This commit is contained in:
Joey Hess 2012-09-13 00:57:52 -04:00
parent a3913f52e5
commit df337bb63b
24 changed files with 91 additions and 97 deletions

View file

@ -162,11 +162,10 @@ 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
checkCanWatch
dstatus <- startDaemonStatus
liftIO $ daemonize $ run dstatus st
startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
checkCanWatch
dstatus <- startDaemonStatus
liftIO $ daemonize $ run dstatus st
where
run dstatus st = do
changechan <- newChangeChan

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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,14 +59,14 @@ 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
, sshRepoName = genSshRepoName hostname dir
, needsPubKey = True
, rsyncOnly = False
}
}
{- Finds the best hostname to use for the host that sent the PairMsg.
-
@ -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) []

View file

@ -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.

View file

@ -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

View file

@ -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]

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -44,27 +44,26 @@ 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
-- We already waited two seconds as a simple rate limiter.
-- Next, wait until at least one commit has been made
commits <- getCommits commitchan
-- Now see if now's a good time to push.
now <- getCurrentTime
if shouldPush now commits
then do
remotes <- filter pushable . knownRemotes
<$> getDaemonStatus dstatus
unless (null remotes) $
void $ alertWhile dstatus (pushAlert remotes) $
pushToRemotes thisThread now st (Just pushmap) remotes
else do
debug thisThread
[ "delaying push of"
, show (length commits)
, "commits"
]
refillCommits commitchan commits
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
-- Now see if now's a good time to push.
now <- getCurrentTime
if shouldPush now commits
then do
remotes <- filter pushable . knownRemotes
<$> getDaemonStatus dstatus
unless (null remotes) $
void $ alertWhile dstatus (pushAlert remotes) $
pushToRemotes thisThread now st (Just pushmap) remotes
else do
debug thisThread
[ "delaying push of"
, show (length commits)
, "commits"
]
refillCommits commitchan commits
where
thread = NamedThread thisThread
pushable r

View file

@ -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

View file

@ -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

View file

@ -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. -}

View file

@ -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]))

View file

@ -44,7 +44,7 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
type Url = String
webAppThread
:: (Maybe ThreadState)
:: Maybe ThreadState
-> DaemonStatusHandle
-> ScanRemoteMap
-> TransferQueue
@ -71,10 +71,9 @@ webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer pos
( return $ httpDebugLogger app
, return app
)
runWebApp app' $ \port -> do
case mst of
Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
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
thread = NamedThread thisThread
getreldir Nothing = return Nothing

View file

@ -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 ()

View file

@ -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

View file

@ -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])

View file

@ -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

View file

@ -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."
)

View file

@ -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 ()