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