hlint
This commit is contained in:
parent
a3913f52e5
commit
df337bb63b
24 changed files with 91 additions and 97 deletions
|
@ -162,8 +162,7 @@ startDaemon assistant foreground webappwaiter
|
|||
go d = startAssistant assistant d webappwaiter
|
||||
|
||||
startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()) -> Annex ()
|
||||
startAssistant assistant daemonize webappwaiter = do
|
||||
withThreadState $ \st -> do
|
||||
startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
|
||||
checkCanWatch
|
||||
dstatus <- startDaemonStatus
|
||||
liftIO $ daemonize $ run dstatus st
|
||||
|
|
|
@ -5,7 +5,7 @@
|
|||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE RankNTypes, BangPatterns, OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes, OverloadedStrings #-}
|
||||
|
||||
module Assistant.Alert where
|
||||
|
||||
|
@ -227,24 +227,24 @@ activityAlert header dat = baseActivityAlert
|
|||
}
|
||||
|
||||
startupScanAlert :: Alert
|
||||
startupScanAlert = activityAlert Nothing $
|
||||
startupScanAlert = activityAlert Nothing
|
||||
[Tensed "Performing" "Performed", "startup scan"]
|
||||
|
||||
commitAlert :: Alert
|
||||
commitAlert = activityAlert Nothing $
|
||||
commitAlert = activityAlert Nothing
|
||||
[Tensed "Committing" "Committed", "changes to git"]
|
||||
|
||||
showRemotes :: [Remote] -> TenseChunk
|
||||
showRemotes = UnTensed . T.unwords . map (T.pack . Remote.name)
|
||||
|
||||
pushAlert :: [Remote] -> Alert
|
||||
pushAlert rs = activityAlert Nothing $
|
||||
pushAlert rs = activityAlert Nothing
|
||||
[Tensed "Syncing" "Synced", "with", showRemotes rs]
|
||||
|
||||
pushRetryAlert :: [Remote] -> Alert
|
||||
pushRetryAlert rs = activityAlert
|
||||
(Just $ tenseWords [Tensed "Retrying" "Retried", "sync"])
|
||||
(["with", showRemotes rs])
|
||||
["with", showRemotes rs]
|
||||
|
||||
syncAlert :: [Remote] -> Alert
|
||||
syncAlert rs = baseActivityAlert
|
||||
|
@ -308,7 +308,7 @@ pairRequestReceivedAlert repo button = Alert
|
|||
, alertButton = Just button
|
||||
}
|
||||
|
||||
pairRequestAcknowledgedAlert :: String -> (Maybe AlertButton) -> Alert
|
||||
pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
|
||||
pairRequestAcknowledgedAlert repo button = baseActivityAlert
|
||||
{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
|
||||
, alertPriority = High
|
||||
|
|
|
@ -52,7 +52,7 @@ makeSshRemote st dstatus scanremotes forcersync sshdata = do
|
|||
addRemote :: Annex String -> Annex Remote
|
||||
addRemote a = do
|
||||
name <- a
|
||||
void $ remoteListRefresh
|
||||
void remoteListRefresh
|
||||
maybe (error "failed to add remote") return =<< Remote.byName (Just name)
|
||||
|
||||
{- Inits a rsync special remote, and returns the name of the remote. -}
|
||||
|
@ -84,7 +84,7 @@ makeGitRemote basename location = makeRemote basename location $ \name ->
|
|||
makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
|
||||
makeRemote basename location a = do
|
||||
r <- fromRepo id
|
||||
if (null $ filter samelocation $ Git.remotes r)
|
||||
if not (any samelocation $ Git.remotes r)
|
||||
then do
|
||||
let name = uniqueRemoteName r basename 0
|
||||
a name
|
||||
|
|
|
@ -34,7 +34,7 @@ newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
|
|||
verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
|
||||
verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip
|
||||
|
||||
fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData, SomeAddr))
|
||||
fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
|
||||
fromPairMsg (PairMsg m) = m
|
||||
|
||||
pairMsgStage :: PairMsg -> PairStage
|
||||
|
|
|
@ -37,7 +37,7 @@ finishedPairing st dstatus scanremotes msg keypair = do
|
|||
{- Ensure that we know
|
||||
- the ssh host key for the host we paired with.
|
||||
- If we don't, ssh over to get it. -}
|
||||
unlessM (knownHost $ sshHostName sshdata) $ do
|
||||
unlessM (knownHost $ sshHostName sshdata) $
|
||||
void $ sshTranscript
|
||||
[ sshOpt "StrictHostKeyChecking" "no"
|
||||
, sshOpt "NumberOfPasswordPrompts" "0"
|
||||
|
@ -59,7 +59,7 @@ pairMsgToSshData msg = do
|
|||
let dir = case remoteDirectory d of
|
||||
('~':'/':v) -> v
|
||||
v -> v
|
||||
return $ SshData
|
||||
return SshData
|
||||
{ sshHostName = T.pack hostname
|
||||
, sshUserName = Just (T.pack $ remoteUserName d)
|
||||
, sshDirectory = T.pack dir
|
||||
|
@ -75,7 +75,7 @@ pairMsgToSshData msg = do
|
|||
- Otherwise, looks up the hostname in the DNS for the remoteAddress,
|
||||
- if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
|
||||
bestHostName :: PairMsg -> IO HostName
|
||||
bestHostName msg = case (remoteHostName $ pairMsgData msg) of
|
||||
bestHostName msg = case remoteHostName $ pairMsgData msg of
|
||||
Just h -> do
|
||||
let localname = h ++ ".local"
|
||||
addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
|
||||
|
|
|
@ -58,7 +58,7 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
|
|||
threadDelaySeconds (Seconds 2)
|
||||
go cache' $ pred <$> n
|
||||
{- The multicast library currently chokes on ipv6 addresses. -}
|
||||
sendinterface cache (IPv6Addr _) = noop
|
||||
sendinterface _ (IPv6Addr _) = noop
|
||||
sendinterface cache i = void $ catchMaybeIO $
|
||||
withSocketsDo $ bracket setup cleanup use
|
||||
where
|
||||
|
@ -106,7 +106,7 @@ showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
|
|||
|
||||
activeNetworkAddresses :: IO [SomeAddr]
|
||||
activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
|
||||
. concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
|
||||
. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
|
||||
<$> getNetworkInterfaces
|
||||
|
||||
{- A human-visible description of the repository being paired with.
|
||||
|
|
|
@ -79,7 +79,9 @@ sshTranscript opts input = do
|
|||
_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
|
||||
|
||||
-- now write and flush any input
|
||||
when (not (null input)) $ do hPutStr inh input; hFlush inh
|
||||
unless (null input) $ do
|
||||
hPutStr inh input
|
||||
hFlush inh
|
||||
hClose inh -- done with stdin
|
||||
|
||||
-- wait on the output
|
||||
|
@ -114,13 +116,12 @@ removeAuthorizedKeys rsynconly pubkey = do
|
|||
sshdir <- sshDir
|
||||
let keyfile = sshdir </> ".authorized_keys"
|
||||
ls <- lines <$> readFileStrict keyfile
|
||||
writeFile keyfile $ unlines $
|
||||
filter (\l -> not $ l == keyline) ls
|
||||
writeFile keyfile $ unlines $ filter (/= keyline) ls
|
||||
|
||||
{- Implemented as a shell command, so it can be run on remote servers over
|
||||
- ssh. -}
|
||||
addAuthorizedKeysCommand :: Bool -> SshPubKey -> String
|
||||
addAuthorizedKeysCommand rsynconly pubkey = join "&&" $
|
||||
addAuthorizedKeysCommand rsynconly pubkey = join "&&"
|
||||
[ "mkdir -p ~/.ssh"
|
||||
, "touch ~/.ssh/authorized_keys"
|
||||
, "chmod 600 ~/.ssh/authorized_keys"
|
||||
|
@ -169,7 +170,7 @@ setupSshKeyPair sshkeypair sshdata = do
|
|||
(unionFileModes ownerWriteMode ownerReadMode)
|
||||
hPutStr h (sshPrivKey sshkeypair)
|
||||
hClose h
|
||||
unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ do
|
||||
unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
|
||||
writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
|
||||
|
||||
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
|
||||
|
@ -186,7 +187,7 @@ setupSshKeyPair sshkeypair sshdata = do
|
|||
sshprivkeyfile = "key." ++ mangledhost
|
||||
sshpubkeyfile = sshprivkeyfile ++ ".pub"
|
||||
mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
|
||||
user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
|
||||
user = maybe "" (\u -> '-' : T.unpack u) (sshUserName sshdata)
|
||||
|
||||
{- Does ssh have known_hosts data for a hostname? -}
|
||||
knownHost :: Text -> IO Bool
|
||||
|
|
|
@ -60,7 +60,7 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
|
|||
-
|
||||
- Avoids running possibly long-duration commands in the Annex monad, so
|
||||
- as not to block other threads. -}
|
||||
pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool
|
||||
pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe FailedPushMap -> [Remote] -> IO Bool
|
||||
pushToRemotes threadname now st mpushmap remotes = do
|
||||
(g, branch) <- runThreadState st $
|
||||
(,) <$> fromRepo id <*> inRepo Git.Branch.current
|
||||
|
@ -81,12 +81,12 @@ pushToRemotes threadname now st mpushmap remotes = do
|
|||
changeFailedPushMap pushmap $ \m ->
|
||||
M.union (makemap failed) $
|
||||
M.difference m (makemap succeeded)
|
||||
unless (ok) $
|
||||
unless ok $
|
||||
debug threadname
|
||||
[ "failed to push to"
|
||||
, show failed
|
||||
]
|
||||
if (ok || not shouldretry)
|
||||
if ok || not shouldretry
|
||||
then return ok
|
||||
else retry branch g failed
|
||||
|
||||
|
@ -100,12 +100,12 @@ pushToRemotes threadname now st mpushmap remotes = do
|
|||
go False (Just branch) g rs
|
||||
|
||||
{- Manually pull from remotes and merge their branches. -}
|
||||
manualPull :: ThreadState -> (Maybe Git.Ref) -> [Remote] -> IO Bool
|
||||
manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool
|
||||
manualPull st currentbranch remotes = do
|
||||
g <- runThreadState st $ fromRepo id
|
||||
forM_ remotes $ \r ->
|
||||
Git.Command.runBool "fetch" [Param $ Remote.name r] g
|
||||
haddiverged <- runThreadState st $ Annex.Branch.forceUpdate
|
||||
haddiverged <- runThreadState st Annex.Branch.forceUpdate
|
||||
forM_ remotes $ \r ->
|
||||
runThreadState st $ Command.Sync.mergeRemote r currentbranch
|
||||
return haddiverged
|
||||
|
@ -114,4 +114,4 @@ manualPull st currentbranch remotes = do
|
|||
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
|
||||
syncNewRemote st dstatus scanremotes remote = do
|
||||
runThreadState st $ updateKnownRemotes dstatus
|
||||
void $ forkIO $ do reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]
|
||||
void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]
|
||||
|
|
|
@ -132,7 +132,7 @@ handleAdds st changechan transferqueue dstatus cs = returnWhen (null pendingadds
|
|||
|
||||
returnWhen (null toadd) $ do
|
||||
added <- catMaybes <$> forM toadd add
|
||||
if (DirWatcher.eventsCoalesce || null added)
|
||||
if DirWatcher.eventsCoalesce || null added
|
||||
then return $ added ++ otherchanges
|
||||
else do
|
||||
r <- handleAdds st changechan transferqueue dstatus
|
||||
|
|
|
@ -44,7 +44,7 @@ type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO ()
|
|||
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
||||
-}
|
||||
runHandler :: Git.Repo -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
||||
runHandler g handler file filestatus = void $ do
|
||||
runHandler g handler file filestatus = void $
|
||||
either print (const noop) =<< tryIO go
|
||||
where
|
||||
go = handler g file filestatus
|
||||
|
|
|
@ -34,7 +34,7 @@ thisThread :: ThreadName
|
|||
thisThread = "NetWatcher"
|
||||
|
||||
netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
|
||||
netWatcherThread st dstatus scanremotes = thread $ do
|
||||
netWatcherThread st dstatus scanremotes = thread $
|
||||
#if WITH_DBUS
|
||||
dbusThread st dstatus scanremotes
|
||||
#else
|
||||
|
@ -49,7 +49,7 @@ netWatcherThread st dstatus scanremotes = thread $ do
|
|||
- while (despite the local network staying up), are synced with
|
||||
- periodically. -}
|
||||
netWatcherFallbackThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
|
||||
netWatcherFallbackThread st dstatus scanremotes = thread $ do
|
||||
netWatcherFallbackThread st dstatus scanremotes = thread $
|
||||
runEvery (Seconds 3600) $
|
||||
handleConnection st dstatus scanremotes
|
||||
where
|
||||
|
|
|
@ -50,7 +50,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
|
|||
else do
|
||||
pairReqReceived verified dstatus urlrenderer m
|
||||
go sock (m:take 10 reqs) (invalidateCache m cache)
|
||||
(_, _, PairAck) -> do
|
||||
(_, _, PairAck) ->
|
||||
pairAckReceived verified pip st dstatus scanremotes m cache
|
||||
>>= go sock reqs
|
||||
(_, _, PairDone) -> do
|
||||
|
@ -65,8 +65,8 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
|
|||
-}
|
||||
verificationCheck m (Just pip) = do
|
||||
let verified = verifiedPairMsg m pip
|
||||
let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData $ m)
|
||||
if (not verified && sameuuid)
|
||||
let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
|
||||
if not verified && sameuuid
|
||||
then do
|
||||
runThreadState st $
|
||||
warning "detected possible pairing brute force attempt; disabled pairing"
|
||||
|
@ -88,8 +88,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
|
|||
{- PairReqs invalidate the cache of recently finished pairings.
|
||||
- This is so that, if a new pairing is started with the
|
||||
- same secret used before, a bogus PairDone is not sent. -}
|
||||
invalidateCache msg =
|
||||
filter (\pip -> not $ verifiedPairMsg msg pip)
|
||||
invalidateCache msg = filter (not . verifiedPairMsg msg)
|
||||
|
||||
getmsg sock c = do
|
||||
(msg, n, _) <- recvFrom sock chunksz
|
||||
|
@ -124,7 +123,7 @@ pairAckReceived True (Just pip) st dstatus scanremotes msg cache = do
|
|||
finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
|
||||
startSending dstatus pip PairDone $ multicastPairMsg
|
||||
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
|
||||
return $ pip:(take 10 cache)
|
||||
return $ pip : take 10 cache
|
||||
{- A stale PairAck might also be seen, after we've finished pairing.
|
||||
- Perhaps our PairDone was not received. To handle this, we keep
|
||||
- a cache of recently finished pairings, and re-send PairDone in
|
||||
|
|
|
@ -44,8 +44,7 @@ pushRetryThread st dstatus pushmap = thread $ runEvery (Seconds halfhour) $ do
|
|||
|
||||
{- This thread pushes git commits out to remotes soon after they are made. -}
|
||||
pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> NamedThread
|
||||
pushThread st dstatus commitchan pushmap = thread $ do
|
||||
runEvery (Seconds 2) $ do
|
||||
pushThread st dstatus commitchan pushmap = thread $ runEvery (Seconds 2) $ do
|
||||
-- We already waited two seconds as a simple rate limiter.
|
||||
-- Next, wait until at least one commit has been made
|
||||
commits <- getCommits commitchan
|
||||
|
|
|
@ -43,7 +43,7 @@ transferScannerThread st dstatus scanremotes transferqueue = thread $ do
|
|||
if any fullScan infos || any (`S.notMember` scanned) rs
|
||||
then do
|
||||
expensiveScan st dstatus transferqueue rs
|
||||
go (S.union scanned (S.fromList rs))
|
||||
go $ scanned `S.union` S.fromList rs
|
||||
else do
|
||||
mapM_ (failedTransferScan st dstatus transferqueue) rs
|
||||
go scanned
|
||||
|
@ -129,7 +129,7 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do
|
|||
)
|
||||
check direction want key locs r
|
||||
| direction == Upload && Remote.readonly r = Nothing
|
||||
| (Remote.uuid r `elem` locs) == want = Just $
|
||||
| (Remote.uuid r `elem` locs) == want = Just
|
||||
(r, Transfer direction (Remote.uuid r) key)
|
||||
| otherwise = Nothing
|
||||
|
||||
|
|
|
@ -43,7 +43,7 @@ type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus
|
|||
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
||||
-}
|
||||
runHandler :: ThreadState -> DaemonStatusHandle -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
||||
runHandler st dstatus handler file filestatus = void $ do
|
||||
runHandler st dstatus handler file filestatus = void $
|
||||
either print (const noop) =<< tryIO go
|
||||
where
|
||||
go = handler st dstatus file filestatus
|
||||
|
|
|
@ -38,7 +38,7 @@ transfererThread st dstatus transferqueue slots = thread $ go =<< readProgramFil
|
|||
maybe (return Nothing) (uncurry $ startTransfer st dstatus program)
|
||||
=<< getNextTransfer transferqueue dstatus notrunning
|
||||
{- Skip transfers that are already running. -}
|
||||
notrunning i = startedTime i == Nothing
|
||||
notrunning = isNothing . startedTime
|
||||
|
||||
{- By the time this is called, the daemonstatus's transfer map should
|
||||
- already have been updated to include the transfer. -}
|
||||
|
|
|
@ -44,7 +44,7 @@ thisThread = "Watcher"
|
|||
checkCanWatch :: Annex ()
|
||||
checkCanWatch
|
||||
| canWatch =
|
||||
unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) $
|
||||
unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force)
|
||||
needLsof
|
||||
| otherwise = error "watch mode is not available on this system"
|
||||
|
||||
|
@ -75,7 +75,7 @@ watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
|
|||
startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
|
||||
startupScan st dstatus scanner = do
|
||||
runThreadState st $ showAction "scanning"
|
||||
r <- alertWhile' dstatus startupScanAlert $ do
|
||||
alertWhile' dstatus startupScanAlert $ do
|
||||
r <- scanner
|
||||
|
||||
-- Notice any files that were deleted before
|
||||
|
@ -88,8 +88,6 @@ startupScan st dstatus scanner = do
|
|||
|
||||
return (True, r)
|
||||
|
||||
return r
|
||||
|
||||
ignored :: FilePath -> Bool
|
||||
ignored = ig . takeFileName
|
||||
where
|
||||
|
@ -135,7 +133,7 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu
|
|||
-}
|
||||
onAdd :: Handler
|
||||
onAdd threadname file filestatus dstatus _
|
||||
| maybe False isRegularFile filestatus = do
|
||||
| maybe False isRegularFile filestatus =
|
||||
ifM (scanComplete <$> liftIO (getDaemonStatus dstatus))
|
||||
( go
|
||||
, ifM (null <$> inRepo (Git.LsFiles.notInRepo False [file]))
|
||||
|
|
|
@ -44,7 +44,7 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
|||
type Url = String
|
||||
|
||||
webAppThread
|
||||
:: (Maybe ThreadState)
|
||||
:: Maybe ThreadState
|
||||
-> DaemonStatusHandle
|
||||
-> ScanRemoteMap
|
||||
-> TransferQueue
|
||||
|
@ -71,8 +71,7 @@ webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer pos
|
|||
( return $ httpDebugLogger app
|
||||
, return app
|
||||
)
|
||||
runWebApp app' $ \port -> do
|
||||
case mst of
|
||||
runWebApp app' $ \port -> case mst of
|
||||
Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
|
||||
Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
|
||||
where
|
||||
|
|
|
@ -107,9 +107,8 @@ queueTransferAt :: Int -> Schedule -> TransferQueue -> DaemonStatusHandle -> Ass
|
|||
queueTransferAt wantsz schedule q dstatus f t remote = do
|
||||
atomically $ do
|
||||
sz <- readTVar (queuesize q)
|
||||
if sz <= wantsz
|
||||
then return ()
|
||||
else retry -- blocks until queuesize changes
|
||||
unless (sz <= wantsz) $
|
||||
retry -- blocks until queuesize changes
|
||||
enqueue schedule q dstatus t (stubInfo f remote)
|
||||
|
||||
queueTransferWhenSmall :: TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
|
||||
|
|
|
@ -69,11 +69,11 @@ inImmediateTransferSlot dstatus s gen = do
|
|||
runTransferThread :: DaemonStatusHandle -> TransferSlots -> Maybe (Transfer, TransferInfo, IO ()) -> IO ()
|
||||
runTransferThread _ s Nothing = signalQSemN s 1
|
||||
runTransferThread dstatus s (Just (t, info, a)) = do
|
||||
tid <- forkIO $ go
|
||||
tid <- forkIO go
|
||||
updateTransferInfo dstatus t $ info { transferTid = Just tid }
|
||||
where
|
||||
go = catchPauseResume a
|
||||
pause = catchPauseResume $ runEvery (Seconds 86400) $ noop
|
||||
pause = catchPauseResume $ runEvery (Seconds 86400) noop
|
||||
{- Note: This must use E.try, rather than E.catch.
|
||||
- When E.catch is used, and has called go in its exception
|
||||
- handler, Control.Concurrent.throwTo will block sometimes
|
||||
|
|
|
@ -48,7 +48,7 @@ repoList = do
|
|||
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
|
||||
l <- runAnnex [] $ do
|
||||
u <- getUUID
|
||||
Remote.prettyListUUIDs $ nub $ u:(map Remote.uuid rs)
|
||||
Remote.prettyListUUIDs $ nub $ u : map Remote.uuid rs
|
||||
return $ zip counter l
|
||||
where
|
||||
counter = map show ([1..] :: [Int])
|
||||
|
|
|
@ -50,7 +50,7 @@ mkSshData sshserver = SshData
|
|||
, rsyncOnly = False
|
||||
}
|
||||
|
||||
sshServerAForm :: (Maybe Text) -> AForm WebApp WebApp SshServer
|
||||
sshServerAForm :: Maybe Text -> AForm WebApp WebApp SshServer
|
||||
sshServerAForm localusername = SshServer
|
||||
<$> aopt check_hostname "Host name" Nothing
|
||||
<*> aopt check_username "User name" (Just localusername)
|
||||
|
@ -99,7 +99,7 @@ getAddSshR = sshConfigurator $ do
|
|||
then lift $ redirect $ ConfirmSshR $
|
||||
(mkSshData sshserver)
|
||||
{ needsPubKey = needspubkey
|
||||
, rsyncOnly = (status == UsableRsyncServer)
|
||||
, rsyncOnly = status == UsableRsyncServer
|
||||
}
|
||||
else showform form enctype status
|
||||
_ -> showform form enctype UntestedServer
|
||||
|
@ -130,7 +130,7 @@ testServer sshserver@(SshServer { hostname = Just hn }) = do
|
|||
return (status', True)
|
||||
where
|
||||
probe extraopts = do
|
||||
let remotecommand = join ";" $
|
||||
let remotecommand = join ";"
|
||||
[ report "loggedin"
|
||||
, checkcommand "git-annex-shell"
|
||||
, checkcommand "rsync"
|
||||
|
@ -186,7 +186,7 @@ getMakeSshRsyncR = makeSsh True
|
|||
makeSsh :: Bool -> SshData -> Handler RepHtml
|
||||
makeSsh rsync sshdata
|
||||
| needsPubKey sshdata = do
|
||||
keypair <- liftIO $ genSshKeyPair
|
||||
keypair <- liftIO genSshKeyPair
|
||||
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
|
||||
makeSsh' rsync sshdata' (Just keypair)
|
||||
| otherwise = makeSsh' rsync sshdata Nothing
|
||||
|
@ -201,10 +201,10 @@ makeSsh' rsync sshdata keypair =
|
|||
remoteCommand = join "&&" $ catMaybes
|
||||
[ Just $ "mkdir -p " ++ shellEscape remotedir
|
||||
, Just $ "cd " ++ shellEscape remotedir
|
||||
, if rsync then Nothing else Just $ "git init --bare --shared"
|
||||
, if rsync then Nothing else Just $ "git annex init"
|
||||
, if rsync then Nothing else Just "git init --bare --shared"
|
||||
, if rsync then Nothing else Just "git annex init"
|
||||
, if needsPubKey sshdata
|
||||
then maybe Nothing (Just . addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair
|
||||
then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair
|
||||
else Nothing
|
||||
]
|
||||
|
||||
|
@ -246,13 +246,13 @@ getAddRsyncNetR = do
|
|||
- to not need to use a different method to create
|
||||
- it.
|
||||
-}
|
||||
let remotecommand = join ";" $
|
||||
let remotecommand = join ";"
|
||||
[ "mkdir -p .ssh"
|
||||
, "touch .ssh/authorized_keys"
|
||||
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
||||
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
|
||||
]
|
||||
let sshopts = filter (not . null) $
|
||||
let sshopts = filter (not . null)
|
||||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||||
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||
, remotecommand
|
||||
|
|
|
@ -34,7 +34,7 @@ seek = [withFlag Command.Watch.stopOption $ \stopdaemon ->
|
|||
start :: Bool -> Bool -> Bool -> CommandStart
|
||||
start foreground stopdaemon autostart
|
||||
| autostart = do
|
||||
liftIO $ autoStart
|
||||
liftIO autoStart
|
||||
stop
|
||||
| otherwise = do
|
||||
ensureInitialized
|
||||
|
@ -43,7 +43,7 @@ start foreground stopdaemon autostart
|
|||
{- Run outside a git repository. Check to see if any parameter is
|
||||
- --autostart and enter autostart mode. -}
|
||||
checkAutoStart :: IO ()
|
||||
checkAutoStart = ifM (any (== "--autostart") <$> getArgs)
|
||||
checkAutoStart = ifM (elem "--autostart" <$> getArgs)
|
||||
( autoStart
|
||||
, error "Not in a git repository."
|
||||
)
|
||||
|
|
|
@ -39,13 +39,13 @@ seek = [withNothing start]
|
|||
|
||||
start :: CommandStart
|
||||
start = notBareRepo $ do
|
||||
ifM (isInitialized) ( go , liftIO startNoRepo )
|
||||
ifM isInitialized ( go , liftIO startNoRepo )
|
||||
stop
|
||||
where
|
||||
go = do
|
||||
browser <- fromRepo webBrowser
|
||||
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
|
||||
ifM (checkpid <&&> checkshim f) $
|
||||
ifM (checkpid <&&> checkshim f)
|
||||
( liftIO $ openBrowser browser f
|
||||
, startDaemon True True $ Just $
|
||||
const $ openBrowser browser
|
||||
|
@ -116,7 +116,7 @@ firstRun = do
|
|||
startAssistant True id $ Just $ sendurlback v
|
||||
sendurlback v url _htmlshim = putMVar v url
|
||||
{- Set up the pid file in the new repo. -}
|
||||
dummydaemonize = do
|
||||
dummydaemonize =
|
||||
liftIO . lockPidFile =<< fromRepo gitAnnexPidFile
|
||||
|
||||
openBrowser :: Maybe FilePath -> FilePath -> IO ()
|
||||
|
|
Loading…
Add table
Reference in a new issue