diff options
Diffstat (limited to 'Assistant')
76 files changed, 770 insertions, 320 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 192952f56..1286e4590 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -1,6 +1,6 @@ {- git-annex assistant alerts - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,6 +16,7 @@ import qualified Remote import Utility.Tense import Logs.Transfer import Types.Distribution +import Git.Types (RemoteName) import Data.String import qualified Data.Text as T @@ -117,11 +118,14 @@ commitAlert :: Alert commitAlert = activityAlert Nothing [Tensed "Committing" "Committed", "changes to git"] -showRemotes :: [Remote] -> TenseChunk -showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name) +showRemotes :: [RemoteName] -> TenseChunk +showRemotes = UnTensed . T.intercalate ", " . map T.pack syncAlert :: [Remote] -> Alert -syncAlert rs = baseActivityAlert +syncAlert = syncAlert' . map Remote.name + +syncAlert' :: [RemoteName] -> Alert +syncAlert' rs = baseActivityAlert { alertName = Just SyncAlert , alertHeader = Just $ tenseWords [Tensed "Syncing" "Synced", "with", showRemotes rs] @@ -130,13 +134,18 @@ syncAlert rs = baseActivityAlert } syncResultAlert :: [Remote] -> [Remote] -> Alert -syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $ +syncResultAlert succeeded failed = syncResultAlert' + (map Remote.name succeeded) + (map Remote.name failed) + +syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert +syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $ baseActivityAlert { alertName = Just SyncAlert , alertHeader = Just $ tenseWords msg } where - msg + msg | null succeeded = ["Failed to sync with", showRemotes failed] | null failed = ["Synced with", showRemotes succeeded] | otherwise = @@ -320,10 +329,10 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert , alertButtons = maybeToList button } -xmppNeededAlert :: AlertButton -> Alert -xmppNeededAlert button = Alert +connectionNeededAlert :: AlertButton -> Alert +connectionNeededAlert button = Alert { alertHeader = Just "Share with friends, and keep your devices in sync across the cloud." - , alertIcon = Just TheCloud + , alertIcon = Just ConnectionIcon , alertPriority = High , alertButtons = [button] , alertClosable = True @@ -331,7 +340,7 @@ xmppNeededAlert button = Alert , alertMessageRender = renderData , alertCounter = 0 , alertBlockDisplay = True - , alertName = Just $ XMPPNeededAlert + , alertName = Just ConnectionNeededAlert , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertData = [] } diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs index 73843be4c..65484e0e6 100644 --- a/Assistant/Alert/Utility.hs +++ b/Assistant/Alert/Utility.hs @@ -1,6 +1,6 @@ {- git-annex assistant alert utilities - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,7 +14,6 @@ import Utility.Tense import qualified Data.Text as T import Data.Text (Text) import qualified Data.Map as M -import Data.Monoid {- This is as many alerts as it makes sense to display at a time. - A display might be smaller, or larger, the point is to not overwhelm the @@ -120,7 +119,7 @@ mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al) where bloat = M.size m' - maxAlerts pruneold l = - let (f, rest) = partition (\(_, a) -> isFiller a) l + let (f, rest) = partition (\(_, a) -> isFiller a) l in drop bloat f ++ rest updatePrune = pruneBloat $ M.filterWithKey pruneSame $ M.insertWith' const i al m diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs index c9354544a..c588c910a 100644 --- a/Assistant/BranchChange.hs +++ b/Assistant/BranchChange.hs @@ -1,6 +1,6 @@ {- git-annex assistant git-annex branch change tracking - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs index 2ecd2036c..6eb9bc28e 100644 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -1,6 +1,6 @@ {- git-annex assistant change tracking - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs index 7d1d3780f..c82f8f4c7 100644 --- a/Assistant/Commits.hs +++ b/Assistant/Commits.hs @@ -1,6 +1,6 @@ {- git-annex assistant commit tracking - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Common.hs b/Assistant/Common.hs index f9719422d..5fab84290 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -1,6 +1,6 @@ {- Common infrastructure for the git-annex assistant. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/CredPairCache.hs b/Assistant/CredPairCache.hs new file mode 100644 index 000000000..ac355b55a --- /dev/null +++ b/Assistant/CredPairCache.hs @@ -0,0 +1,53 @@ +{- git-annex assistant CredPair cache. + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Assistant.CredPairCache ( + cacheCred, + getCachedCred, + expireCachedCred, +) where + +import Assistant.Types.CredPairCache +import Types.Creds +import Assistant.Common +import Utility.ThreadScheduler + +import qualified Data.Map as M +import Control.Concurrent + +{- Caches a CredPair, but only for a limited time, after which it + - will expire. + - + - Note that repeatedly caching the same CredPair + - does not reset its expiry time. + -} +cacheCred :: CredPair -> Seconds -> Assistant () +cacheCred (login, password) expireafter = do + cache <- getAssistant credPairCache + liftIO $ do + changeStrict cache $ M.insert login password + void $ forkIO $ do + threadDelaySeconds expireafter + changeStrict cache $ M.delete login + +getCachedCred :: Login -> Assistant (Maybe Password) +getCachedCred login = do + cache <- getAssistant credPairCache + liftIO $ M.lookup login <$> readMVar cache + +expireCachedCred :: Login -> Assistant () +expireCachedCred login = do + cache <- getAssistant credPairCache + liftIO $ changeStrict cache $ M.delete login + +{- Update map strictly to avoid keeping references to old creds in memory. -} +changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO () +changeStrict cache a = modifyMVar_ cache $ \m -> do + let !m' = a m + return m' diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index eb842b784..1ed40595e 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -1,6 +1,6 @@ {- git-annex assistant daemon status - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -26,6 +26,7 @@ import Data.Time.Clock.POSIX import Data.Time import System.Locale import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T getDaemonStatus :: Assistant DaemonStatus @@ -64,7 +65,7 @@ calcSyncRemotes = do , syncingToCloudRemote = any iscloud syncdata } where - iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable + iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable {- Updates the syncRemotes list from the list of all remotes in Annex state. -} updateSyncRemotes :: Assistant () @@ -78,6 +79,15 @@ updateSyncRemotes = do M.filter $ \alert -> alertName alert /= Just CloudRepoNeededAlert +changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant () +changeCurrentlyConnected sm = do + modifyDaemonStatus_ $ \ds -> ds + { currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds) + } + v <- currentlyConnectedRemotes <$> getDaemonStatus + debug [show v] + liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus + updateScheduleLog :: Assistant () updateScheduleLog = liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs index cc05786e4..5b044fd18 100644 --- a/Assistant/DeleteRemote.hs +++ b/Assistant/DeleteRemote.hs @@ -1,6 +1,6 @@ {- git-annex assistant remote deletion utilities - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,7 +17,7 @@ import Logs.Location import Assistant.DaemonStatus import qualified Remote import Remote.List -import qualified Git.Remote +import qualified Git.Remote.Remove import Logs.Trust import qualified Annex @@ -34,7 +34,7 @@ disableRemote uuid = do remote <- fromMaybe (error "unknown remote") <$> liftAnnex (Remote.remoteFromUUID uuid) liftAnnex $ do - inRepo $ Git.Remote.remove (Remote.name remote) + inRepo $ Git.Remote.Remove.remove (Remote.name remote) void $ remoteListRefresh updateSyncRemotes return remote @@ -62,7 +62,7 @@ removableRemote urlrenderer uuid = do <$> liftAnnex (Remote.remoteFromUUID uuid) mapM_ (queueremaining r) keys where - queueremaining r k = + queueremaining r k = queueTransferWhenSmall "remaining object in unwanted remote" Nothing (Transfer Download uuid k) r {- Scanning for keys can take a long time; do not tie up diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index efd74fdb3..57eef8f3a 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -1,6 +1,6 @@ {- git-annex assistant dropping of unwanted content - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Install.hs b/Assistant/Install.hs index d29cefb8c..6da6d2389 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -1,6 +1,6 @@ {- Assistant installation - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -22,6 +22,9 @@ import Utility.SshConfig import Utility.OSX #else import Utility.FreeDesktop +#ifdef linux_HOST_OS +import Utility.UserInfo +#endif import Assistant.Install.Menu #endif @@ -30,16 +33,19 @@ standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" {- The standalone app does not have an installation process. - So when it's run, it needs to set up autostarting of the assistant - - daemon, as well as writing the programFile, and putting a - - git-annex-shell wrapper into ~/.ssh + - daemon, as well as writing the programFile, and putting the + - git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh - - Note that this is done every time it's started, so if the user moves - it around, the paths this sets up won't break. + - + - File manager hook script installation is done even for + - packaged apps, since it has to go into the user's home directory. -} ensureInstalled :: IO () ensureInstalled = go =<< standaloneAppBase where - go Nothing = noop + go Nothing = installFileManagerHooks "git-annex" go (Just base) = do let program = base </> "git-annex" programfile <- programFile @@ -56,27 +62,98 @@ ensureInstalled = go =<< standaloneAppBase #endif installAutoStart program autostartfile - {- This shim is only updated if it doesn't - - already exist with the right content. -} sshdir <- sshDir - let shim = sshdir </> "git-annex-shell" - let runshell var = "exec " ++ base </> "runshell" ++ - " git-annex-shell -c \"" ++ var ++ "\"" - let content = unlines + let runshell var = "exec " ++ base </> "runshell " ++ var + let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\"" + + installWrapper (sshdir </> "git-annex-shell") $ unlines [ shebang_local , "set -e" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" - , runshell "$SSH_ORIGINAL_COMMAND" + , rungitannexshell "$SSH_ORIGINAL_COMMAND" , "else" - , runshell "$@" + , rungitannexshell "$@" , "fi" ] + installWrapper (sshdir </> "git-annex-wrapper") $ unlines + [ shebang_local + , "set -e" + , runshell "\"$@\"" + ] + + installFileManagerHooks program + +installWrapper :: FilePath -> String -> IO () +installWrapper file content = do + curr <- catchDefaultIO "" $ readFileStrict file + when (curr /= content) $ do + createDirectoryIfMissing True (parentDir file) + viaTmp writeFile file content + modifyFileMode file $ addModes [ownerExecuteMode] + +installFileManagerHooks :: FilePath -> IO () +#ifdef linux_HOST_OS +installFileManagerHooks program = do + let actions = ["get", "drop", "undo"] - curr <- catchDefaultIO "" $ readFileStrict shim - when (curr /= content) $ do - createDirectoryIfMissing True (parentDir shim) - viaTmp writeFile shim content - modifyFileMode shim $ addModes [ownerExecuteMode] + -- Gnome + nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir + createDirectoryIfMissing True nautilusScriptdir + forM_ actions $ + genNautilusScript nautilusScriptdir + + -- KDE + home <- myHomeDir + let kdeServiceMenusdir = home </> ".kde" </> "share" </> "kde4" </> "services" </> "ServiceMenus" + createDirectoryIfMissing True kdeServiceMenusdir + writeFile (kdeServiceMenusdir </> "git-annex.desktop") + (kdeDesktopFile actions) + where + genNautilusScript scriptdir action = + installscript (scriptdir </> scriptname action) $ unlines + [ shebang_local + , autoaddedcomment + , "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" + ] + scriptname action = "git-annex " ++ action + installscript f c = whenM (safetoinstallscript f) $ do + writeFile f c + modifyFileMode f $ addModes [ownerExecuteMode] + safetoinstallscript f = catchDefaultIO True $ + elem autoaddedcomment . lines <$> readFileStrict f + autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" + autoaddedmsg = "Automatically added by git-annex, do not edit." + + kdeDesktopFile actions = unlines $ concat $ + kdeDesktopHeader actions : map kdeDesktopAction actions + kdeDesktopHeader actions = + [ "# " ++ autoaddedmsg + , "[Desktop Entry]" + , "Type=Service" + , "ServiceTypes=all/allfiles" + , "MimeType=all/all;" + , "Actions=" ++ intercalate ";" (map kdeDesktopSection actions) + , "X-KDE-Priority=TopLevel" + , "X-KDE-Submenu=Git-Annex" + , "X-KDE-Icon=git-annex" + , "X-KDE-ServiceTypes=KonqPopupMenu/Plugin" + ] + kdeDesktopSection command = "GitAnnex" ++ command + kdeDesktopAction command = + [ "" + , "[Desktop Action " ++ kdeDesktopSection command ++ "]" + , "Name=" ++ command + , "Icon=git-annex" + , unwords + [ "Exec=sh -c 'cd \"$(dirname '%U')\" &&" + , program + , command + , "--notify-start --notify-finish -- %U'" + ] + ] +#else +installFileManagerHooks _ = noop +#endif {- Returns a cleaned up environment that lacks settings used to make the - standalone builds use their bundled libraries and programs. @@ -87,15 +164,15 @@ ensureInstalled = go =<< standaloneAppBase cleanEnvironment :: IO (Maybe [(String, String)]) cleanEnvironment = clean <$> getEnvironment where - clean env + clean environ | null vars = Nothing - | otherwise = Just $ catMaybes $ map (restoreorig env) env + | otherwise = Just $ catMaybes $ map (restoreorig environ) environ | otherwise = Nothing where vars = words $ fromMaybe "" $ - lookup "GIT_ANNEX_STANDLONE_ENV" env - restoreorig oldenv p@(k, _v) - | k `elem` vars = case lookup ("ORIG_" ++ k) oldenv of + lookup "GIT_ANNEX_STANDLONE_ENV" environ + restoreorig oldenviron p@(k, _v) + | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of (Just v') | not (null v') -> Just (k, v') _ -> Nothing diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs index b03d20224..b27b69775 100644 --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -1,6 +1,6 @@ {- Assistant autostart file installation - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs index d095cdd88..32393abaf 100644 --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -1,6 +1,6 @@ {- Assistant menu installation. - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 349d4af9c..a5eace724 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -1,6 +1,6 @@ {- git-annex assistant remote creation utilities - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -48,7 +48,7 @@ makeRsyncRemote :: RemoteName -> String -> Annex String makeRsyncRemote name location = makeRemote name location $ const $ void $ go =<< Command.InitRemote.findExisting name where - go Nothing = setupSpecialRemote name Rsync.remote config Nothing + go Nothing = setupSpecialRemote name Rsync.remote config Nothing (Nothing, Command.InitRemote.newConfig name) go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing (Just u, c) @@ -90,18 +90,23 @@ enableSpecialRemote name remotetype mcreds config = do r <- Command.InitRemote.findExisting name case r of Nothing -> error $ "Cannot find a special remote named " ++ name - Just (u, c) -> setupSpecialRemote name remotetype config mcreds (Just u, c) + Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, c) setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName -setupSpecialRemote name remotetype config mcreds (mu, c) = do +setupSpecialRemote = setupSpecialRemote' True + +setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName +setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do {- Currently, only 'weak' ciphers can be generated from the - assistant, because otherwise GnuPG may block once the entropy - pool is drained, and as of now there's no way to tell the user - to perform IO actions to refill the pool. -} (c', u) <- R.setup remotetype mu mcreds $ M.insert "highRandomQuality" "false" $ M.union config c - describeUUID u name configSet u c' + when setdesc $ + whenM (isNothing . M.lookup u <$> uuidMap) $ + describeUUID u name return name {- Returns the name of the git remote it created. If there's already a diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 7c28c7f6f..a34264a01 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -1,6 +1,6 @@ {- git-annex assistant monad - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -43,6 +43,8 @@ import Assistant.Types.RepoProblem import Assistant.Types.Buddies import Assistant.Types.NetMessager import Assistant.Types.ThreadName +import Assistant.Types.RemoteControl +import Assistant.Types.CredPairCache newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } deriving ( @@ -68,6 +70,8 @@ data AssistantData = AssistantData , branchChangeHandle :: BranchChangeHandle , buddyList :: BuddyList , netMessager :: NetMessager + , remoteControl :: RemoteControl + , credPairCache :: CredPairCache } newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData @@ -86,6 +90,8 @@ newAssistantData st dstatus = AssistantData <*> newBranchChangeHandle <*> newBuddyList <*> newNetMessager + <*> newRemoteControl + <*> newCredPairCache runAssistant :: AssistantData -> Assistant a -> IO a runAssistant d a = runReaderT (mkAssistant a) d diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index e1b3983f7..f80953053 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -1,6 +1,6 @@ {- git-annex assistant named threads. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs index acb18b648..dd1811141 100644 --- a/Assistant/NetMessager.hs +++ b/Assistant/NetMessager.hs @@ -1,6 +1,6 @@ {- git-annex assistant out of band network messager interface - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -80,7 +80,7 @@ checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager queuePushInitiation :: NetMessage -> Assistant () queuePushInitiation msg@(Pushing clientid stage) = do tv <- getPushInitiationQueue side - liftIO $ atomically $ do + liftIO $ atomically $ do r <- tryTakeTMVar tv case r of Nothing -> putTMVar tv [msg] @@ -88,7 +88,7 @@ queuePushInitiation msg@(Pushing clientid stage) = do let !l' = msg : filter differentclient l putTMVar tv l' where - side = pushDestinationSide stage + side = pushDestinationSide stage differentclient (Pushing cid _) = cid /= clientid differentclient _ = True queuePushInitiation _ = noop diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index bb1384a15..b24e5fdb6 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -1,6 +1,6 @@ {- git-annex assistant repo pairing, core data types - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -58,6 +58,15 @@ data PairData = PairData } deriving (Eq, Read, Show) +checkSane :: PairData -> Bool +checkSane p = all (not . any isControl) + [ fromMaybe "" (remoteHostName p) + , remoteUserName p + , remoteDirectory p + , remoteSshPubKey p + , fromUUID (pairUUID p) + ] + type UserName = String {- A pairing that is in progress has a secret, a thread that is diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 3f3823664..05533e270 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -1,6 +1,6 @@ {- git-annex assistant pairing remote creation - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -23,12 +23,11 @@ import qualified Data.Text as T {- Authorized keys are set up before pairing is complete, so that the other - side can immediately begin syncing. -} setupAuthorizedKeys :: PairMsg -> FilePath -> IO () -setupAuthorizedKeys msg repodir = do - validateSshPubKey pubkey - unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $ - error "failed setting up ssh authorized keys" - where - pubkey = remoteSshPubKey $ pairMsgData msg +setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of + Left err -> error err + Right pubkey -> + unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $ + error "failed setting up ssh authorized keys" {- When local pairing is complete, this is used to set up the remote for - the host we paired with. -} diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 6c625f881..7a4ac3ffe 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -4,7 +4,7 @@ - each message is repeated until acknowledged. This is done using a - thread, that gets stopped before the next message is sent. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -20,7 +20,6 @@ import Utility.Verifiable import Network.Multicast import Network.Info import Network.Socket -import Control.Exception (bracket) import qualified Data.Map as M import Control.Concurrent diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs index 54f31a84b..7b4de450f 100644 --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -1,6 +1,6 @@ {- git-annex assistant push tracking - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/RemoteControl.hs b/Assistant/RemoteControl.hs new file mode 100644 index 000000000..1016f1169 --- /dev/null +++ b/Assistant/RemoteControl.hs @@ -0,0 +1,21 @@ +{- git-annex assistant RemoteDaemon control + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.RemoteControl ( + sendRemoteControl, + RemoteDaemon.Consumed(..) +) where + +import Assistant.Common +import qualified RemoteDaemon.Types as RemoteDaemon + +import Control.Concurrent + +sendRemoteControl :: RemoteDaemon.Consumed -> Assistant () +sendRemoteControl msg = do + clicker <- getAssistant remoteControl + liftIO $ writeChan clicker msg diff --git a/Assistant/RepoProblem.hs b/Assistant/RepoProblem.hs index 6913fefc6..32595916e 100644 --- a/Assistant/RepoProblem.hs +++ b/Assistant/RepoProblem.hs @@ -1,6 +1,6 @@ {- git-annex assistant remote problem handling - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs index 2743c0f36..0ce7a47cc 100644 --- a/Assistant/ScanRemotes.hs +++ b/Assistant/ScanRemotes.hs @@ -1,6 +1,6 @@ {- git-annex assistant remotes needing scanning - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index acb2fc11c..88afec713 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex assistant ssh utilities - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -92,7 +92,7 @@ parseSshUrl u , sshCapabilities = [] } where - (user, host) = if '@' `elem` userhost + (user, host) = if '@' `elem` userhost then separate (== '@') userhost else ("", userhost) fromrsync s @@ -111,34 +111,26 @@ sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool) sshTranscript opts input = processTranscript "ssh" opts input {- Ensure that the ssh public key doesn't include any ssh options, like - - command=foo, or other weirdness -} -validateSshPubKey :: SshPubKey -> IO () + - command=foo, or other weirdness. + - + - The returned version of the key has its comment removed. + -} +validateSshPubKey :: SshPubKey -> Either String SshPubKey validateSshPubKey pubkey - | length (lines pubkey) == 1 = - either error return $ check $ words pubkey - | otherwise = error "too many lines in ssh public key" + | length (lines pubkey) == 1 = check $ words pubkey + | otherwise = Left "too many lines in ssh public key" where - check [prefix, _key, comment] = do - checkprefix prefix - checkcomment comment - check [prefix, _key] = - checkprefix prefix + check (prefix:key:_) = checkprefix prefix (unwords [prefix, key]) check _ = err "wrong number of words in ssh public key" - ok = Right () err msg = Left $ unwords [msg, pubkey] - checkprefix prefix - | ssh == "ssh" && all isAlphaNum keytype = ok + checkprefix prefix validpubkey + | ssh == "ssh" && all isAlphaNum keytype = Right validpubkey | otherwise = err "bad ssh public key prefix" where (ssh, keytype) = separate (== '-') prefix - checkcomment comment = case filter (not . safeincomment) comment of - [] -> ok - badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")" - safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.' - addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh" [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ] @@ -197,7 +189,7 @@ authorizedKeysLine gitannexshellonly dir pubkey - long perl script. -} | otherwise = pubkey where - limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " + limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " {- Generates a ssh key pair. -} genSshKeyPair :: IO SshKeyPair @@ -260,7 +252,7 @@ setupSshKeyPair sshkeypair sshdata = do fixSshKeyPairIdentitiesOnly :: IO () fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines where - go c [] = reverse c + go c [] = reverse c go c (l:[]) | all (`isInfixOf` l) indicators = go (fixedline l:l:c) [] | otherwise = go (l:c) [] @@ -268,7 +260,7 @@ fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines | all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) = go (fixedline l:l:c) (next:rest) | otherwise = go (l:c) (next:rest) - indicators = ["IdentityFile", "key.git-annex"] + indicators = ["IdentityFile", "key.git-annex"] fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes" {- Add StrictHostKeyChecking to any ssh config stanzas that were written @@ -312,7 +304,7 @@ setSshConfig sshdata config = do {- This hostname is specific to a given repository on the ssh host, - so it is based on the real hostname, the username, and the directory. - - - The mangled hostname has the form "git-annex-realhostname-username_dir". + - The mangled hostname has the form "git-annex-realhostname-username-port_dir". - The only use of "-" is to separate the parts shown; this is necessary - to allow unMangleSshHostName to work. Any unusual characters in the - username or directory are url encoded, except using "." rather than "%" @@ -324,6 +316,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata) where extra = intercalate "_" $ map T.unpack $ catMaybes [ sshUserName sshdata + , Just $ T.pack $ show $ sshPort sshdata , Just $ sshDirectory sshdata ] safe c diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index fc95419ab..d914d2246 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -1,6 +1,6 @@ {- git-annex assistant repo syncing - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -15,6 +15,7 @@ import Assistant.Alert import Assistant.Alert.Utility import Assistant.DaemonStatus import Assistant.ScanRemotes +import Assistant.RemoteControl import qualified Command.Sync import Utility.Parallel import qualified Git @@ -95,7 +96,7 @@ reconnectRemotes notifypushes rs = void $ do =<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers <$> getDaemonStatus -{- Updates the local sync branch, then pushes it to all remotes, in +{- Pushes the local sync branch to all remotes, in - parallel, along with the git-annex branch. This is the same - as "git annex sync", except in parallel, and will co-exist with use of - "git annex sync". @@ -147,7 +148,6 @@ pushToRemotes' now notifypushes remotes = do go _ _ _ _ [] = return [] -- no remotes, so nothing to do go shouldretry (Just branch) g u rs = do debug ["pushing to", show rs] - liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g (succeeded, failed) <- liftIO $ inParallel (push g branch) rs updatemap succeeded [] if null failed @@ -258,6 +258,7 @@ changeSyncable Nothing enable = do changeSyncable (Just r) True = do liftAnnex $ changeSyncFlag r True syncRemote r + sendRemoteControl RELOAD changeSyncable (Just r) False = do liftAnnex $ changeSyncFlag r False updateSyncRemotes diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index cb98b017f..8cf6da2d2 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -1,6 +1,6 @@ {- git-annex assistant commit thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -27,7 +27,6 @@ import qualified Utility.Lsof as Lsof import qualified Utility.DirWatcher as DirWatcher import Types.KeySource import Config -import Annex.Exception import Annex.Content import Annex.Link import Annex.CatFile @@ -35,6 +34,7 @@ import qualified Annex import Utility.InodeCache import Annex.Content.Direct import qualified Command.Sync +import qualified Git.Branch import Data.Time.Clock import Data.Tuple.Utils @@ -50,6 +50,7 @@ commitThread = namedThread "Committer" $ do delayadd <- liftAnnex $ maybe delayaddDefault (return . Just . Seconds) =<< annexDelayAdd <$> Annex.getGitConfig + msg <- liftAnnex Command.Sync.commitMsg waitChangeTime $ \(changes, time) -> do readychanges <- handleAdds havelsof delayadd changes if shouldCommit False time (length readychanges) readychanges @@ -60,7 +61,7 @@ commitThread = namedThread "Committer" $ do , "changes" ] void $ alertWhile commitAlert $ - liftAnnex commitStaged + liftAnnex $ commitStaged msg recordCommit let numchanges = length readychanges mapM_ checkChangeContent readychanges @@ -164,8 +165,8 @@ waitChangeTime a = waitchanges 0 -} aftermaxcommit oldchanges = loop (30 :: Int) where - loop 0 = continue oldchanges - loop n = do + loop 0 = continue oldchanges + loop n = do liftAnnex noop -- ensure Annex state is free liftIO $ threadDelaySeconds (Seconds 1) changes <- getAnyChanges @@ -212,14 +213,18 @@ shouldCommit scanning now len changes recentchanges = filter thissecond changes timeDelta c = now `diffUTCTime` changeTime c -commitStaged :: Annex Bool -commitStaged = do +commitStaged :: String -> Annex Bool +commitStaged msg = do {- This could fail if there's another commit being made by - something else. -} - v <- tryAnnex Annex.Queue.flush + v <- tryNonAsync Annex.Queue.flush case v of Left _ -> return False - Right _ -> Command.Sync.commitStaged "" + Right _ -> do + ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg + when ok $ + Command.Sync.updateSyncBranch =<< inRepo Git.Branch.current + return ok {- OSX needs a short delay after a file is added before locking it down, - when using a non-direct mode repository, as pasting a file seems to @@ -297,7 +302,7 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do add change@(InProcessAddChange { keySource = ks }) = catchDefaultIO Nothing <~> doadd where - doadd = sanitycheck ks $ do + doadd = sanitycheck ks $ do (mkey, mcache) <- liftAnnex $ do showStart "add" $ keyFilename ks Command.Add.ingest $ Just ks @@ -313,10 +318,11 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do adddirect toadd = do ct <- liftAnnex compareInodeCachesWith m <- liftAnnex $ removedKeysMap ct cs + delta <- liftAnnex getTSDelta if M.null m then forM toadd add else forM toadd $ \c -> do - mcache <- liftIO $ genInodeCache $ changeFile c + mcache <- liftIO $ genInodeCache (changeFile c) delta case mcache of Nothing -> add c Just cache -> @@ -347,7 +353,7 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do done change mcache file key = liftAnnex $ do logStatus key InfoPresent link <- ifM isDirect - ( inRepo $ gitAnnexLink file key + ( calcRepo $ gitAnnexLink file key , Command.Add.link file key mcache ) whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index a92c7d785..7ab55fb82 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -1,6 +1,6 @@ {- git-annex assistant config monitor thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -62,15 +62,17 @@ configFilesActions = , (groupLog, void $ liftAnnex groupMapLoad) , (numcopiesLog, void $ liftAnnex globalNumCopiesLoad) , (scheduleLog, void updateScheduleLog) - -- Preferred content settings depend on most of the other configs, - -- so will be reloaded whenever any configs change. + -- Preferred and required content settings depend on most of the + -- other configs, so will be reloaded whenever any configs change. , (preferredContentLog, noop) + , (requiredContentLog, noop) + , (groupPreferredContentLog, noop) ] reloadConfigs :: Configs -> Assistant () reloadConfigs changedconfigs = do sequence_ as - void $ liftAnnex preferredContentMapLoad + void $ liftAnnex preferredRequiredMapsLoad {- Changes to the remote log, or the trust log, can affect the - syncRemotes list. Changes to the uuid log may affect its - display so are also included. -} diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index 55b3ca2f1..451fa75c6 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -1,6 +1,6 @@ {- git-annex assistant sceduled jobs runner - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -87,7 +87,7 @@ cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do liftIO $ waitNotification h debug ["reloading changed activities"] go h amap' nmap' - startactivities as lastruntimes = forM as $ \activity -> + startactivities as lastruntimes = forM as $ \activity -> case connectActivityUUID activity of Nothing -> do runner <- asIO2 (sleepingActivityThread urlrenderer) @@ -108,8 +108,8 @@ cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do sleepingActivityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant () sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime where - getnexttime = liftIO . nextTime schedule - go _ Nothing = debug ["no scheduled events left for", desc] + getnexttime = liftIO . nextTime schedule + go _ Nothing = debug ["no scheduled events left for", desc] go l (Just (NextTimeExactly t)) = waitrun l t Nothing go l (Just (NextTimeWindow windowstart windowend)) = waitrun l windowstart (Just windowend) @@ -129,7 +129,7 @@ sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnextti go l =<< getnexttime l else run nowt where - tolate nowt tz = case mmaxt of + tolate nowt tz = case mmaxt of Just maxt -> nowt > maxt -- allow the job to start 10 minutes late Nothing ->diffUTCTime @@ -191,10 +191,10 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir) where reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download -runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (remoteFromUUID u) +runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (remoteFromUUID u) where - handle Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] - handle (Just rmt) = void $ case Remote.remoteFsck rmt of + dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] + dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of Nothing -> go rmt $ do program <- readProgramFile void $ batchCommand program $ diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs index 5bbb15acb..d5b2cc25d 100644 --- a/Assistant/Threads/DaemonStatus.hs +++ b/Assistant/Threads/DaemonStatus.hs @@ -1,6 +1,6 @@ {- git-annex assistant daemon status thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs index 4c4012a67..900e0d423 100644 --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -1,6 +1,6 @@ {- git-annex assistant Amazon Glacier retrieval - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 03bcf0aad..f1a64925d 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -1,6 +1,6 @@ {- git-annex assistant git merge thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -78,12 +78,13 @@ onChange file changedbranch = fileToBranch file mergecurrent (Just current) - | equivBranches changedbranch current = do - debug - [ "merging", Git.fromRef changedbranch - , "into", Git.fromRef current - ] - void $ liftAnnex $ autoMergeFrom changedbranch (Just current) + | equivBranches changedbranch current = + whenM (liftAnnex $ inRepo $ Git.Branch.changed current changedbranch) $ do + debug + [ "merging", Git.fromRef changedbranch + , "into", Git.fromRef current + ] + void $ liftAnnex $ autoMergeFrom changedbranch (Just current) Git.Branch.AutomaticCommit mergecurrent _ = noop handleDesynced = case fromTaggedBranch changedbranch of diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 39ae67537..023af53cb 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -1,6 +1,6 @@ {- git-annex assistant mount watcher, using either dbus or mtab polling - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -63,7 +63,11 @@ dbusThread urlrenderer = do wasmounted <- liftIO $ swapMVar mvar nowmounted handleMounts urlrenderer wasmounted nowmounted liftIO $ forM_ mountChanged $ \matcher -> +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher handleevent +#else listen client matcher handleevent +#endif , do liftAnnex $ warning "No known volume monitor available through dbus; falling back to mtab polling" diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index 0b009647c..ad3a87a91 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -1,6 +1,6 @@ {- git-annex assistant network connection watcher, using dbus - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -18,10 +18,10 @@ import Assistant.DaemonStatus import Utility.NotificationBroadcaster #if WITH_DBUS +import Assistant.RemoteControl import Utility.DBus import DBus.Client import DBus -import Data.Word (Word32) import Assistant.NetMessager #else #ifdef linux_HOST_OS @@ -44,8 +44,9 @@ netWatcherThread = thread noop - while (despite the local network staying up), are synced with - periodically. - - - Note that it does not call notifyNetMessagerRestart, because - - it doesn't know that the network has changed. + - Note that it does not call notifyNetMessagerRestart, or + - signal the RemoteControl, because it doesn't know that the + - network has changed. -} netWatcherFallbackThread :: NamedThread netWatcherFallbackThread = namedThread "NetWatcherFallback" $ @@ -61,16 +62,22 @@ dbusThread = do where go client = ifM (checkNetMonitor client) ( do - listenNMConnections client <~> handleconn - listenWicdConnections client <~> handleconn + callback <- asIO1 connchange + liftIO $ do + listenNMConnections client callback + listenWicdConnections client callback , do liftAnnex $ warning "No known network monitor available through dbus; falling back to polling" ) - handleconn = do + connchange False = do + debug ["detected network disconnection"] + sendRemoteControl LOSTNET + connchange True = do debug ["detected network connection"] notifyNetMessagerRestart handleConnection + sendRemoteControl RESUME onerr e _ = do liftAnnex $ warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" @@ -95,38 +102,75 @@ checkNetMonitor client = do networkmanager = "org.freedesktop.NetworkManager" wicd = "org.wicd.daemon" -{- Listens for new NetworkManager connections. -} -listenNMConnections :: Client -> IO () -> IO () -listenNMConnections client callback = - listen client matcher $ \event -> - when (Just True == anyM activeconnection (signalBody event)) $ - callback +{- Listens for NetworkManager connections and diconnections. + - + - Connection example (once fully connected): + - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}] + - + - Disconnection example: + - [Variant {"ActiveConnections": Variant []}] + -} +listenNMConnections :: Client -> (Bool -> IO ()) -> IO () +listenNMConnections client setconnected = +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher +#else + listen client matcher +#endif + $ \event -> mapM_ handleevent + (map dictionaryItems $ mapMaybe fromVariant $ signalBody event) where matcher = matchAny - { matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active" + { matchInterface = Just "org.freedesktop.NetworkManager" , matchMember = Just "PropertiesChanged" } - nm_connection_activated = toVariant (2 :: Word32) - nm_state_key = toVariant ("State" :: String) - activeconnection v = do - m <- fromVariant v - vstate <- lookup nm_state_key $ dictionaryItems m - state <- fromVariant vstate - return $ state == nm_connection_activated + nm_active_connections_key = toVariant ("ActiveConnections" :: String) + nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String) + noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath]) + rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/" + handleevent m + | lookup nm_active_connections_key m == noconnections = + setconnected False + | lookup nm_activatingconnection_key m == rootconnection = + setconnected True + | otherwise = noop -{- Listens for new Wicd connections. -} -listenWicdConnections :: Client -> IO () -> IO () -listenWicdConnections client callback = - listen client matcher $ \event -> +{- Listens for Wicd connections and disconnections. + - + - Connection example: + - ConnectResultsSent: + - Variant "success" + - + - Diconnection example: + - StatusChanged + - [Variant 0, Variant [Varient ""]] + -} +listenWicdConnections :: Client -> (Bool -> IO ()) -> IO () +listenWicdConnections client setconnected = do + match connmatcher $ \event -> when (any (== wicd_success) (signalBody event)) $ - callback + setconnected True + match statusmatcher $ \event -> handleevent (signalBody event) where - matcher = matchAny + connmatcher = matchAny { matchInterface = Just "org.wicd.daemon" , matchMember = Just "ConnectResultsSent" } + statusmatcher = matchAny + { matchInterface = Just "org.wicd.daemon" + , matchMember = Just "StatusChanged" + } wicd_success = toVariant ("success" :: String) - + wicd_disconnected = toVariant [toVariant ("" :: String)] + handleevent status + | any (== wicd_disconnected) status = setconnected False + | otherwise = noop + match matcher a = +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher a +#else + listen client matcher a +#endif #endif handleConnection :: Assistant () diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index cd95ab5a4..e4f87494c 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -1,6 +1,6 @@ {- git-annex assistant thread to listen for incoming pairing traffic - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,13 +16,11 @@ import Assistant.WebApp.Types import Assistant.Alert import Assistant.DaemonStatus import Utility.ThreadScheduler -import Utility.Format import Git import Network.Multicast import Network.Socket import qualified Data.Text as T -import Data.Char pairListenerThread :: UrlRenderer -> NamedThread pairListenerThread urlrenderer = namedThread "PairListener" $ do @@ -39,16 +37,18 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do Nothing -> go reqs cache sock Just m -> do debug ["received", show msg] - sane <- checkSane msg (pip, verified) <- verificationCheck m =<< (pairingInProgress <$> getDaemonStatus) let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip - case (wrongstage, fromus, sane, pairMsgStage m) of + case (wrongstage, fromus, checkSane (pairMsgData m), pairMsgStage m) of (_, True, _, _) -> do debug ["ignoring message that looped back"] go reqs cache sock - (_, _, False, _) -> go reqs cache sock + (_, _, False, _) -> do + liftAnnex $ warning + "illegal control characters in pairing message; ignoring" + go reqs cache sock -- PairReq starts a pairing process, so a -- new one is always heeded, even if -- some other pairing is in process. @@ -83,19 +83,10 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do "detected possible pairing brute force attempt; disabled pairing" stopSending pip return (Nothing, False) - |otherwise = return (Just pip, verified && sameuuid) + | otherwise = return (Just pip, verified && sameuuid) where verified = verifiedPairMsg m pip sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m) - - checkSane msg - {- Control characters could be used in a - - console poisoning attack. -} - | any isControl (filter (/= '\n') (decode_c msg)) = do - liftAnnex $ warning - "illegal control characters in pairing message; ignoring" - return False - | otherwise = return True {- PairReqs invalidate the cache of recently finished pairings. - This is so that, if a new pairing is started with the diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs index 8095581a6..86ee027f7 100644 --- a/Assistant/Threads/ProblemFixer.hs +++ b/Assistant/Threads/ProblemFixer.hs @@ -1,6 +1,6 @@ {- git-annex assistant thread to handle fixing problems with repositories - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 3ec922fe4..35989ed48 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -1,6 +1,6 @@ {- git-annex assistant git pushing thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs new file mode 100644 index 000000000..ae63aff5c --- /dev/null +++ b/Assistant/Threads/RemoteControl.hs @@ -0,0 +1,121 @@ +{- git-annex assistant communication with remotedaemon + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.RemoteControl where + +import Assistant.Common +import RemoteDaemon.Types +import Config.Files +import Utility.Batch +import Utility.SimpleProtocol +import Assistant.Alert +import Assistant.Alert.Utility +import Assistant.DaemonStatus +import qualified Git +import qualified Git.Types as Git +import qualified Remote +import qualified Types.Remote as Remote + +import Control.Concurrent +import Control.Concurrent.Async +import Network.URI +import qualified Data.Map as M +import qualified Data.Set as S + +remoteControlThread :: NamedThread +remoteControlThread = namedThread "RemoteControl" $ do + program <- liftIO readProgramFile + (cmd, params) <- liftIO $ toBatchCommand + (program, [Param "remotedaemon"]) + let p = proc cmd (toCommand params) + (Just toh, Just fromh, _, pid) <- liftIO $ createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + + urimap <- liftIO . newMVar =<< liftAnnex getURIMap + + controller <- asIO $ remoteControllerThread toh + responder <- asIO $ remoteResponderThread fromh urimap + + -- run controller and responder until the remotedaemon dies + liftIO $ void $ tryNonAsync $ controller `concurrently` responder + debug ["remotedaemon exited"] + liftIO $ forceSuccessProcess p pid + +-- feed from the remoteControl channel into the remotedaemon +remoteControllerThread :: Handle -> Assistant () +remoteControllerThread toh = do + clicker <- getAssistant remoteControl + forever $ do + msg <- liftIO $ readChan clicker + debug [show msg] + liftIO $ do + hPutStrLn toh $ unwords $ formatMessage msg + hFlush toh + +-- read status messages emitted by the remotedaemon and handle them +remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant () +remoteResponderThread fromh urimap = go M.empty + where + go syncalerts = do + l <- liftIO $ hGetLine fromh + debug [l] + case parseMessage l of + Just (CONNECTED uri) -> changeconnected S.insert uri + Just (DISCONNECTED uri) -> changeconnected S.delete uri + Just (SYNCING uri) -> withr uri $ \r -> + if M.member (Remote.uuid r) syncalerts + then go syncalerts + else do + i <- addAlert $ syncAlert [r] + go (M.insert (Remote.uuid r) i syncalerts) + Just (DONESYNCING uri status) -> withr uri $ \r -> + case M.lookup (Remote.uuid r) syncalerts of + Nothing -> cont + Just i -> do + let (succeeded, failed) = if status + then ([r], []) + else ([], [r]) + updateAlertMap $ mergeAlert i $ + syncResultAlert succeeded failed + go (M.delete (Remote.uuid r) syncalerts) + Just (WARNING (RemoteURI uri) msg) -> do + void $ addAlert $ + warningAlert ("RemoteControl "++ show uri) msg + cont + Nothing -> do + debug ["protocol error from remotedaemon: ", l] + cont + where + cont = go syncalerts + withr uri = withRemote uri urimap cont + changeconnected sm uri = withr uri $ \r -> do + changeCurrentlyConnected $ sm $ Remote.uuid r + cont + +getURIMap :: Annex (M.Map URI Remote) +getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo) + where + mkk (Git.Url u) = Just u + mkk _ = Nothing + +withRemote + :: RemoteURI + -> MVar (M.Map URI Remote) + -> Assistant a + -> (Remote -> Assistant a) + -> Assistant a +withRemote (RemoteURI uri) remotemap noremote a = do + m <- liftIO $ readMVar remotemap + case M.lookup uri m of + Just r -> a r + Nothing -> do + {- Reload map, in case a new remote has been added. -} + m' <- liftAnnex getURIMap + void $ liftIO $ swapMVar remotemap $ m' + maybe noremote a (M.lookup uri m') diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index d7a71d477..3073cfe41 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -1,6 +1,6 @@ {- git-annex assistant sanity checker - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,9 +21,11 @@ import Assistant.Drop import Assistant.Ssh import Assistant.TransferQueue import Assistant.Types.UrlRenderer +import Assistant.Restart import qualified Annex.Branch +import qualified Git import qualified Git.LsFiles -import qualified Git.Command +import qualified Git.Command.Batch import qualified Git.Config import Utility.ThreadScheduler import qualified Assistant.Threads.Watcher as Watcher @@ -38,13 +40,14 @@ import Assistant.Unused import Logs.Unused import Logs.Transfer import Config.Files -import Utility.DiskFree +import Types.Key (keyBackendName) import qualified Annex #ifdef WITH_WEBAPP import Assistant.WebApp.Types #endif #ifndef mingw32_HOST_OS import Utility.LogFile +import Utility.DiskFree #endif import Data.Time.Clock.POSIX @@ -82,6 +85,11 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta {- Fix up ssh remotes set up by past versions of the assistant. -} liftIO $ fixUpSshRemotes + {- Clean up old temp files. -} + void $ liftAnnex $ tryNonAsync $ do + cleanOldTmpMisc + cleanReallyOldTmp + {- If there's a startup delay, it's done here. -} liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay @@ -140,6 +148,8 @@ waitForNextCheck = do - will block the watcher. -} dailyCheck :: UrlRenderer -> Assistant Bool dailyCheck urlrenderer = do + checkRepoExists + g <- liftAnnex gitRepo batchmaker <- liftIO getBatchCommandMaker @@ -160,7 +170,7 @@ dailyCheck urlrenderer = do - to have a lot of small objects and they should not be a - significant size. -} when (Git.Config.getMaybe "gc.auto" g == Just "0") $ - liftIO $ void $ Git.Command.runBatch batchmaker + liftIO $ void $ Git.Command.Batch.run batchmaker [ Param "-c", Param "gc.auto=670000" , Param "gc" , Param "--auto" @@ -197,6 +207,7 @@ dailyCheck urlrenderer = do hourlyCheck :: Assistant () hourlyCheck = do + checkRepoExists #ifndef mingw32_HOST_OS checkLogSize 0 #else @@ -214,10 +225,10 @@ checkLogSize :: Int -> Assistant () checkLogSize n = do f <- liftAnnex $ fromRepo gitAnnexLogFile logs <- liftIO $ listLogs f - totalsize <- liftIO $ sum <$> mapM filesize logs + totalsize <- liftIO $ sum <$> mapM getFileSize logs when (totalsize > 2 * oneMegabyte) $ do notice ["Rotated logs due to size:", show totalsize] - liftIO $ openLog f >>= redirLog + liftIO $ openLog f >>= handleToFd >>= redirLog when (n < maxLogs + 1) $ do df <- liftIO $ getDiskFree $ takeDirectory f case df of @@ -226,9 +237,7 @@ checkLogSize n = do checkLogSize (n + 1) _ -> noop where - filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f) - - oneMegabyte :: Int + oneMegabyte :: Integer oneMegabyte = 1000000 #endif @@ -247,7 +256,7 @@ checkOldUnused :: UrlRenderer -> Assistant () checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig where go (Just Nothing) = noop - go (Just (Just expireunused)) = expireUnused (Just expireunused) + go (Just (Just expireunused)) = expireUnused (Just expireunused) go Nothing = maybe noop prompt =<< describeUnusedWhenBig prompt msg = @@ -258,3 +267,61 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit #else debug [show $ renderTense Past msg] #endif + +{- Files may be left in misctmp by eg, an interrupted add of files + - by the assistant, which hard links files to there as part of lockdown + - checks. Delete these files if they're more than a day old. + - + - Note that this is not safe to run after the Watcher starts up, since it + - will create such files, and due to hard linking they may have old + - mtimes. So, this should only be called from the + - sanityCheckerStartupThread, which runs before the Watcher starts up. + - + - Also, if a git-annex add is being run at the same time the assistant + - starts up, its tmp files could be deleted. However, the watcher will + - come along and add everything once it starts up anyway, so at worst + - this would make the git-annex add fail unexpectedly. + -} +cleanOldTmpMisc :: Annex () +cleanOldTmpMisc = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24) + tmp <- fromRepo gitAnnexTmpMiscDir + liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp + +{- While .git/annex/tmp is now only used for storing partially transferred + - objects, older versions of git-annex used it for misctemp. Clean up any + - files that might be left from that, by looking for files whose names + - cannot be the key of an annexed object. Only delete files older than + - 1 week old. + - + - Also, some remotes such as rsync may use this temp directory for storing + - eg, encrypted objects that are being transferred. So, delete old + - objects that use a GPGHMAC backend. + -} +cleanReallyOldTmp :: Annex () +cleanReallyOldTmp = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24 * 7) + tmp <- fromRepo gitAnnexTmpObjectDir + liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp + where + cleanjunk check f = case fileKey (takeFileName f) of + Nothing -> cleanOld check f + Just k + | "GPGHMAC" `isPrefixOf` keyBackendName k -> + cleanOld check f + | otherwise -> noop + +cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO () +cleanOld check f = go =<< catchMaybeIO getmtime + where + getmtime = realToFrac . modificationTime <$> getSymbolicLinkStatus f + go (Just mtime) | check mtime = nukeFile f + go _ = noop + +checkRepoExists :: Assistant () +checkRepoExists = do + g <- liftAnnex gitRepo + liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $ + terminateSelf diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index 71bfe3676..73562dbf7 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -1,6 +1,6 @@ {- git-annex assistant transfer polling thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -36,8 +36,7 @@ transferPollerThread = namedThread "TransferPoller" $ do - temp file being used for the transfer. -} | transferDirection t == Download = do let f = gitAnnexTmpObjectLocation (transferKey t) g - sz <- liftIO $ catchMaybeIO $ - fromIntegral . fileSize <$> getFileStatus f + sz <- liftIO $ catchMaybeIO $ getFileSize f newsize t info sz {- Uploads don't need to be polled for when the TransferWatcher - thread can track file modifications. -} diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 6df9b1e18..3cbaadf19 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -1,6 +1,6 @@ {- git-annex assistant thread to scan remotes to find needed transfers - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,7 +19,6 @@ import Assistant.Types.UrlRenderer import Logs.Transfer import Logs.Location import Logs.Group -import Logs.Web (webUUID) import qualified Remote import qualified Types.Remote as Remote import Utility.ThreadScheduler @@ -115,7 +114,7 @@ failedTransferScan r = do - since we need to look at the locations of all keys anyway. -} expensiveScan :: UrlRenderer -> [Remote] -> Assistant () -expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do +expensiveScan urlrenderer rs = batch <~> do debug ["starting scan of", show visiblers] let us = map Remote.uuid rs @@ -135,7 +134,6 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do remove <- asIO1 $ removableRemote urlrenderer liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers where - onlyweb = all (== webUUID) $ map Remote.uuid rs visiblers = let rs' = filter (not . Remote.readonly) rs in if null rs' then rs else rs' @@ -151,7 +149,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do enqueue f (r, t) = queueTransferWhenSmall "expensive scan found missing object" (Just f) t r - findtransfers f unwanted (key, _) = do + findtransfers f unwanted key = do {- The syncable remotes may have changed since this - scan began. -} syncrs <- syncDataRemotes <$> getDaemonStatus diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 6e8791732..c452d87c2 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -1,6 +1,6 @@ {- git-annex assistant transfer watching thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 53d8a578c..073dbef3c 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -1,6 +1,6 @@ {- git-annex assistant data transferrer thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs index ffad09d3d..e779c8e54 100644 --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -1,6 +1,6 @@ {- git-annex assistant thread to detect when git-annex is upgraded - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -51,9 +51,9 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do let depth = length (splitPath dir) + 1 let nosubdirs f = length (splitPath f) == depth void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) - -- Ignore bogus events generated during the startup scan. + -- Ignore bogus events generated during the startup scan. -- We ask the watcher to not generate them, but just to be safe.. - startup mvar scanner = do + startup mvar scanner = do r <- scanner void $ swapMVar mvar Started return r diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs index 60aeec70b..602d09208 100644 --- a/Assistant/Threads/Upgrader.hs +++ b/Assistant/Threads/Upgrader.hs @@ -1,6 +1,6 @@ {- git-annex assistant thread to detect when upgrade is available - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -18,11 +18,8 @@ import Assistant.Types.UrlRenderer import Assistant.DaemonStatus import Assistant.Alert import Utility.NotificationBroadcaster -import Utility.Tmp import qualified Annex import qualified Build.SysConfig -import qualified Utility.Url as Url -import qualified Annex.Url as Url import qualified Git.Version import Types.Distribution #ifdef WITH_WEBAPP @@ -42,7 +39,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $ h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus go h =<< liftIO getCurrentTime where - {- Wait for a network connection event. Then see if it's been + {- Wait for a network connection event. Then see if it's been - half a day since the last upgrade check. If so, proceed with - check. -} go h lastchecked = do @@ -62,7 +59,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $ checkUpgrade :: UrlRenderer -> Assistant () checkUpgrade urlrenderer = do debug [ "Checking if an upgrade is available." ] - go =<< getDistributionInfo + go =<< downloadDistributionInfo where go Nothing = debug [ "Failed to check if upgrade is available." ] go (Just d) = do @@ -86,16 +83,3 @@ canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled noop #endif ) - -getDistributionInfo :: Assistant (Maybe GitAnnexDistribution) -getDistributionInfo = do - uo <- liftAnnex Url.getUrlOptions - liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do - hClose h - ifM (Url.downloadQuiet distributionInfoUrl tmpfile uo) - ( readish <$> readFileStrict tmpfile - , return Nothing - ) - -distributionInfoUrl :: String -distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info" diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 8a8e8faf0..6f3afa8ca 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -1,6 +1,6 @@ {- git-annex assistant tree watcher - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -35,6 +35,7 @@ import Annex.CatFile import Annex.CheckIgnore import Annex.Link import Annex.FileMatcher +import Types.FileMatcher import Annex.ReplaceFile import Git.Types import Config @@ -71,7 +72,7 @@ needLsof = error $ unlines {- A special exception that can be thrown to pause or resume the watcher. -} data WatcherControl = PauseWatcher | ResumeWatcher - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Typeable) instance E.Exception WatcherControl @@ -103,13 +104,13 @@ runWatcher = do , errHook = errhook } scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig - handle <- liftIO $ watchDir "." ignored scanevents hooks startup + h <- liftIO $ watchDir "." ignored scanevents hooks startup debug [ "watching", "."] {- Let the DirWatcher thread run until signalled to pause it, - then wait for a resume signal, and restart. -} waitFor PauseWatcher $ do - liftIO $ stopWatchDir handle + liftIO $ stopWatchDir h waitFor ResumeWatcher runWatcher where hook a = Just <$> asIO2 (runHandler a) @@ -183,7 +184,7 @@ runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () runHandler handler file filestatus = void $ do r <- tryIO <~> handler (normalize file) filestatus case r of - Left e -> liftIO $ print e + Left e -> liftIO $ warningIO $ show e Right Nothing -> noop Right (Just change) -> do -- Just in case the commit thread is not @@ -191,12 +192,12 @@ runHandler handler file filestatus = void $ do liftAnnex Annex.Queue.flushWhenFull recordChange change where - normalize f + normalize f | "./" `isPrefixOf` file = drop 2 f | otherwise = f {- Small files are added to git as-is, while large ones go into the annex. -} -add :: FileMatcher -> FilePath -> Assistant (Maybe Change) +add :: FileMatcher Annex -> FilePath -> Assistant (Maybe Change) add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file) ( pendingAddChange file , do @@ -205,7 +206,7 @@ add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file) madeChange file AddFileChange ) -onAdd :: FileMatcher -> Handler +onAdd :: FileMatcher Annex -> Handler onAdd matcher file filestatus | maybe False isRegularFile filestatus = unlessIgnored file $ @@ -218,12 +219,12 @@ shouldRestage ds = scanComplete ds || forceRestage ds {- In direct mode, add events are received for both new files, and - modified existing files. -} -onAddDirect :: Bool -> FileMatcher -> Handler +onAddDirect :: Bool -> FileMatcher Annex -> Handler onAddDirect symlinkssupported matcher file fs = do v <- liftAnnex $ catKeyFile file case (v, fs) of (Just key, Just filestatus) -> - ifM (liftAnnex $ sameFileStatus key filestatus) + ifM (liftAnnex $ sameFileStatus key file filestatus) {- It's possible to get an add event for - an existing file that is not - really modified, but it might have @@ -231,7 +232,7 @@ onAddDirect symlinkssupported matcher file fs = do - so it symlink is restaged to make sure. -} ( ifM (shouldRestage <$> getDaemonStatus) ( do - link <- liftAnnex $ inRepo $ gitAnnexLink file key + link <- liftAnnex $ calcRepo $ gitAnnexLink file key addLink file link (Just key) , noChange ) @@ -245,7 +246,7 @@ onAddDirect symlinkssupported matcher file fs = do debug ["add direct", file] add matcher file where - {- On a filesystem without symlinks, we'll get changes for regular + {- On a filesystem without symlinks, we'll get changes for regular - files that git uses to stand-in for symlinks. Detect when - this happens, and stage the symlink, rather than annexing the - file. -} @@ -270,15 +271,15 @@ onAddSymlink :: Bool -> Handler onAddSymlink isdirect file filestatus = unlessIgnored file $ do linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) kv <- liftAnnex (Backend.lookupFile file) - onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus + onAddSymlink' linktarget kv isdirect file filestatus onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler onAddSymlink' linktarget mk isdirect file filestatus = go mk where - go (Just key) = do + go (Just key) = do when isdirect $ liftAnnex $ void $ addAssociatedFile key file - link <- liftAnnex $ inRepo $ gitAnnexLink file key + link <- liftAnnex $ calcRepo $ gitAnnexLink file key if linktarget == Just link then ensurestaged (Just link) =<< getDaemonStatus else do diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 8d977194b..fd78ba8d8 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -1,11 +1,12 @@ {- git-annex assistant webapp thread - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns, OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -47,6 +48,8 @@ import Yesod import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack) import qualified Network.Wai.Handler.WarpTLS as TLS +import Network.Wai.Middleware.RequestLogger +import System.Log.Logger mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") @@ -83,7 +86,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost setUrlRenderer urlrenderer $ yesodRender webapp (pack "") app <- toWaiAppPlain webapp app' <- ifM debugEnabled - ( return $ httpDebugLogger app + ( return $ logStdout app , return app ) runWebApp tlssettings listenhost' app' $ \addr -> if noannex @@ -95,7 +98,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile go tlssettings addr webapp htmlshim (Just urlfile) where - -- The webapp thread does not wait for the startupSanityCheckThread + -- The webapp thread does not wait for the startupSanityCheckThread -- to finish, so that the user interface remains responsive while -- that's going on. thread = namedThreadUnchecked "WebApp" @@ -135,3 +138,9 @@ getTlsSettings = do #else return Nothing #endif + +{- Checks if debugging is actually enabled. -} +debugEnabled :: IO Bool +debugEnabled = do + l <- getRootLogger + return $ getLevel l <= Just DEBUG diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index ab4de9257..78d527920 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -1,6 +1,6 @@ {- git-annex XMPP client - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -42,17 +42,20 @@ xmppClientThread urlrenderer = namedThread "XMPPClient" $ restartableClient . xmppClient urlrenderer =<< getAssistant id {- Runs the client, handing restart events. -} -restartableClient :: (XMPPCreds -> IO ()) -> Assistant () +restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant () restartableClient a = forever $ go =<< liftAnnex getXMPPCreds where go Nothing = waitNetMessagerRestart go (Just creds) = do - tid <- liftIO $ forkIO $ a creds + xmppuuid <- maybe NoUUID Remote.uuid . headMaybe + . filter Remote.isXMPPRemote . syncRemotes + <$> getDaemonStatus + tid <- liftIO $ forkIO $ a creds xmppuuid waitNetMessagerRestart liftIO $ killThread tid -xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO () -xmppClient urlrenderer d creds = +xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO () +xmppClient urlrenderer d creds xmppuuid = retry (runclient creds) =<< getCurrentTime where liftAssistant = runAssistant d @@ -68,8 +71,11 @@ xmppClient urlrenderer d creds = liftAssistant $ updateBuddyList (const noBuddies) <<~ buddyList void client - liftAssistant $ modifyDaemonStatus_ $ \s -> s - { xmppClientID = Nothing } + liftAssistant $ do + modifyDaemonStatus_ $ \s -> s + { xmppClientID = Nothing } + changeCurrentlyConnected $ S.delete xmppuuid + now <- getCurrentTime if diffUTCTime now starttime > 300 then do @@ -87,6 +93,7 @@ xmppClient urlrenderer d creds = inAssistant $ do modifyDaemonStatus_ $ \s -> s { xmppClientID = Just $ xmppJID creds } + changeCurrentlyConnected $ S.insert xmppuuid debug ["connected", logJid selfjid] lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime @@ -110,7 +117,7 @@ xmppClient urlrenderer d creds = void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime inAssistant $ debug ["received:", show $ map logXMPPEvent l] - mapM_ (handle selfjid) l + mapM_ (handlemsg selfjid) l sendpings selfjid lasttraffic = forever $ do putStanza pingstanza @@ -124,23 +131,23 @@ xmppClient urlrenderer d creds = {- XEP-0199 says that the server will respond with either - a ping response or an error message. Either will - cause traffic, so good enough. -} - pingstanza = xmppPing selfjid + pingstanza = xmppPing selfjid - handle selfjid (PresenceMessage p) = do + handlemsg selfjid (PresenceMessage p) = do void $ inAssistant $ updateBuddyList (updateBuddies p) <<~ buddyList resendImportantMessages selfjid p - handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature - handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us - handle selfjid (GotNetMessage (PairingNotification stage c u)) = + handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature + handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us + handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) = maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) - handle _ (GotNetMessage m@(Pushing _ pushstage)) + handlemsg _ (GotNetMessage m@(Pushing _ pushstage)) | isPushNotice pushstage = inAssistant $ handlePushNotice m | isPushInitiation pushstage = inAssistant $ queuePushInitiation m | otherwise = inAssistant $ storeInbox m - handle _ (Ignorable _) = noop - handle _ (Unknown _) = noop - handle _ (ProtocolError _) = noop + handlemsg _ (Ignorable _) = noop + handlemsg _ (Unknown _) = noop + handlemsg _ (ProtocolError _) = noop resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do let c = formatJID jid diff --git a/Assistant/Threads/XMPPPusher.hs b/Assistant/Threads/XMPPPusher.hs index 30c91c7f0..ec11b9b94 100644 --- a/Assistant/Threads/XMPPPusher.hs +++ b/Assistant/Threads/XMPPPusher.hs @@ -9,7 +9,7 @@ - they would deadlock with only one thread. For larger numbers of - clients, the two threads are also sufficient. - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -34,7 +34,7 @@ xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing where - go lastpushedto = do + go lastpushedto = do msg <- waitPushInitiation side $ selectNextPush lastpushedto debug ["started running push", logNetMessage msg] @@ -78,4 +78,4 @@ selectNextPush lastpushedto l = go [] l (Pushing clientid _) | Just clientid /= lastpushedto -> (m, rejected ++ ms) _ -> go (m:rejected) ms - go [] [] = undefined + go [] [] = undefined diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 93c982224..ba13b3f04 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -1,6 +1,6 @@ {- git-annex assistant pending transfer queue - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -92,7 +92,7 @@ queueTransfersMatching matching reason schedule k f direction filterM (wantSend True (Just k) f . Remote.uuid) $ filter (\r -> not (inset s r || Remote.readonly r)) rs where - locs = S.fromList <$> Remote.keyLocations k + locs = S.fromList <$> Remote.keyLocations k inset s r = S.member (Remote.uuid r) s gentransfer r = Transfer { transferDirection = direction diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index a36a3ee32..bbc2ec7e5 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -1,6 +1,6 @@ {- git-annex assistant transfer slots - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -149,7 +149,7 @@ genTransfer t info = case transferRemote info of - usual cleanup. However, first check if something else is - running the transfer, to avoid removing active transfers. -} - go remote transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info) + go remote transferrer = ifM (liftIO $ performTransfer transferrer t info) ( do maybe noop (void . addAlert . makeAlertFiller True diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs index 6ad9b6b99..152625f4f 100644 --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -1,6 +1,6 @@ {- A pool of "git-annex transferkeys" processes - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -15,7 +15,6 @@ import Utility.Batch import qualified Command.TransferKeys as T import Control.Concurrent.STM hiding (check) -import System.Process (create_group, std_in, std_out) import Control.Exception (throw) import Control.Concurrent @@ -56,9 +55,9 @@ checkTransferrerPoolItem program batchmaker i = case i of {- Requests that a Transferrer perform a Transfer, and waits for it to - finish. -} -performTransfer :: Transferrer -> Transfer -> AssociatedFile -> IO Bool -performTransfer transferrer t f = catchBoolIO $ do - T.sendRequest t f (transferrerWrite transferrer) +performTransfer :: Transferrer -> Transfer -> TransferInfo -> IO Bool +performTransfer transferrer t info = catchBoolIO $ do + T.sendRequest t info (transferrerWrite transferrer) T.readResponse (transferrerRead transferrer) {- Starts a new git-annex transferkeys process, setting up handles diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs index 19fe55e6e..a2e5d5c82 100644 --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -1,6 +1,6 @@ {- git-annex assistant alert types - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -26,7 +26,7 @@ data AlertName | SanityCheckFixAlert | WarningAlert String | PairAlert String - | XMPPNeededAlert + | ConnectionNeededAlert | RemoteRemovalAlert String | CloudRepoNeededAlert | SyncAlert @@ -54,7 +54,7 @@ data Alert = Alert , alertButtons :: [AlertButton] } -data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud +data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | ConnectionIcon type AlertMap = M.Map AlertId Alert diff --git a/Assistant/Types/BranchChange.hs b/Assistant/Types/BranchChange.hs index 399abee54..f769657d0 100644 --- a/Assistant/Types/BranchChange.hs +++ b/Assistant/Types/BranchChange.hs @@ -1,6 +1,6 @@ {- git-annex assistant git-annex branch change tracking - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs index 36d8a4fed..2887aaef0 100644 --- a/Assistant/Types/Buddies.hs +++ b/Assistant/Types/Buddies.hs @@ -1,6 +1,6 @@ {- git-annex assistant buddies - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs index e8ecc6e48..1d8b51775 100644 --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -1,6 +1,6 @@ {- git-annex assistant change tracking - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/Commits.hs b/Assistant/Types/Commits.hs index 500faa901..bf83fc486 100644 --- a/Assistant/Types/Commits.hs +++ b/Assistant/Types/Commits.hs @@ -1,6 +1,6 @@ {- git-annex assistant commit tracking - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/CredPairCache.hs b/Assistant/Types/CredPairCache.hs new file mode 100644 index 000000000..9777e29ee --- /dev/null +++ b/Assistant/Types/CredPairCache.hs @@ -0,0 +1,18 @@ +{- git-annex assistant CredPair cache. + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.CredPairCache where + +import Types.Creds + +import Control.Concurrent +import qualified Data.Map as M + +type CredPairCache = MVar (M.Map Login Password) + +newCredPairCache :: IO CredPairCache +newCredPairCache = newMVar M.empty diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index a618c700d..e1b6c997e 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -1,6 +1,6 @@ {- git-annex assistant daemon status - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -52,6 +52,8 @@ data DaemonStatus = DaemonStatus , syncDataRemotes :: [Remote] -- Are we syncing to any cloud remotes? , syncingToCloudRemote :: Bool + -- Set of uuids of remotes that are currently connected. + , currentlyConnectedRemotes :: S.Set UUID -- List of uuids of remotes that we may have gotten out of sync with. , desynced :: S.Set UUID -- Pairing request that is in progress. @@ -104,6 +106,7 @@ newDaemonStatus = DaemonStatus <*> pure [] <*> pure False <*> pure S.empty + <*> pure S.empty <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs index 5dd1364ad..b07b322ad 100644 --- a/Assistant/Types/NamedThread.hs +++ b/Assistant/Types/NamedThread.hs @@ -1,6 +1,6 @@ {- named threads - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 41ab4b272..475d810ae 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -1,6 +1,6 @@ {- git-annex assistant out of band network messager types - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,13 +12,13 @@ import Assistant.Pairing import Git.Types import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Set as S import qualified Data.Map as M import qualified Data.DList as D import Control.Concurrent.STM import Control.Concurrent.MSampleVar import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 import Data.Text (Text) {- Messages that can be sent out of band by a network messager. -} @@ -85,7 +85,7 @@ logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $ SendPackOutput n _ -> SendPackOutput n elided s -> s where - elided = B8.pack "<elided>" + elided = T.encodeUtf8 $ T.pack "<elided>" logNetMessage (PairingNotification stage c uuid) = show $ PairingNotification stage (logClientID c) uuid logNetMessage m = show m diff --git a/Assistant/Types/Pushes.hs b/Assistant/Types/Pushes.hs index 99e0ee162..0da8b44b5 100644 --- a/Assistant/Types/Pushes.hs +++ b/Assistant/Types/Pushes.hs @@ -1,6 +1,6 @@ {- git-annex assistant push tracking - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/RemoteControl.hs b/Assistant/Types/RemoteControl.hs new file mode 100644 index 000000000..42cb4a5aa --- /dev/null +++ b/Assistant/Types/RemoteControl.hs @@ -0,0 +1,16 @@ +{- git-annex assistant RemoteDaemon control + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.RemoteControl where + +import qualified RemoteDaemon.Types as RemoteDaemon +import Control.Concurrent + +type RemoteControl = Chan RemoteDaemon.Consumed + +newRemoteControl :: IO RemoteControl +newRemoteControl = newChan diff --git a/Assistant/Types/RepoProblem.hs b/Assistant/Types/RepoProblem.hs index ece5a5286..3b9c72cf8 100644 --- a/Assistant/Types/RepoProblem.hs +++ b/Assistant/Types/RepoProblem.hs @@ -1,6 +1,6 @@ {- git-annex assistant repository problem tracking - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/ScanRemotes.hs b/Assistant/Types/ScanRemotes.hs index 8219f9baf..ac6d8fef9 100644 --- a/Assistant/Types/ScanRemotes.hs +++ b/Assistant/Types/ScanRemotes.hs @@ -1,6 +1,6 @@ {- git-annex assistant remotes needing scanning - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/ThreadName.hs b/Assistant/Types/ThreadName.hs index c8d264a38..57c704dad 100644 --- a/Assistant/Types/ThreadName.hs +++ b/Assistant/Types/ThreadName.hs @@ -1,6 +1,6 @@ {- name of a thread - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/ThreadedMonad.hs b/Assistant/Types/ThreadedMonad.hs index 1a2aa7eb7..eadf325ea 100644 --- a/Assistant/Types/ThreadedMonad.hs +++ b/Assistant/Types/ThreadedMonad.hs @@ -1,6 +1,6 @@ {- making the Annex monad available across threads - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs index e4bf2ae92..73a7521c5 100644 --- a/Assistant/Types/TransferQueue.hs +++ b/Assistant/Types/TransferQueue.hs @@ -1,6 +1,6 @@ {- git-annex assistant pending transfer queue - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/TransferSlots.hs b/Assistant/Types/TransferSlots.hs index 5140995a3..5fa1219a7 100644 --- a/Assistant/Types/TransferSlots.hs +++ b/Assistant/Types/TransferSlots.hs @@ -1,6 +1,6 @@ {- git-annex assistant transfer slots - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs index b66fdfa13..697bb8dd5 100644 --- a/Assistant/Types/TransferrerPool.hs +++ b/Assistant/Types/TransferrerPool.hs @@ -1,6 +1,6 @@ {- A pool of "git-annex transferkeys" processes available for use - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Types/UrlRenderer.hs b/Assistant/Types/UrlRenderer.hs index 521905bf3..68c238d6a 100644 --- a/Assistant/Types/UrlRenderer.hs +++ b/Assistant/Types/UrlRenderer.hs @@ -1,6 +1,6 @@ {- webapp url renderer access from the assistant - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs index 3ad98c12e..194739367 100644 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -1,6 +1,6 @@ {- git-annex assistant unused files - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -77,7 +77,7 @@ expireUnused duration = do forM_ oldkeys $ \k -> do debug ["removing old unused key", key2file k] liftAnnex $ do - removeAnnex k + lockContent k removeAnnex logStatus k InfoMissing where boundry = durationToPOSIXTime <$> duration diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index e74705021..b9ae50e27 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -1,6 +1,6 @@ {- core xmpp support - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -195,7 +195,7 @@ decodeMessage m = decode =<< gitAnnexTagInfo m <*> a i gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i))) seqgen c i = do - packet <- decodeTagContent $ tagElement i + packet <- decodeTagContent $ tagElement i let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i return $ c seqnum packet shasgen c i = do diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs index 0c466e51c..29e0e24cf 100644 --- a/Assistant/XMPP/Buddies.hs +++ b/Assistant/XMPP/Buddies.hs @@ -1,6 +1,6 @@ {- xmpp buddies - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs index 677bb2ff3..6d09d32e6 100644 --- a/Assistant/XMPP/Client.hs +++ b/Assistant/XMPP/Client.hs @@ -1,6 +1,6 @@ {- xmpp client support - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -15,7 +15,6 @@ import Network.Protocol.XMPP import Network import Control.Concurrent import qualified Data.Text as T -import Control.Exception (SomeException) {- Everything we need to know to connect to an XMPP server. -} data XMPPCreds = XMPPCreds @@ -34,18 +33,18 @@ connectXMPP c a = case parseJID (xmppJID c) of {- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -} connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())] -connectXMPP' jid c a = reverse <$> (handle =<< lookupSRV srvrecord) +connectXMPP' jid c a = reverse <$> (handlesrv =<< lookupSRV srvrecord) where srvrecord = mkSRVTcp "xmpp-client" $ T.unpack $ strDomain $ jidDomain jid serverjid = JID Nothing (jidDomain jid) Nothing - handle [] = do + handlesrv [] = do let h = xmppHostname c let p = PortNumber $ fromIntegral $ xmppPort c r <- run h p $ a jid return [r] - handle srvs = go [] srvs + handlesrv srvs = go [] srvs go l [] = return l go l ((h,p):rest) = do diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index ab34dce1e..2186b5bce 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -1,6 +1,6 @@ {- git over XMPP - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -38,7 +38,7 @@ import Utility.Env import Network.Protocol.XMPP import qualified Data.Text as T import System.Posix.Types -import System.Process (std_in, std_out, std_err) +import qualified System.Posix.IO import Control.Concurrent import System.Timeout import qualified Data.ByteString as B @@ -74,7 +74,7 @@ makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool makeXMPPGitRemote buddyname jid u = do remote <- liftAnnex $ addRemote $ makeGitRemote buddyname $ gitXMPPLocation jid - liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u + liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u liftAnnex $ void remoteListRefresh remote' <- liftAnnex $ fromMaybe (error "failed to add remote") <$> Remote.byName (Just buddyname) @@ -105,22 +105,22 @@ xmppPush cid gitpush = do u <- liftAnnex getUUID sendNetMessage $ Pushing cid (StartingPush u) - (Fd inf, writepush) <- liftIO createPipe - (readpush, Fd outf) <- liftIO createPipe - (Fd controlf, writecontrol) <- liftIO createPipe + (Fd inf, writepush) <- liftIO System.Posix.IO.createPipe + (readpush, Fd outf) <- liftIO System.Posix.IO.createPipe + (Fd controlf, writecontrol) <- liftIO System.Posix.IO.createPipe tmpdir <- gettmpdir installwrapper tmpdir - env <- liftIO getEnvironment + environ <- liftIO getEnvironment path <- liftIO getSearchPath - let myenv = addEntries + let myenviron = addEntries [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path) , (relayIn, show inf) , (relayOut, show outf) , (relayControl, show controlf) ] - env + environ inh <- liftIO $ fdToHandle readpush outh <- liftIO $ fdToHandle writepush @@ -132,7 +132,7 @@ xmppPush cid gitpush = do {- This can take a long time to run, so avoid running it in the - Annex monad. Also, override environment. -} g <- liftAnnex gitRepo - r <- liftIO $ gitpush $ g { gitEnv = Just myenv } + r <- liftIO $ gitpush $ g { gitEnv = Just myenviron } liftIO $ do mapM_ killThread [t1, t2] @@ -151,16 +151,16 @@ xmppPush cid gitpush = do SendPackOutput seqnum' b toxmpp seqnum' inh - fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handle + fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg where - handle (Just (Pushing _ (ReceivePackOutput _ b))) = + handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) = liftIO $ writeChunk outh b - handle (Just (Pushing _ (ReceivePackDone exitcode))) = + handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) = liftIO $ do hPrint controlh exitcode hFlush controlh - handle (Just _) = noop - handle Nothing = do + handlemsg (Just _) = noop + handlemsg Nothing = do debug ["timeout waiting for git receive-pack output via XMPP"] -- Send a synthetic exit code to git-annex -- xmppgit, which will exit and cause git push @@ -265,12 +265,12 @@ xmppReceivePack cid = do let seqnum' = succ seqnum sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b relaytoxmpp seqnum' outh - relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handle + relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg where - handle (Just (Pushing _ (SendPackOutput _ b))) = + handlemsg (Just (Pushing _ (SendPackOutput _ b))) = liftIO $ writeChunk inh b - handle (Just _) = noop - handle Nothing = do + handlemsg (Just _) = noop + handlemsg Nothing = do debug ["timeout waiting for git send-pack output via XMPP"] -- closing the handle will make git receive-pack exit liftIO $ do @@ -338,7 +338,7 @@ handlePushNotice (Pushing cid (CanPush theiruuid shas)) = , go ) where - go = do + go = do u <- liftAnnex getUUID sendNetMessage $ Pushing cid (PushRequest u) haveall l = liftAnnex $ not <$> anyM donthave l @@ -360,9 +360,9 @@ writeChunk h b = do withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant () withPushMessagesInSequence cid side a = loop 0 where - loop seqnum = do + loop seqnum = do m <- timeout xmppTimeout <~> waitInbox cid side - let go s = a m >> loop s + let go s = a m >> loop s let next = seqnum + 1 case extractSequence =<< m of Just seqnum' |