hlint
This commit is contained in:
		
					parent
					
						
							
								a3913f52e5
							
						
					
				
			
			
				commit
				
					
						df337bb63b
					
				
			
		
					 24 changed files with 91 additions and 97 deletions
				
			
		|  | @ -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 | ||||
|  |  | |||
|  | @ -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,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) [] | ||||
|  |  | |||
|  | @ -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,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 | ||||
|  |  | |||
|  | @ -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,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 | ||||
|  |  | |||
|  | @ -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
		Add a link
		
	
		Reference in a new issue
	
	 Joey Hess
				Joey Hess