commit d26333883d722990b2675ea8693292a9c442575f Author: Joey Hess Date: Wed Nov 6 15:17:47 2013 +0000 git-annex (4.20131106~bpo70+1) wheezy-backports; urgency=low * Backport is now built against git 1.8.4, also now available in backports. * Improve local pairing behavior when two computers both try to start the pairing process separately. * sync: Work even when the local git repository is new and empty, with no master branch. * gcrypt, bup: Fix bug that prevented using these special remotes with encryption=pubkey. * Fix enabling of gcrypt repository accessed over ssh; git-annex-shell gcryptsetup had a bug that caused it to fail with permission denied. * Fix zombie process that occurred when switching between repository views in the webapp. * map: Work when there are gcrypt remotes. * Fix build w/o webapp. * Fix exception handling bug that could cause .git/annex/index to be used for git commits outside the git-annex branch. Known to affect git-annex when used with the git shipped with Ubuntu 13.10. # imported from the archive diff --git a/.ghci b/.ghci new file mode 100644 index 0000000000..c5550cee6e --- /dev/null +++ b/.ghci @@ -0,0 +1 @@ +:load Common diff --git a/Annex.hs b/Annex.hs new file mode 100644 index 0000000000..ae56ec5ad7 --- /dev/null +++ b/Annex.hs @@ -0,0 +1,249 @@ +{- git-annex monad + - + - Copyright 2010-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Annex ( + Annex, + AnnexState(..), + PreferredContentMap, + new, + newState, + run, + eval, + getState, + changeState, + setFlag, + setField, + setOutput, + getFlag, + getField, + addCleanup, + gitRepo, + inRepo, + fromRepo, + calcRepo, + getGitConfig, + changeGitConfig, + changeGitRepo, + withCurrentState, +) where + +import "mtl" Control.Monad.Reader +import "MonadCatchIO-transformers" Control.Monad.CatchIO +import System.Posix.Types (Fd) +import Control.Concurrent + +import Common +import qualified Git +import qualified Git.Config +import Git.CatFile +import Git.CheckAttr +import Git.CheckIgnore +import Git.SharedRepository +import qualified Git.Queue +import Types.Backend +import Types.GitConfig +import qualified Types.Remote +import Types.Crypto +import Types.BranchState +import Types.TrustLevel +import Types.Group +import Types.Messages +import Types.UUID +import Types.FileMatcher +import qualified Utility.Matcher +import qualified Data.Map as M +import qualified Data.Set as S + +{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar. + - This allows modifying the state in an exception-safe fashion. + - The MVar is not exposed outside this module. + -} +newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a } + deriving ( + Monad, + MonadIO, + MonadReader (MVar AnnexState), + MonadCatchIO, + Functor, + Applicative + ) + +type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a) +type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FileInfo -> Annex Bool)) + +-- internal state storage +data AnnexState = AnnexState + { repo :: Git.Repo + , gitconfig :: GitConfig + , backends :: [BackendA Annex] + , remotes :: [Types.Remote.RemoteA Annex] + , output :: MessageState + , force :: Bool + , fast :: Bool + , auto :: Bool + , daemon :: Bool + , branchstate :: BranchState + , repoqueue :: Maybe Git.Queue.Queue + , catfilehandles :: M.Map FilePath CatFileHandle + , checkattrhandle :: Maybe CheckAttrHandle + , checkignorehandle :: Maybe (Maybe CheckIgnoreHandle) + , forcebackend :: Maybe String + , forcenumcopies :: Maybe Int + , limit :: Matcher (FileInfo -> Annex Bool) + , uuidmap :: Maybe UUIDMap + , preferredcontentmap :: Maybe PreferredContentMap + , shared :: Maybe SharedRepository + , forcetrust :: TrustMap + , trustmap :: Maybe TrustMap + , groupmap :: Maybe GroupMap + , ciphers :: M.Map StorableCipher Cipher + , lockpool :: M.Map FilePath Fd + , flags :: M.Map String Bool + , fields :: M.Map String String + , cleanup :: M.Map String (Annex ()) + , inodeschanged :: Maybe Bool + , useragent :: Maybe String + } + +newState :: Git.Repo -> AnnexState +newState gitrepo = AnnexState + { repo = gitrepo + , gitconfig = extractGitConfig gitrepo + , backends = [] + , remotes = [] + , output = defaultMessageState + , force = False + , fast = False + , auto = False + , daemon = False + , branchstate = startBranchState + , repoqueue = Nothing + , catfilehandles = M.empty + , checkattrhandle = Nothing + , checkignorehandle = Nothing + , forcebackend = Nothing + , forcenumcopies = Nothing + , limit = Left [] + , uuidmap = Nothing + , preferredcontentmap = Nothing + , shared = Nothing + , forcetrust = M.empty + , trustmap = Nothing + , groupmap = Nothing + , ciphers = M.empty + , lockpool = M.empty + , flags = M.empty + , fields = M.empty + , cleanup = M.empty + , inodeschanged = Nothing + , useragent = Nothing + } + +{- Makes an Annex state object for the specified git repo. + - Ensures the config is read, if it was not already. -} +new :: Git.Repo -> IO AnnexState +new = newState <$$> Git.Config.read + +{- Performs an action in the Annex monad from a starting state, + - returning a new state. -} +run :: AnnexState -> Annex a -> IO (a, AnnexState) +run s a = do + mvar <- newMVar s + r <- runReaderT (runAnnex a) mvar + s' <- takeMVar mvar + return (r, s') + +{- Performs an action in the Annex monad from a starting state, + - and throws away the new state. -} +eval :: AnnexState -> Annex a -> IO a +eval s a = do + mvar <- newMVar s + runReaderT (runAnnex a) mvar + +getState :: (AnnexState -> v) -> Annex v +getState selector = do + mvar <- ask + s <- liftIO $ readMVar mvar + return $ selector s + +changeState :: (AnnexState -> AnnexState) -> Annex () +changeState modifier = do + mvar <- ask + liftIO $ modifyMVar_ mvar $ return . modifier + +{- Sets a flag to True -} +setFlag :: String -> Annex () +setFlag flag = changeState $ \s -> + s { flags = M.insertWith' const flag True $ flags s } + +{- Sets a field to a value -} +setField :: String -> String -> Annex () +setField field value = changeState $ \s -> + s { fields = M.insertWith' const field value $ fields s } + +{- Adds a cleanup action to perform. -} +addCleanup :: String -> Annex () -> Annex () +addCleanup uid a = changeState $ \s -> + s { cleanup = M.insertWith' const uid a $ cleanup s } + +{- Sets the type of output to emit. -} +setOutput :: OutputType -> Annex () +setOutput o = changeState $ \s -> + s { output = (output s) { outputType = o } } + +{- Checks if a flag was set. -} +getFlag :: String -> Annex Bool +getFlag flag = fromMaybe False . M.lookup flag <$> getState flags + +{- Gets the value of a field. -} +getField :: String -> Annex (Maybe String) +getField field = M.lookup field <$> getState fields + +{- Returns the annex's git repository. -} +gitRepo :: Annex Git.Repo +gitRepo = getState repo + +{- Runs an IO action in the annex's git repository. -} +inRepo :: (Git.Repo -> IO a) -> Annex a +inRepo a = liftIO . a =<< gitRepo + +{- Extracts a value from the annex's git repisitory. -} +fromRepo :: (Git.Repo -> a) -> Annex a +fromRepo a = a <$> gitRepo + +{- Calculates a value from an annex's git repository and its GitConfig. -} +calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a +calcRepo a = do + s <- getState id + liftIO $ a (repo s) (gitconfig s) + +{- Gets the GitConfig settings. -} +getGitConfig :: Annex GitConfig +getGitConfig = getState gitconfig + +{- Modifies a GitConfig setting. -} +changeGitConfig :: (GitConfig -> GitConfig) -> Annex () +changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) } + +{- Changing the git Repo data also involves re-extracting its GitConfig. -} +changeGitRepo :: Git.Repo -> Annex () +changeGitRepo r = changeState $ \s -> s + { repo = r + , gitconfig = extractGitConfig r + } + +{- Converts an Annex action into an IO action, that runs with a copy + - of the current Annex state. + - + - Use with caution; the action should not rely on changing the + - state, as it will be thrown away. -} +withCurrentState :: Annex a -> Annex (IO a) +withCurrentState a = do + s <- getState id + return $ eval s a diff --git a/Annex/Branch.hs b/Annex/Branch.hs new file mode 100644 index 0000000000..5978260a1f --- /dev/null +++ b/Annex/Branch.hs @@ -0,0 +1,533 @@ +{- management of the git-annex branch + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Branch ( + fullname, + name, + hasOrigin, + hasSibling, + siblingBranches, + create, + update, + forceUpdate, + updateTo, + get, + change, + commit, + forceCommit, + files, + withIndex, + performTransitions, +) where + +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Control.Exception as E + +import Common.Annex +import Annex.BranchState +import Annex.Journal +import qualified Git +import qualified Git.Command +import qualified Git.Ref +import qualified Git.Sha +import qualified Git.Branch +import qualified Git.UnionMerge +import qualified Git.UpdateIndex +import Git.HashObject +import Git.Types +import Git.FilePath +import Annex.CatFile +import Annex.Perms +import qualified Annex +import Utility.Env +import Logs +import Logs.Transitions +import Logs.Trust.Pure +import Annex.ReplaceFile +import qualified Annex.Queue +import Annex.Branch.Transitions +import Annex.Exception + +{- Name of the branch that is used to store git-annex's information. -} +name :: Git.Ref +name = Git.Ref "git-annex" + +{- Fully qualified name of the branch. -} +fullname :: Git.Ref +fullname = Git.Ref $ "refs/heads/" ++ show name + +{- Branch's name in origin. -} +originname :: Git.Ref +originname = Git.Ref $ "origin/" ++ show name + +{- Does origin/git-annex exist? -} +hasOrigin :: Annex Bool +hasOrigin = inRepo $ Git.Ref.exists originname + +{- Does the git-annex branch or a sibling foo/git-annex branch exist? -} +hasSibling :: Annex Bool +hasSibling = not . null <$> siblingBranches + +{- List of git-annex (refs, branches), including the main one and any + - from remotes. Duplicate refs are filtered out. -} +siblingBranches :: Annex [(Git.Ref, Git.Branch)] +siblingBranches = inRepo $ Git.Ref.matchingUniq [name] + +{- Creates the branch, if it does not already exist. -} +create :: Annex () +create = void getBranch + +{- Returns the ref of the branch, creating it first if necessary. -} +getBranch :: Annex Git.Ref +getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha + where + go True = do + inRepo $ Git.Command.run + [Param "branch", Param $ show name, Param $ show originname] + fromMaybe (error $ "failed to create " ++ show name) + <$> branchsha + go False = withIndex' True $ + inRepo $ Git.Branch.commit "branch created" fullname [] + use sha = do + setIndexSha sha + return sha + branchsha = inRepo $ Git.Ref.sha fullname + +{- Ensures that the branch and index are up-to-date; should be + - called before data is read from it. Runs only once per git-annex run. -} +update :: Annex () +update = runUpdateOnce $ void $ updateTo =<< siblingBranches + +{- Forces an update even if one has already been run. -} +forceUpdate :: Annex Bool +forceUpdate = updateTo =<< siblingBranches + +{- Merges the specified Refs into the index, if they have any changes not + - already in it. The Branch names are only used in the commit message; + - it's even possible that the provided Branches have not been updated to + - point to the Refs yet. + - + - The branch is fast-forwarded if possible, otherwise a merge commit is + - made. + - + - Before Refs are merged into the index, it's important to first stage the + - journal into the index. Otherwise, any changes in the journal would + - later get staged, and might overwrite changes made during the merge. + - This is only done if some of the Refs do need to be merged. + - + - Also handles performing any Transitions that have not yet been + - performed, in either the local branch, or the Refs. + - + - Returns True if any refs were merged in, False otherwise. + -} +updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool +updateTo pairs = do + -- ensure branch exists, and get its current ref + branchref <- getBranch + dirty <- journalDirty + ignoredrefs <- getIgnoredRefs + (refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs + if null refs + {- Even when no refs need to be merged, the index + - may still be updated if the branch has gotten ahead + - of the index. -} + then whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do + forceUpdateIndex jl branchref + {- When there are journalled changes + - as well as the branch being updated, + - a commit needs to be done. -} + when dirty $ + go branchref True [] [] jl + else lockJournal $ go branchref dirty refs branches + return $ not $ null refs + where + isnewer ignoredrefs (r, _) + | S.member r ignoredrefs = return False + | otherwise = inRepo $ Git.Branch.changed fullname r + go branchref dirty refs branches jl = withIndex $ do + cleanjournal <- if dirty then stageJournal jl else return noop + let merge_desc = if null branches + then "update" + else "merging " ++ + unwords (map Git.Ref.describe branches) ++ + " into " ++ show name + localtransitions <- parseTransitionsStrictly "local" + <$> getLocal transitionsLog + unless (null branches) $ do + showSideAction merge_desc + mergeIndex jl refs + let commitrefs = nub $ fullname:refs + unlessM (handleTransitions jl localtransitions commitrefs) $ do + ff <- if dirty + then return False + else inRepo $ Git.Branch.fastForward fullname refs + if ff + then updateIndex jl branchref + else commitIndex jl branchref merge_desc commitrefs + liftIO cleanjournal + +{- Gets the content of a file, which may be in the journal, or in the index + - (and committed to the branch). + - + - Updates the branch if necessary, to ensure the most up-to-date available + - content is returned. + - + - Returns an empty string if the file doesn't exist yet. -} +get :: FilePath -> Annex String +get file = do + update + getLocal file + +{- Like get, but does not merge the branch, so the info returned may not + - reflect changes in remotes. + - (Changing the value this returns, and then merging is always the + - same as using get, and then changing its value.) -} +getLocal :: FilePath -> Annex String +getLocal file = go =<< getJournalFileStale file + where + go (Just journalcontent) = return journalcontent + go Nothing = getRaw file + +getRaw :: FilePath -> Annex String +getRaw file = withIndex $ L.unpack <$> catFile fullname file + +{- Applies a function to modifiy the content of a file. + - + - Note that this does not cause the branch to be merged, it only + - modifes the current content of the file on the branch. + -} +change :: FilePath -> (String -> String) -> Annex () +change file a = lockJournal $ \jl -> a <$> getLocal file >>= set jl file + +{- Records new content of a file into the journal -} +set :: JournalLocked -> FilePath -> String -> Annex () +set = setJournalFile + +{- Stages the journal, and commits staged changes to the branch. -} +commit :: String -> Annex () +commit = whenM journalDirty . forceCommit + +{- Commits the current index to the branch even without any journalleda + - changes. -} +forceCommit :: String -> Annex () +forceCommit message = lockJournal $ \jl -> do + cleanjournal <- stageJournal jl + ref <- getBranch + withIndex $ commitIndex jl ref message [fullname] + liftIO cleanjournal + +{- Commits the staged changes in the index to the branch. + - + - Ensures that the branch's index file is first updated to the state + - of the branch at branchref, before running the commit action. This + - is needed because the branch may have had changes pushed to it, that + - are not yet reflected in the index. + - + - Also safely handles a race that can occur if a change is being pushed + - into the branch at the same time. When the race happens, the commit will + - be made on top of the newly pushed change, but without the index file + - being updated to include it. The result is that the newly pushed + - change is reverted. This race is detected and another commit made + - to fix it. + - + - The branchref value can have been obtained using getBranch at any + - previous point, though getting it a long time ago makes the race + - more likely to occur. + -} +commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex () +commitIndex jl branchref message parents = do + showStoringStateAction + commitIndex' jl branchref message parents +commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex () +commitIndex' jl branchref message parents = do + updateIndex jl branchref + committedref <- inRepo $ Git.Branch.commit message fullname parents + setIndexSha committedref + parentrefs <- commitparents <$> catObject committedref + when (racedetected branchref parentrefs) $ do + liftIO $ print ("race detected", branchref, parentrefs, "committing", (branchref, parents)) + fixrace committedref parentrefs + where + -- look for "parent ref" lines and return the refs + commitparents = map (Git.Ref . snd) . filter isparent . + map (toassoc . L.unpack) . L.lines + toassoc = separate (== ' ') + isparent (k,_) = k == "parent" + + {- The race can be detected by checking the commit's + - parent, which will be the newly pushed branch, + - instead of the expected ref that the index was updated to. -} + racedetected expectedref parentrefs + | expectedref `elem` parentrefs = False -- good parent + | otherwise = True -- race! + + {- To recover from the race, union merge the lost refs + - into the index, and recommit on top of the bad commit. -} + fixrace committedref lostrefs = do + mergeIndex jl lostrefs + commitIndex jl committedref racemessage [committedref] + + racemessage = message ++ " (recovery from race)" + +{- Lists all files on the branch. There may be duplicates in the list. -} +files :: Annex [FilePath] +files = do + update + (++) + <$> branchFiles + <*> getJournalledFilesStale + +{- Files in the branch, not including any from journalled changes, + - and without updating the branch. -} +branchFiles :: Annex [FilePath] +branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie + [ Params "ls-tree --name-only -r -z" + , Param $ show fullname + ] + +{- Populates the branch's index file with the current branch contents. + - + - This is only done when the index doesn't yet exist, and the index + - is used to build up changes to be commited to the branch, and merge + - in changes from other branches. + -} +genIndex :: Git.Repo -> IO () +genIndex g = Git.UpdateIndex.streamUpdateIndex g + [Git.UpdateIndex.lsTree fullname g] + +{- Merges the specified refs into the index. + - Any changes staged in the index will be preserved. -} +mergeIndex :: JournalLocked -> [Git.Ref] -> Annex () +mergeIndex jl branches = do + prepareModifyIndex jl + h <- catFileHandle + inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches + +{- Removes any stale git lock file, to avoid git falling over when + - updating the index. + - + - Since all modifications of the index are performed inside this module, + - and only when the journal is locked, the fact that the journal has to be + - locked when this is called ensures that no other process is currently + - modifying the index. So any index.lock file must be stale, caused + - by git running when the system crashed, or the repository's disk was + - removed, etc. + -} +prepareModifyIndex :: JournalLocked -> Annex () +prepareModifyIndex _jl = do + index <- fromRepo gitAnnexIndex + void $ liftIO $ tryIO $ removeFile $ index ++ ".lock" + +{- Runs an action using the branch's index file. -} +withIndex :: Annex a -> Annex a +withIndex = withIndex' False +withIndex' :: Bool -> Annex a -> Annex a +withIndex' bootstrapping a = do + f <- fromRepo gitAnnexIndex + g <- gitRepo +#ifdef __ANDROID__ + {- This should not be necessary on Android, but there is some + - weird getEnvironment breakage. See + - https://github.com/neurocyte/ghc-android/issues/7 + - Use getEnv to get some key environment variables that + - git expects to have. -} + let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME" + let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k + e <- liftIO $ catMaybes <$> forM keyenv getEnvPair +#else + e <- liftIO getEnvironment +#endif + let g' = g { gitEnv = Just $ ("GIT_INDEX_FILE", f):e } + + r <- tryAnnex $ do + Annex.changeState $ \s -> s { Annex.repo = g' } + checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do + unless bootstrapping create + liftIO $ createDirectoryIfMissing True $ takeDirectory f + unless bootstrapping $ inRepo genIndex + a + Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} } + either E.throw return r + +{- Updates the branch's index to reflect the current contents of the branch. + - Any changes staged in the index will be preserved. + - + - Compares the ref stored in the lock file with the current + - ref of the branch to see if an update is needed. + -} +updateIndex :: JournalLocked -> Git.Ref -> Annex () +updateIndex jl branchref = whenM (needUpdateIndex branchref) $ + forceUpdateIndex jl branchref + +forceUpdateIndex :: JournalLocked -> Git.Ref -> Annex () +forceUpdateIndex jl branchref = do + withIndex $ mergeIndex jl [fullname] + setIndexSha branchref + +{- Checks if the index needs to be updated. -} +needUpdateIndex :: Git.Ref -> Annex Bool +needUpdateIndex branchref = do + f <- fromRepo gitAnnexIndexStatus + committedref <- Git.Ref . firstLine <$> + liftIO (catchDefaultIO "" $ readFileStrict f) + return (committedref /= branchref) + +{- Record that the branch's index has been updated to correspond to a + - given ref of the branch. -} +setIndexSha :: Git.Ref -> Annex () +setIndexSha ref = do + f <- fromRepo gitAnnexIndexStatus + liftIO $ writeFile f $ show ref ++ "\n" + setAnnexPerm f + +{- Stages the journal into the index and returns an action that will + - clean up the staged journal files, which should only be run once + - the index has been committed to the branch. + - + - Before staging, this removes any existing git index file lock. + - This is safe to do because stageJournal is the only thing that + - modifies this index file, and only one can run at a time, because + - the journal is locked. So any existing git index file lock must be + - stale, and the journal must contain any data that was in the process + - of being written to the index file when it crashed. + -} +stageJournal :: JournalLocked -> Annex (IO ()) +stageJournal jl = withIndex $ do + prepareModifyIndex jl + g <- gitRepo + let dir = gitAnnexJournalDir g + fs <- getJournalFiles jl + liftIO $ do + h <- hashObjectStart g + Git.UpdateIndex.streamUpdateIndex g + [genstream dir h fs] + hashObjectStop h + return $ liftIO $ mapM_ (removeFile . (dir )) fs + where + genstream dir h fs streamer = forM_ fs $ \file -> do + let path = dir file + sha <- hashFile h path + streamer $ Git.UpdateIndex.updateIndexLine + sha FileBlob (asTopFilePath $ fileJournal file) + +{- This is run after the refs have been merged into the index, + - but before the result is committed to the branch. + - (Which is why it's passed the contents of the local branches's + - transition log before that merge took place.) + - + - When the refs contain transitions that have not yet been done locally, + - the transitions are performed on the index, and a new branch + - is created from the result. + - + - When there are transitions recorded locally that have not been done + - to the remote refs, the transitions are performed in the index, + - and committed to the existing branch. In this case, the untransitioned + - remote refs cannot be merged into the branch (since transitions + - throw away history), so they are added to the list of refs to ignore, + - to avoid re-merging content from them again. + -} +handleTransitions :: JournalLocked -> Transitions -> [Git.Ref] -> Annex Bool +handleTransitions jl localts refs = do + m <- M.fromList <$> mapM getreftransition refs + let remotets = M.elems m + if all (localts ==) remotets + then return False + else do + let allts = combineTransitions (localts:remotets) + let (transitionedrefs, untransitionedrefs) = + partition (\r -> M.lookup r m == Just allts) refs + performTransitionsLocked jl allts (localts /= allts) transitionedrefs + ignoreRefs untransitionedrefs + return True + where + getreftransition ref = do + ts <- parseTransitionsStrictly "remote" . L.unpack + <$> catFile ref transitionsLog + return (ref, ts) + +ignoreRefs :: [Git.Ref] -> Annex () +ignoreRefs rs = do + old <- getIgnoredRefs + let s = S.unions [old, S.fromList rs] + f <- fromRepo gitAnnexIgnoredRefs + replaceFile f $ \tmp -> liftIO $ writeFile tmp $ + unlines $ map show $ S.elems s + +getIgnoredRefs :: Annex (S.Set Git.Ref) +getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content + where + content = do + f <- fromRepo gitAnnexIgnoredRefs + liftIO $ catchDefaultIO "" $ readFile f + +{- Performs the specified transitions on the contents of the index file, + - commits it to the branch, or creates a new branch. + -} +performTransitions :: Transitions -> Bool -> [Ref] -> Annex () +performTransitions ts neednewlocalbranch transitionedrefs = lockJournal $ \jl -> + performTransitionsLocked jl ts neednewlocalbranch transitionedrefs +performTransitionsLocked :: JournalLocked -> Transitions -> Bool -> [Ref] -> Annex () +performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do + -- For simplicity & speed, we're going to use the Annex.Queue to + -- update the git-annex branch, while it usually holds changes + -- for the head branch. Flush any such changes. + Annex.Queue.flush + withIndex $ do + prepareModifyIndex jl + run $ mapMaybe getTransitionCalculator $ transitionList ts + Annex.Queue.flush + if neednewlocalbranch + then do + committedref <- inRepo $ Git.Branch.commit message fullname transitionedrefs + setIndexSha committedref + else do + ref <- getBranch + commitIndex jl ref message (nub $ fullname:transitionedrefs) + where + message + | neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc + | otherwise = "continuing transition " ++ tdesc + tdesc = show $ map describeTransition $ transitionList ts + + {- The changes to make to the branch are calculated and applied to + - the branch directly, rather than going through the journal, + - which would be innefficient. (And the journal is not designed + - to hold changes to every file in the branch at once.) + - + - When a file in the branch is changed by transition code, + - that value is remembered and fed into the code for subsequent + - transitions. + -} + run [] = noop + run changers = do + trustmap <- calcTrustMap <$> getRaw trustLog + fs <- branchFiles + hasher <- inRepo hashObjectStart + forM_ fs $ \f -> do + content <- getRaw f + apply changers hasher f content trustmap + liftIO $ hashObjectStop hasher + apply [] _ _ _ _ = return () + apply (changer:rest) hasher file content trustmap = + case changer file content trustmap of + RemoveFile -> do + Annex.Queue.addUpdateIndex + =<< inRepo (Git.UpdateIndex.unstageFile file) + -- File is deleted; can't run any other + -- transitions on it. + return () + ChangeFile content' -> do + sha <- inRepo $ hashObject BlobObject content' + Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ + Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file) + apply rest hasher file content' trustmap + PreserveFile -> + apply rest hasher file content trustmap diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs new file mode 100644 index 0000000000..90002de624 --- /dev/null +++ b/Annex/Branch/Transitions.hs @@ -0,0 +1,53 @@ +{- git-annex branch transitions + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Branch.Transitions ( + FileTransition(..), + getTransitionCalculator +) where + +import Logs +import Logs.Transitions +import Logs.UUIDBased as UUIDBased +import Logs.Presence.Pure as Presence +import Types.TrustLevel +import Types.UUID + +import qualified Data.Map as M + +data FileTransition + = ChangeFile String + | RemoveFile + | PreserveFile + +type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition + +getTransitionCalculator :: Transition -> Maybe TransitionCalculator +getTransitionCalculator ForgetGitHistory = Nothing +getTransitionCalculator ForgetDeadRemotes = Just dropDead + +dropDead :: FilePath -> String -> TrustMap -> FileTransition +dropDead f content trustmap = case getLogVariety f of + Just UUIDBasedLog -> ChangeFile $ + UUIDBased.showLog id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLog Just content + Just (PresenceLog _) -> + let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content + in if null newlog + then RemoveFile + else ChangeFile $ Presence.showLog newlog + Nothing -> PreserveFile + +dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String +dropDeadFromUUIDBasedLog trustmap = M.filterWithKey $ notDead trustmap . const + +{- Presence logs can contain UUIDs or other values. Any line that matches + - a dead uuid is dropped; any other values are passed through. -} +dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine] +dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info) + +notDead :: TrustMap -> (v -> UUID) -> v -> Bool +notDead trustmap a v = M.findWithDefault SemiTrusted (a v) trustmap /= DeadTrusted diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs new file mode 100644 index 0000000000..9b2f9a04c5 --- /dev/null +++ b/Annex/BranchState.hs @@ -0,0 +1,43 @@ +{- git-annex branch state management + - + - Runtime state about the git-annex branch. + - + - Copyright 2011-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.BranchState where + +import Common.Annex +import Types.BranchState +import qualified Annex + +getState :: Annex BranchState +getState = Annex.getState Annex.branchstate + +setState :: BranchState -> Annex () +setState state = Annex.changeState $ \s -> s { Annex.branchstate = state } + +changeState :: (BranchState -> BranchState) -> Annex () +changeState changer = setState =<< changer <$> getState + +{- Runs an action to check that the index file exists, if it's not been + - checked before in this run of git-annex. -} +checkIndexOnce :: Annex () -> Annex () +checkIndexOnce a = unlessM (indexChecked <$> getState) $ do + a + changeState $ \s -> s { indexChecked = True } + +{- Runs an action to update the branch, if it's not been updated before + - in this run of git-annex. -} +runUpdateOnce :: Annex () -> Annex () +runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do + a + disableUpdate + +{- Avoids updating the branch. A useful optimisation when the branch + - is known to have not changed, or git-annex won't be relying on info + - from it. -} +disableUpdate :: Annex () +disableUpdate = changeState $ \s -> s { branchUpdated = True } diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs new file mode 100644 index 0000000000..407b4ddae3 --- /dev/null +++ b/Annex/CatFile.hs @@ -0,0 +1,141 @@ +{- git cat-file interface, with handle automatically stored in the Annex monad + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.CatFile ( + catFile, + catObject, + catTree, + catObjectDetails, + catFileHandle, + catKey, + catKeyFile, + catKeyFileHEAD, +) where + +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import System.PosixCompat.Types + +import Common.Annex +import qualified Git +import qualified Git.CatFile +import qualified Annex +import Git.Types +import Git.FilePath +import Git.FileMode + +catFile :: Git.Branch -> FilePath -> Annex L.ByteString +catFile branch file = do + h <- catFileHandle + liftIO $ Git.CatFile.catFile h branch file + +catObject :: Git.Ref -> Annex L.ByteString +catObject ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catObject h ref + +catTree :: Git.Ref -> Annex [(FilePath, FileMode)] +catTree ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catTree h ref + +catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType)) +catObjectDetails ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catObjectDetails h ref + +{- There can be multiple index files, and a different cat-file is needed + - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -} +catFileHandle :: Annex Git.CatFile.CatFileHandle +catFileHandle = do + m <- Annex.getState Annex.catfilehandles + indexfile <- fromMaybe "" . maybe Nothing (lookup "GIT_INDEX_FILE") + <$> fromRepo gitEnv + case M.lookup indexfile m of + Just h -> return h + Nothing -> do + h <- inRepo Git.CatFile.catFileStart + let m' = M.insert indexfile h m + Annex.changeState $ \s -> s { Annex.catfilehandles = m' } + return h + +{- From the Sha or Ref of a symlink back to the key. + - + - Requires a mode witness, to guarantee that the file is a symlink. + -} +catKey :: Ref -> FileMode -> Annex (Maybe Key) +catKey = catKey' True + +catKey' :: Bool -> Ref -> FileMode -> Annex (Maybe Key) +catKey' modeguaranteed ref mode + | isSymLink mode = do + l <- fromInternalGitPath . encodeW8 . L.unpack <$> get + return $ if isLinkToAnnex l + then fileKey $ takeFileName l + else Nothing + | otherwise = return Nothing + where + -- If the mode is not guaranteed to be correct, avoid + -- buffering the whole file content, which might be large. + -- 8192 is enough if it really is a symlink. + get + | modeguaranteed = catObject ref + | otherwise = L.take 8192 <$> catObject ref + +{- Looks up the file mode corresponding to the Ref using the running + - cat-file. + - + - Currently this always has to look in HEAD, because cat-file --batch + - does not offer a way to specify that we want to look up a tree object + - in the index. So if the index has a file staged not as a symlink, + - and it is a symlink in head, the wrong mode is gotten. + - Also, we have to assume the file is a symlink if it's not yet committed + - to HEAD. For these reasons, modeguaranteed is not set. + -} +catKeyChecked :: Bool -> Ref -> Annex (Maybe Key) +catKeyChecked needhead ref@(Ref r) = + catKey' False ref =<< findmode <$> catTree treeref + where + pathparts = split "/" r + dir = intercalate "/" $ take (length pathparts - 1) pathparts + file = fromMaybe "" $ lastMaybe pathparts + treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/" + findmode = fromMaybe symLinkMode . headMaybe . + map snd . filter (\p -> fst p == file) + +{- From a file in the repository back to the key. + - + - Prefixing the file with ./ makes this work even if in a subdirectory + - of a repo. + - + - Ideally, this should reflect the key that's staged in the index, + - not the key that's committed to HEAD. Unfortunately, git cat-file + - does not refresh the index file after it's started up, so things + - newly staged in the index won't show up. It does, however, notice + - when branches change. + - + - For command-line git-annex use, that doesn't matter. It's perfectly + - reasonable for things staged in the index after the currently running + - git-annex process to not be noticed by it. However, we do want to see + - what's in the index, since it may have uncommitted changes not in HEAD> + - + - For the assistant, this is much more of a problem, since it commits + - files and then needs to be able to immediately look up their keys. + - OTOH, the assistant doesn't keep changes staged in the index for very + - long at all before committing them -- and it won't look at the keys + - of files until after committing them. + - + - So, this gets info from the index, unless running as a daemon. + -} +catKeyFile :: FilePath -> Annex (Maybe Key) +catKeyFile f = ifM (Annex.getState Annex.daemon) + ( catKeyFileHEAD f + , catKeyChecked True (Ref $ ":./" ++ f) + ) + +catKeyFileHEAD :: FilePath -> Annex (Maybe Key) +catKeyFileHEAD f = catKeyChecked False (Ref $ "HEAD:./" ++ f) diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs new file mode 100644 index 0000000000..8eed9e804c --- /dev/null +++ b/Annex/CheckAttr.hs @@ -0,0 +1,35 @@ +{- git check-attr interface, with handle automatically stored in the Annex monad + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.CheckAttr ( + checkAttr, + checkAttrHandle +) where + +import Common.Annex +import qualified Git.CheckAttr as Git +import qualified Annex + +{- All gitattributes used by git-annex. -} +annexAttrs :: [Git.Attr] +annexAttrs = + [ "annex.backend" + , "annex.numcopies" + ] + +checkAttr :: Git.Attr -> FilePath -> Annex String +checkAttr attr file = do + h <- checkAttrHandle + liftIO $ Git.checkAttr h attr file + +checkAttrHandle :: Annex Git.CheckAttrHandle +checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle + where + startup = do + h <- inRepo $ Git.checkAttrStart annexAttrs + Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h } + return h diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs new file mode 100644 index 0000000000..d45e652bcb --- /dev/null +++ b/Annex/CheckIgnore.hs @@ -0,0 +1,32 @@ +{- git check-ignore interface, with handle automatically stored in + - the Annex monad + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.CheckIgnore ( + checkIgnored, + checkIgnoreHandle +) where + +import Common.Annex +import qualified Git.CheckIgnore as Git +import qualified Annex + +checkIgnored :: FilePath -> Annex Bool +checkIgnored file = go =<< checkIgnoreHandle + where + go Nothing = return False + go (Just h) = liftIO $ Git.checkIgnored h file + +checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle) +checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle + where + startup = do + v <- inRepo Git.checkIgnoreStart + when (isNothing v) $ + warning "The installed version of git is too old for .gitignores to be honored by git-annex." + Annex.changeState $ \s -> s { Annex.checkignorehandle = Just v } + return v diff --git a/Annex/Content.hs b/Annex/Content.hs new file mode 100644 index 0000000000..66ca7be18b --- /dev/null +++ b/Annex/Content.hs @@ -0,0 +1,540 @@ +{- git-annex file content managing + - + - Copyright 2010-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content ( + inAnnex, + inAnnexSafe, + inAnnexCheck, + lockContent, + getViaTmp, + getViaTmpChecked, + getViaTmpUnchecked, + withTmp, + checkDiskSpace, + moveAnnex, + sendAnnex, + prepSendAnnex, + removeAnnex, + fromAnnex, + moveBad, + getKeysPresent, + saveState, + downloadUrl, + preseedTmp, + freezeContent, + thawContent, + cleanObjectLoc, + dirKeys, +) where + +import System.IO.Unsafe (unsafeInterleaveIO) +import System.PosixCompat.Files + +import Common.Annex +import Logs.Location +import qualified Git +import qualified Annex +import qualified Annex.Queue +import qualified Annex.Branch +import Utility.DiskFree +import Utility.FileMode +import qualified Annex.Url as Url +import Types.Key +import Utility.DataUnits +import Utility.CopyFile +import Config +import Git.SharedRepository +import Annex.Perms +import Annex.Link +import Annex.Content.Direct +import Annex.ReplaceFile +#ifndef mingw32_HOST_OS +import Annex.Exception +#endif + +{- Checks if a given key's content is currently present. -} +inAnnex :: Key -> Annex Bool +inAnnex key = inAnnexCheck key $ liftIO . doesFileExist + +{- Runs an arbitrary check on a key's content. -} +inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool +inAnnexCheck key check = inAnnex' id False check key + +{- Generic inAnnex, handling both indirect and direct mode. + - + - In direct mode, at least one of the associated files must pass the + - check. Additionally, the file must be unmodified. + -} +inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a +inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect + where + checkindirect loc = do + whenM (fromRepo Git.repoIsUrl) $ + error "inAnnex cannot check remote repo" + check loc + checkdirect [] = return bad + checkdirect (loc:locs) = do + r <- check loc + if isgood r + then ifM (goodContent key loc) + ( return r + , checkdirect locs + ) + else checkdirect locs + +{- A safer check; the key's content must not only be present, but + - is not in the process of being removed. -} +inAnnexSafe :: Key -> Annex (Maybe Bool) +inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go + where + go f = liftIO $ openforlock f >>= check +#ifndef mingw32_HOST_OS + openforlock f = catchMaybeIO $ + openFd f ReadOnly Nothing defaultFileFlags +#else + openforlock _ = return $ Just () +#endif + check Nothing = return is_missing +#ifndef mingw32_HOST_OS + check (Just h) = do + v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) + closeFd h + return $ case v of + Just _ -> is_locked + Nothing -> is_unlocked +#else + check (Just _) = return is_unlocked +#endif +#ifndef mingw32_HOST_OS + is_locked = Nothing +#endif + is_unlocked = Just True + is_missing = Just False + +{- Content is exclusively locked while running an action that might remove + - it. (If the content is not present, no locking is done.) -} +lockContent :: Key -> Annex a -> Annex a +#ifndef mingw32_HOST_OS +lockContent key a = do + file <- calcRepo $ gitAnnexLocation key + bracketIO (openforlock file >>= lock) unlock (const a) + where + {- Since files are stored with the write bit disabled, have + - to fiddle with permissions to open for an exclusive lock. -} + openforlock f = catchMaybeIO $ ifM (doesFileExist f) + ( withModifiedFileMode f + (`unionFileModes` ownerWriteMode) + open + , open + ) + where + open = openFd f ReadWrite Nothing defaultFileFlags + lock Nothing = return Nothing + lock (Just fd) = do + v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> error "content is locked" + Right _ -> return $ Just fd + unlock Nothing = noop + unlock (Just l) = closeFd l +#else +lockContent _key a = a -- no locking for Windows! +#endif + +{- Runs an action, passing it a temporary filename to get, + - and if the action succeeds, moves the temp file into + - the annex as a key's content. -} +getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmp = getViaTmpChecked (return True) + +{- Like getViaTmp, but does not check that there is enough disk space + - for the incoming key. For use when the key content is already on disk + - and not being copied into place. -} +getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmpUnchecked = finishGetViaTmp (return True) + +getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmpChecked check key action = do + tmp <- fromRepo $ gitAnnexTmpLocation key + + -- Check that there is enough free disk space. + -- When the temp file already exists, count the space + -- it is using as free. + e <- liftIO $ doesFileExist tmp + alreadythere <- if e + then fromIntegral . fileSize <$> liftIO (getFileStatus tmp) + else return 0 + ifM (checkDiskSpace Nothing key alreadythere) + ( do + when e $ thawContent tmp + finishGetViaTmp check key action + , return False + ) + +finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool +finishGetViaTmp check key action = do + tmpfile <- prepTmp key + ifM (action tmpfile <&&> check) + ( do + moveAnnex key tmpfile + logStatus key InfoPresent + return True + , do + -- the tmp file is left behind, in case caller wants + -- to resume its transfer + return False + ) + +prepTmp :: Key -> Annex FilePath +prepTmp key = do + tmp <- fromRepo $ gitAnnexTmpLocation key + createAnnexDirectory (parentDir tmp) + return tmp + +{- Creates a temp file, runs an action on it, and cleans up the temp file. -} +withTmp :: Key -> (FilePath -> Annex a) -> Annex a +withTmp key action = do + tmp <- prepTmp key + res <- action tmp + liftIO $ nukeFile tmp + return res + +{- Checks that there is disk space available to store a given key, + - in a destination (or the annex) printing a warning if not. -} +checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool +checkDiskSpace destination key alreadythere = do + reserve <- annexDiskReserve <$> Annex.getGitConfig + free <- liftIO . getDiskFree =<< dir + force <- Annex.getState Annex.force + case (free, keySize key) of + (Just have, Just need) -> do + let ok = (need + reserve <= have + alreadythere) || force + unless ok $ + needmorespace (need + reserve - have - alreadythere) + return ok + _ -> return True + where + dir = maybe (fromRepo gitAnnexDir) return destination + needmorespace n = + warning $ "not enough free space, need " ++ + roughSize storageUnits True n ++ + " more" ++ forcemsg + forcemsg = " (use --force to override this check or adjust annex.diskreserve)" + +{- Moves a key's content into .git/annex/objects/ + - + - In direct mode, moves it to the associated file, or files. + - + - What if the key there already has content? This could happen for + - various reasons; perhaps the same content is being annexed again. + - Perhaps there has been a hash collision generating the keys. + - + - The current strategy is to assume that in this case it's safe to delete + - one of the two copies of the content; and the one already in the annex + - is left there, assuming it's the original, canonical copy. + - + - I considered being more paranoid, and checking that both files had + - the same content. Decided against it because A) users explicitly choose + - a backend based on its hashing properties and so if they're dealing + - with colliding files it's their own fault and B) adding such a check + - would not catch all cases of colliding keys. For example, perhaps + - a remote has a key; if it's then added again with different content then + - the overall system now has two different peices of content for that + - key, and one of them will probably get deleted later. So, adding the + - check here would only raise expectations that git-annex cannot truely + - meet. + -} +moveAnnex :: Key -> FilePath -> Annex () +moveAnnex key src = withObjectLoc key storeobject storedirect + where + storeobject dest = ifM (liftIO $ doesFileExist dest) + ( alreadyhave + , do + createContentDir dest + liftIO $ moveFile src dest + freezeContent dest + freezeContentDir dest + ) + storeindirect = storeobject =<< calcRepo (gitAnnexLocation key) + + {- In direct mode, the associated file's content may be locally + - modified. In that case, it's preserved. However, the content + - we're moving into the annex may be the only extant copy, so + - it's important we not lose it. So, when the key's content + - cannot be moved to any associated file, it's stored in indirect + - mode. + -} + storedirect = storedirect' storeindirect + storedirect' fallback [] = fallback + storedirect' fallback (f:fs) = do + thawContentDir =<< calcRepo (gitAnnexLocation key) + thawContent src + v <- isAnnexLink f + if Just key == v + then do + updateInodeCache key src + replaceFile f $ liftIO . moveFile src + chmodContent f + forM_ fs $ + addContentWhenNotPresent key f + else ifM (goodContent key f) + ( storedirect' alreadyhave fs + , storedirect' fallback fs + ) + + alreadyhave = liftIO $ removeFile src + +{- Runs an action to transfer an object's content. + - + - In direct mode, it's possible for the file to change as it's being sent. + - If this happens, runs the rollback action and returns False. The + - rollback action should remove the data that was transferred. + -} +sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool +sendAnnex key rollback sendobject = go =<< prepSendAnnex key + where + go Nothing = return False + go (Just (f, checksuccess)) = do + r <- sendobject f + ifM checksuccess + ( return r + , do + rollback + return False + ) + +{- Returns a file that contains an object's content, + - and an check to run after the transfer is complete. + - + - In direct mode, it's possible for the file to change as it's being sent, + - and the check detects this case and returns False. + - + - Note that the returned check action is, in some cases, run in the + - Annex monad of the remote that is receiving the object, rather than + - the sender. So it cannot rely on Annex state. + -} +prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool)) +prepSendAnnex key = withObjectLoc key indirect direct + where + indirect f = return $ Just (f, return True) + direct [] = return Nothing + direct (f:fs) = do + cache <- recordedInodeCache key + -- check that we have a good file + ifM (sameInodeCache f cache) + ( return $ Just (f, sameInodeCache f cache) + , direct fs + ) + +{- Performs an action, passing it the location to use for a key's content. + - + - In direct mode, the associated files will be passed. But, if there are + - no associated files for a key, the indirect mode action will be + - performed instead. -} +withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a +withObjectLoc key indirect direct = ifM isDirect + ( do + fs <- associatedFiles key + if null fs + then goindirect + else direct fs + , goindirect + ) + where + goindirect = indirect =<< calcRepo (gitAnnexLocation key) + +cleanObjectLoc :: Key -> Annex () +cleanObjectLoc key = do + file <- calcRepo $ gitAnnexLocation key + unlessM crippledFileSystem $ + void $ liftIO $ catchMaybeIO $ allowWrite $ parentDir file + liftIO $ removeparents file (3 :: Int) + where + removeparents _ 0 = noop + removeparents file n = do + let dir = parentDir file + maybe noop (const $ removeparents dir (n-1)) + <=< catchMaybeIO $ removeDirectory dir + +{- Removes a key's file from .git/annex/objects/ + - + - In direct mode, deletes the associated files or files, and replaces + - them with symlinks. -} +removeAnnex :: Key -> Annex () +removeAnnex key = withObjectLoc key remove removedirect + where + remove file = do + thawContentDir file + liftIO $ nukeFile file + removeInodeCache key + cleanObjectLoc key + removedirect fs = do + thawContentDir =<< calcRepo (gitAnnexLocation key) + cache <- recordedInodeCache key + removeInodeCache key + mapM_ (resetfile cache) fs + resetfile cache f = whenM (sameInodeCache f cache) $ do + l <- inRepo $ gitAnnexLink f key + top <- fromRepo Git.repoPath + cwd <- liftIO getCurrentDirectory + let top' = fromMaybe top $ absNormPath cwd top + let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l) + replaceFile f $ makeAnnexLink l' + +{- Moves a key's file out of .git/annex/objects/ -} +fromAnnex :: Key -> FilePath -> Annex () +fromAnnex key dest = do + file <- calcRepo $ gitAnnexLocation key + thawContentDir file + thawContent file + liftIO $ moveFile file dest + cleanObjectLoc key + +{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and + - returns the file it was moved to. -} +moveBad :: Key -> Annex FilePath +moveBad key = do + src <- calcRepo $ gitAnnexLocation key + bad <- fromRepo gitAnnexBadDir + let dest = bad takeFileName src + createAnnexDirectory (parentDir dest) + thawContentDir src + liftIO $ moveFile src dest + cleanObjectLoc key + logStatus key InfoMissing + return dest + +{- List of keys whose content exists in the annex. -} +getKeysPresent :: Annex [Key] +getKeysPresent = do + direct <- isDirect + dir <- fromRepo gitAnnexObjectDir + liftIO $ traverse direct (2 :: Int) dir + where + traverse direct depth dir = do + contents <- catchDefaultIO [] (dirContents dir) + if depth == 0 + then do + contents' <- filterM (present direct) contents + let keys = mapMaybe (fileKey . takeFileName) contents' + continue keys [] + else do + let deeper = traverse direct (depth - 1) + continue [] (map deeper contents) + continue keys [] = return keys + continue keys (a:as) = do + {- Force lazy traversal with unsafeInterleaveIO. -} + morekeys <- unsafeInterleaveIO a + continue (morekeys++keys) as + + {- In indirect mode, look for the key. In direct mode, + - the inode cache file is only present when a key's content + - is present. -} + present False d = doesFileExist $ contentfile d + present True d = doesFileExist $ contentfile d ++ ".cache" + contentfile d = d takeFileName d + +{- Things to do to record changes to content when shutting down. + - + - It's acceptable to avoid committing changes to the branch, + - especially if performing a short-lived action. + -} +saveState :: Bool -> Annex () +saveState nocommit = doSideAction $ do + Annex.Queue.flush + unless nocommit $ + whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ + Annex.Branch.commit "update" + +{- Downloads content from any of a list of urls. -} +downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool +downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig + where + go Nothing = do + opts <- map Param . annexWebOptions <$> Annex.getGitConfig + headers <- getHttpHeaders + anyM (\u -> Url.withUserAgent $ Url.download u headers opts file) urls + go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls + downloadcmd basecmd url = + boolSystem "sh" [Param "-c", Param $ gencmd url basecmd] + <&&> doesFileExist file + gencmd url = massReplace + [ ("%file", shellEscape file) + , ("%url", shellEscape url) + ] + +{- Copies a key's content, when present, to a temp file. + - This is used to speed up some rsyncs. -} +preseedTmp :: Key -> FilePath -> Annex Bool +preseedTmp key file = go =<< inAnnex key + where + go False = return False + go True = do + ok <- copy + when ok $ thawContent file + return ok + copy = ifM (liftIO $ doesFileExist file) + ( return True + , do + s <- calcRepo $ gitAnnexLocation key + liftIO $ copyFileExternal s file + ) + +{- Blocks writing to an annexed file, and modifies file permissions to + - allow reading it, per core.sharedRepository setting. -} +freezeContent :: FilePath -> Annex () +freezeContent file = unlessM crippledFileSystem $ + liftIO . go =<< fromRepo getSharedRepository + where + go GroupShared = modifyFileMode file $ + removeModes writeModes . + addModes [ownerReadMode, groupReadMode] + go AllShared = modifyFileMode file $ + removeModes writeModes . + addModes readModes + go _ = modifyFileMode file $ + removeModes writeModes . + addModes [ownerReadMode] + +{- Adjusts read mode of annexed file per core.sharedRepository setting. -} +chmodContent :: FilePath -> Annex () +chmodContent file = unlessM crippledFileSystem $ + liftIO . go =<< fromRepo getSharedRepository + where + go GroupShared = modifyFileMode file $ + addModes [ownerReadMode, groupReadMode] + go AllShared = modifyFileMode file $ + addModes readModes + go _ = modifyFileMode file $ + addModes [ownerReadMode] + +{- Allows writing to an annexed file that freezeContent was called on + - before. -} +thawContent :: FilePath -> Annex () +thawContent file = unlessM crippledFileSystem $ + liftIO . go =<< fromRepo getSharedRepository + where + go GroupShared = groupWriteRead file + go AllShared = groupWriteRead file + go _ = allowWrite file + +{- Finds files directly inside a directory like gitAnnexBadDir + - (not in subdirectories) and returns the corresponding keys. -} +dirKeys :: (Git.Repo -> FilePath) -> Annex [Key] +dirKeys dirspec = do + dir <- fromRepo dirspec + ifM (liftIO $ doesDirectoryExist dir) + ( do + contents <- liftIO $ getDirectoryContents dir + files <- liftIO $ filterM doesFileExist $ + map (dir ) contents + return $ mapMaybe (fileKey . takeFileName) files + , return [] + ) + diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs new file mode 100644 index 0000000000..b0b8621e91 --- /dev/null +++ b/Annex/Content/Direct.hs @@ -0,0 +1,251 @@ +{- git-annex file content managing for direct mode + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Content.Direct ( + associatedFiles, + associatedFilesRelative, + removeAssociatedFile, + removeAssociatedFileUnchecked, + addAssociatedFile, + goodContent, + recordedInodeCache, + updateInodeCache, + addInodeCache, + writeInodeCache, + compareInodeCaches, + compareInodeCachesWith, + sameInodeCache, + elemInodeCaches, + sameFileStatus, + removeInodeCache, + toInodeCache, + inodesChanged, + createInodeSentinalFile, + addContentWhenNotPresent, +) where + +import Common.Annex +import qualified Annex +import Annex.Perms +import qualified Git +import Utility.Tmp +import Logs.Location +import Utility.InodeCache +import Utility.CopyFile +import Annex.ReplaceFile +import Annex.Link + +{- Absolute FilePaths of Files in the tree that are associated with a key. -} +associatedFiles :: Key -> Annex [FilePath] +associatedFiles key = do + files <- associatedFilesRelative key + top <- fromRepo Git.repoPath + return $ map (top ) files + +{- List of files in the tree that are associated with a key, relative to + - the top of the repo. -} +associatedFilesRelative :: Key -> Annex [FilePath] +associatedFilesRelative key = do + mapping <- calcRepo $ gitAnnexMapping key + liftIO $ catchDefaultIO [] $ do + h <- openFile mapping ReadMode + fileEncoding h + lines <$> hGetContents h + +{- Changes the associated files information for a key, applying a + - transformation to the list. Returns new associatedFiles value. -} +changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath] +changeAssociatedFiles key transform = do + mapping <- calcRepo $ gitAnnexMapping key + files <- associatedFilesRelative key + let files' = transform files + when (files /= files') $ do + createContentDir mapping + liftIO $ viaTmp write mapping $ unlines files' + top <- fromRepo Git.repoPath + return $ map (top ) files' + where + write file content = do + h <- openFile file WriteMode + fileEncoding h + hPutStr h content + hClose h + +{- Removes an associated file. Returns new associatedFiles value. + - Checks if this was the last copy of the object, and updates location + - log. -} +removeAssociatedFile :: Key -> FilePath -> Annex [FilePath] +removeAssociatedFile key file = do + fs <- removeAssociatedFileUnchecked key file + when (null fs) $ + logStatus key InfoMissing + return fs + +{- Removes an associated file. Returns new associatedFiles value. -} +removeAssociatedFileUnchecked :: Key -> FilePath -> Annex [FilePath] +removeAssociatedFileUnchecked key file = do + file' <- normaliseAssociatedFile file + changeAssociatedFiles key $ filter (/= file') + +{- Adds an associated file. Returns new associatedFiles value. -} +addAssociatedFile :: Key -> FilePath -> Annex [FilePath] +addAssociatedFile key file = do + file' <- normaliseAssociatedFile file + changeAssociatedFiles key $ \files -> + if file' `elem` files + then files + else file':files + +{- Associated files are always stored relative to the top of the repository. + - The input FilePath is relative to the CWD, or is absolute. -} +normaliseAssociatedFile :: FilePath -> Annex FilePath +normaliseAssociatedFile file = do + top <- fromRepo Git.repoPath + liftIO $ relPathDirToFile top <$> absPath file + +{- Checks if a file in the tree, associated with a key, has not been modified. + - + - To avoid needing to fsck the file's content, which can involve an + - expensive checksum, this relies on a cache that contains the file's + - expected mtime and inode. + -} +goodContent :: Key -> FilePath -> Annex Bool +goodContent key file = sameInodeCache file =<< recordedInodeCache key + +{- Gets the recorded inode cache for a key. + - + - A key can be associated with multiple files, so may return more than + - one. -} +recordedInodeCache :: Key -> Annex [InodeCache] +recordedInodeCache key = withInodeCacheFile key $ \f -> + liftIO $ catchDefaultIO [] $ + mapMaybe readInodeCache . lines <$> readFileStrict f + +{- Caches an inode for a file. + - + - Anything else already cached is preserved. + -} +updateInodeCache :: Key -> FilePath -> Annex () +updateInodeCache key file = maybe noop (addInodeCache key) + =<< liftIO (genInodeCache file) + +{- Adds another inode to the cache for a key. -} +addInodeCache :: Key -> InodeCache -> Annex () +addInodeCache key cache = do + oldcaches <- recordedInodeCache key + unlessM (elemInodeCaches cache oldcaches) $ + writeInodeCache key (cache:oldcaches) + +{- Writes inode cache for a key. -} +writeInodeCache :: Key -> [InodeCache] -> Annex () +writeInodeCache key caches = withInodeCacheFile key $ \f -> do + createContentDir f + liftIO $ writeFile f $ + unlines $ map showInodeCache caches + +{- Removes an inode cache. -} +removeInodeCache :: Key -> Annex () +removeInodeCache key = withInodeCacheFile key $ \f -> do + createContentDir f -- also thaws directory + liftIO $ nukeFile f + +withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a +withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key) + +{- Checks if a InodeCache matches the current version of a file. -} +sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool +sameInodeCache _ [] = return False +sameInodeCache file old = go =<< liftIO (genInodeCache file) + where + go Nothing = return False + go (Just curr) = elemInodeCaches curr old + +{- Checks if a FileStatus matches the recorded InodeCache of a file. -} +sameFileStatus :: Key -> FileStatus -> Annex Bool +sameFileStatus key status = do + old <- recordedInodeCache key + let curr = toInodeCache status + case (old, curr) of + (_, Just c) -> elemInodeCaches c old + ([], Nothing) -> return True + _ -> return False + +{- If the inodes have changed, only the size and mtime are compared. -} +compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool +compareInodeCaches x y + | compareStrong x y = return True + | otherwise = ifM inodesChanged + ( return $ compareWeak x y + , return False + ) + +elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool +elemInodeCaches _ [] = return False +elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l) + ( return True + , elemInodeCaches c ls + ) + +compareInodeCachesWith :: Annex InodeComparisonType +compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly ) + +{- Copies the contentfile to the associated file, if the associated + - file has no content. If the associated file does have content, + - even if the content differs, it's left unchanged. -} +addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex () +addContentWhenNotPresent key contentfile associatedfile = do + v <- isAnnexLink associatedfile + when (Just key == v) $ + replaceFile associatedfile $ + liftIO . void . copyFileExternal contentfile + updateInodeCache key associatedfile + +{- Some filesystems get new inodes each time they are mounted. + - In order to work on such a filesystem, a sentinal file is used to detect + - when the inodes have changed. + - + - If the sentinal file does not exist, we have to assume that the + - inodes have changed. + -} +inodesChanged :: Annex Bool +inodesChanged = maybe calc return =<< Annex.getState Annex.inodeschanged + where + calc = do + scache <- liftIO . genInodeCache + =<< fromRepo gitAnnexInodeSentinal + scached <- readInodeSentinalFile + let changed = case (scache, scached) of + (Just c1, Just c2) -> not $ compareStrong c1 c2 + _ -> True + Annex.changeState $ \s -> s { Annex.inodeschanged = Just changed } + return changed + +readInodeSentinalFile :: Annex (Maybe InodeCache) +readInodeSentinalFile = do + sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache + liftIO $ catchDefaultIO Nothing $ + readInodeCache <$> readFile sentinalcachefile + +writeInodeSentinalFile :: Annex () +writeInodeSentinalFile = do + sentinalfile <- fromRepo gitAnnexInodeSentinal + createAnnexDirectory (parentDir sentinalfile) + sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache + liftIO $ writeFile sentinalfile "" + liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache) + =<< genInodeCache sentinalfile + +{- The sentinal file is only created when first initializing a repository. + - If there are any annexed objects in the repository already, creating + - the file would invalidate their inode caches. -} +createInodeSentinalFile :: Annex () +createInodeSentinalFile = + unlessM (alreadyexists <||> hasobjects) + writeInodeSentinalFile + where + alreadyexists = isJust <$> readInodeSentinalFile + hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir diff --git a/Annex/Direct.hs b/Annex/Direct.hs new file mode 100644 index 0000000000..ea2b577b9d --- /dev/null +++ b/Annex/Direct.hs @@ -0,0 +1,233 @@ +{- git-annex direct mode + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Direct where + +import Common.Annex +import qualified Git +import qualified Git.LsFiles +import qualified Git.Merge +import qualified Git.DiffTree as DiffTree +import Git.Sha +import Git.FilePath +import Git.Types +import Annex.CatFile +import qualified Annex.Queue +import Logs.Location +import Backend +import Types.KeySource +import Annex.Content +import Annex.Content.Direct +import Annex.Link +import Utility.InodeCache +import Utility.CopyFile +import Annex.Perms +import Annex.ReplaceFile +import Annex.Exception + +{- Uses git ls-files to find files that need to be committed, and stages + - them into the index. Returns True if some changes were staged. -} +stageDirect :: Annex Bool +stageDirect = do + Annex.Queue.flush + top <- fromRepo Git.repoPath + (l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top] + forM_ l go + void $ liftIO cleanup + staged <- Annex.Queue.size + Annex.Queue.flush + return $ staged /= 0 + where + {- Determine what kind of modified or deleted file this is, as + - efficiently as we can, by getting any key that's associated + - with it in git, as well as its stat info. -} + go (file, Just sha, Just mode) = do + shakey <- catKey sha mode + mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + filekey <- isAnnexLink file + case (shakey, filekey, mstat, toInodeCache =<< mstat) of + (_, Just key, _, _) + | shakey == filekey -> noop + {- A changed symlink. -} + | otherwise -> stageannexlink file key + (Just key, _, _, Just cache) -> do + {- All direct mode files will show as + - modified, so compare the cache to see if + - it really was. -} + oldcache <- recordedInodeCache key + case oldcache of + [] -> modifiedannexed file key cache + _ -> unlessM (elemInodeCaches cache oldcache) $ + modifiedannexed file key cache + (Just key, _, Nothing, _) -> deletedannexed file key + (Nothing, _, Nothing, _) -> deletegit file + (_, _, Just _, _) -> addgit file + go _ = noop + + modifiedannexed file oldkey cache = do + void $ removeAssociatedFile oldkey file + void $ addDirect file cache + + deletedannexed file key = do + void $ removeAssociatedFile key file + deletegit file + + stageannexlink file key = do + l <- inRepo $ gitAnnexLink file key + stageSymlink file =<< hashSymlink l + void $ addAssociatedFile key file + + addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file] + + deletegit file = Annex.Queue.addCommand "rm" [Param "-f"] [file] + +{- Adds a file to the annex in direct mode. Can fail, if the file is + - modified or deleted while it's being added. -} +addDirect :: FilePath -> InodeCache -> Annex Bool +addDirect file cache = do + showStart "add" file + let source = KeySource + { keyFilename = file + , contentLocation = file + , inodeCache = Just cache + } + got =<< genKey source =<< chooseBackend file + where + got Nothing = do + showEndFail + return False + got (Just (key, _)) = ifM (sameInodeCache file [cache]) + ( do + l <- inRepo $ gitAnnexLink file key + stageSymlink file =<< hashSymlink l + addInodeCache key cache + void $ addAssociatedFile key file + logStatus key InfoPresent + showEndOk + return True + , do + showEndFail + return False + ) + +{- In direct mode, git merge would usually refuse to do anything, since it + - sees present direct mode files as type changed files. To avoid this, + - merge is run with the work tree set to a temp directory. + - + - This should only be used once any changes to the real working tree have + - already been committed, because it overwrites files in the working tree. + -} +mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool +mergeDirect d branch g = do + whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d + createDirectoryIfMissing True d + let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } } + Git.Merge.mergeNonInteractive branch g' + +{- Cleans up after a direct mode merge. The merge must have been committed, + - and the commit sha passed in, along with the old sha of the tree + - before the merge. Uses git diff-tree to find files that changed between + - the two shas, and applies those changes to the work tree. + -} +mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex () +mergeDirectCleanup d oldsha newsha = do + (items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha + makeabs <- flip fromTopFilePath <$> gitRepo + forM_ items (updated makeabs) + void $ liftIO cleanup + liftIO $ removeDirectoryRecursive d + where + updated makeabs item = do + let f = makeabs (DiffTree.file item) + void $ tryAnnex $ + go f DiffTree.srcsha DiffTree.srcmode moveout moveout_raw + void $ tryAnnex $ + go f DiffTree.dstsha DiffTree.dstmode movein movein_raw + where + go f getsha getmode a araw + | getsha item == nullSha = noop + | otherwise = maybe (araw f) (\k -> void $ a k f) + =<< catKey (getsha item) (getmode item) + + moveout = removeDirect + + {- Files deleted by the merge are removed from the work tree. + - Empty work tree directories are removed, per git behavior. -} + moveout_raw f = liftIO $ do + nukeFile f + void $ tryIO $ removeDirectory $ parentDir f + + {- If the file is already present, with the right content for the + - key, it's left alone. Otherwise, create the symlink and then + - if possible, replace it with the content. -} + movein k f = unlessM (goodContent k f) $ do + l <- inRepo $ gitAnnexLink f k + replaceFile f $ makeAnnexLink l + toDirect k f + + {- Any new, modified, or renamed files were written to the temp + - directory by the merge, and are moved to the real work tree. -} + movein_raw f = liftIO $ do + createDirectoryIfMissing True $ parentDir f + void $ tryIO $ rename (d f) f + +{- If possible, converts a symlink in the working tree into a direct + - mode file. If the content is not available, leaves the symlink + - unchanged. -} +toDirect :: Key -> FilePath -> Annex () +toDirect k f = fromMaybe noop =<< toDirectGen k f + +toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ())) +toDirectGen k f = do + loc <- calcRepo $ gitAnnexLocation k + ifM (liftIO $ doesFileExist loc) + ( return $ Just $ fromindirect loc + , do + {- Copy content from another direct file. -} + absf <- liftIO $ absPath f + dlocs <- filterM (goodContent k) =<< + filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<< + (filter (/= absf) <$> addAssociatedFile k f) + case dlocs of + [] -> return Nothing + (dloc:_) -> return $ Just $ fromdirect dloc + ) + where + fromindirect loc = do + {- Move content from annex to direct file. -} + thawContentDir loc + updateInodeCache k loc + void $ addAssociatedFile k f + thawContent loc + replaceFile f $ liftIO . moveFile loc + fromdirect loc = do + replaceFile f $ + liftIO . void . copyFileExternal loc + updateInodeCache k f + +{- Removes a direct mode file, while retaining its content in the annex + - (unless its content has already been changed). -} +removeDirect :: Key -> FilePath -> Annex () +removeDirect k f = do + void $ removeAssociatedFileUnchecked k f + unlessM (inAnnex k) $ + ifM (goodContent k f) + ( moveAnnex k f + , logStatus k InfoMissing + ) + liftIO $ do + nukeFile f + void $ tryIO $ removeDirectory $ parentDir f + +{- Called when a direct mode file has been changed. Its old content may be + - lost. -} +changedDirect :: Key -> FilePath -> Annex () +changedDirect oldk f = do + locs <- removeAssociatedFile oldk f + whenM (pure (null locs) <&&> not <$> inAnnex oldk) $ + logStatus oldk InfoMissing diff --git a/Annex/Environment.hs b/Annex/Environment.hs new file mode 100644 index 0000000000..f22c5f2d49 --- /dev/null +++ b/Annex/Environment.hs @@ -0,0 +1,65 @@ +{- git-annex environment + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Environment where + +import Common.Annex +import Utility.UserInfo +import qualified Git.Config +import Config +import Annex.Exception + +#ifndef mingw32_HOST_OS +import Utility.Env +#endif + +{- Checks that the system's environment allows git to function. + - Git requires a GECOS username, or suitable git configuration, or + - environment variables. + - + - Git also requires the system have a hostname containing a dot. + - Otherwise, it tries various methods to find a FQDN, and will fail if it + - does not. To avoid replicating that code here, which would break if its + - methods change, this function does not check the hostname is valid. + - Instead, code that commits can use ensureCommit. + -} +checkEnvironment :: Annex () +checkEnvironment = do + gitusername <- fromRepo $ Git.Config.getMaybe "user.name" + when (isNothing gitusername || gitusername == Just "") $ + liftIO checkEnvironmentIO + +checkEnvironmentIO :: IO () +checkEnvironmentIO = +#ifdef mingw32_HOST_OS + noop +#else + whenM (null <$> myUserGecos) $ do + username <- myUserName + ensureEnv "GIT_AUTHOR_NAME" username + ensureEnv "GIT_COMMITTER_NAME" username + where +#ifndef __ANDROID__ + -- existing environment is not overwritten + ensureEnv var val = void $ setEnv var val False +#else + -- Environment setting is broken on Android, so this is dealt with + -- in runshell instead. + ensureEnv _ _ = noop +#endif +#endif + +{- Runs an action that commits to the repository, and if it fails, + - sets user.email to a dummy value and tries the action again. -} +ensureCommit :: Annex a -> Annex a +ensureCommit a = either retry return =<< tryAnnex a + where + retry _ = do + setConfig (ConfigKey "user.email") =<< liftIO myUserName + a diff --git a/Annex/Exception.hs b/Annex/Exception.hs new file mode 100644 index 0000000000..aaa6811a53 --- /dev/null +++ b/Annex/Exception.hs @@ -0,0 +1,44 @@ +{- exception handling in the git-annex monad + - + - Note that when an Annex action fails and the exception is handled + - by these functions, any changes the action has made to the + - AnnexState are retained. This works because the Annex monad + - internally stores the AnnexState in a MVar. + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Exception ( + bracketIO, + tryAnnex, + tryAnnexIO, + throwAnnex, + catchAnnex, +) where + +import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M +import Control.Exception + +import Common.Annex + +{- Runs an Annex action, with setup and cleanup both in the IO monad. -} +bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a +bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup) + +{- try in the Annex monad -} +tryAnnex :: Annex a -> Annex (Either SomeException a) +tryAnnex = M.try + +{- try in the Annex monad, but only catching IO exceptions -} +tryAnnexIO :: Annex a -> Annex (Either IOException a) +tryAnnexIO = M.try + +{- throw in the Annex monad -} +throwAnnex :: Exception e => e -> Annex a +throwAnnex = M.throw + +{- catch in the Annex monad -} +catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a +catchAnnex = M.catch diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs new file mode 100644 index 0000000000..cded857a23 --- /dev/null +++ b/Annex/FileMatcher.hs @@ -0,0 +1,102 @@ +{- git-annex file matching + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.FileMatcher where + +import qualified Data.Map as M + +import Common.Annex +import Limit +import Utility.Matcher +import Types.Group +import Types.Limit +import Logs.Group +import Logs.Remote +import Annex.UUID +import qualified Annex +import Types.FileMatcher +import Git.FilePath +import Types.Remote (RemoteConfig) + +import Data.Either +import qualified Data.Set as S + +type FileMatcher = Matcher MatchFiles + +checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool +checkFileMatcher matcher file = checkFileMatcher' matcher file S.empty True + +checkFileMatcher' :: FileMatcher -> FilePath -> AssumeNotPresent -> Bool -> Annex Bool +checkFileMatcher' matcher file notpresent def + | isEmpty matcher = return def + | otherwise = do + matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) + let fi = FileInfo + { matchFile = matchfile + , relFile = file + } + matchMrun matcher $ \a -> a notpresent fi + +matchAll :: FileMatcher +matchAll = generate [] + +parsedToMatcher :: [Either String (Token MatchFiles)] -> Either String FileMatcher +parsedToMatcher parsed = case partitionEithers parsed of + ([], vs) -> Right $ generate vs + (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es + +exprParser :: GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)] +exprParser groupmap configmap mu expr = + map parse $ tokenizeMatcher expr + where + parse = parseToken + (limitPresent mu) + (limitInDir preferreddir) + groupmap + preferreddir = fromMaybe "public" $ + M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu + +parseToken :: MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) +parseToken checkpresent checkpreferreddir groupmap t + | t `elem` tokens = Right $ token t + | t == "present" = use checkpresent + | t == "inpreferreddir" = use checkpreferreddir + | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $ + M.fromList + [ ("include", limitInclude) + , ("exclude", limitExclude) + , ("copies", limitCopies) + , ("inbackend", limitInBackend) + , ("largerthan", limitSize (>)) + , ("smallerthan", limitSize (<)) + , ("inallgroup", limitInAllGroup groupmap) + ] + where + (k, v) = separate (== '=') t + use a = Operation <$> a v + +{- This is really dumb tokenization; there's no support for quoted values. + - Open and close parens are always treated as standalone tokens; + - otherwise tokens must be separated by whitespace. -} +tokenizeMatcher :: String -> [String] +tokenizeMatcher = filter (not . null ) . concatMap splitparens . words + where + splitparens = segmentDelim (`elem` "()") + +{- Generates a matcher for files large enough (or meeting other criteria) + - to be added to the annex, rather than directly to git. -} +largeFilesMatcher :: Annex FileMatcher +largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig + where + go Nothing = return matchAll + go (Just expr) = do + gm <- groupMap + rc <- readRemoteLog + u <- getUUID + either badexpr return $ + parsedToMatcher $ exprParser gm rc (Just u) expr + badexpr e = error $ "bad annex.largefiles configuration: " ++ e diff --git a/Annex/Journal.hs b/Annex/Journal.hs new file mode 100644 index 0000000000..8b88ab2fbf --- /dev/null +++ b/Annex/Journal.hs @@ -0,0 +1,128 @@ +{- management of the git-annex journal + - + - The journal is used to queue up changes before they are committed to the + - git-annex branch. Among other things, it ensures that if git-annex is + - interrupted, its recorded data is not lost. + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Journal where + +import System.IO.Binary + +import Common.Annex +import Annex.Exception +import qualified Git +import Annex.Perms + +{- Records content for a file in the branch to the journal. + - + - Using the journal, rather than immediatly staging content to the index + - avoids git needing to rewrite the index after every change. + - + - The file in the journal is updated atomically, which allows + - getJournalFileStale to always return a consistent journal file + - content, although possibly not the most current one. + -} +setJournalFile :: JournalLocked -> FilePath -> String -> Annex () +setJournalFile _jl file content = do + createAnnexDirectory =<< fromRepo gitAnnexJournalDir + createAnnexDirectory =<< fromRepo gitAnnexTmpDir + -- journal file is written atomically + jfile <- fromRepo $ journalFile file + tmp <- fromRepo gitAnnexTmpDir + let tmpfile = tmp takeFileName jfile + liftIO $ do + writeBinaryFile tmpfile content + moveFile tmpfile jfile + +{- Gets any journalled content for a file in the branch. -} +getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe String) +getJournalFile _jl = getJournalFileStale + +{- Without locking, this is not guaranteed to be the most recent + - version of the file in the journal, so should not be used as a basis for + - changes. -} +getJournalFileStale :: FilePath -> Annex (Maybe String) +getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ + readFileStrict $ journalFile file g + +{- List of files that have updated content in the journal. -} +getJournalledFiles :: JournalLocked -> Annex [FilePath] +getJournalledFiles jl = map fileJournal <$> getJournalFiles jl + +getJournalledFilesStale :: Annex [FilePath] +getJournalledFilesStale = map fileJournal <$> getJournalFilesStale + +{- List of existing journal files. -} +getJournalFiles :: JournalLocked -> Annex [FilePath] +getJournalFiles _jl = getJournalFilesStale + +{- List of existing journal files, but without locking, may miss new ones + - just being added, or may have false positives if the journal is staged + - as it is run. -} +getJournalFilesStale :: Annex [FilePath] +getJournalFilesStale = do + g <- gitRepo + fs <- liftIO $ catchDefaultIO [] $ + getDirectoryContents $ gitAnnexJournalDir g + return $ filter (`notElem` [".", ".."]) fs + +{- Checks if there are changes in the journal. -} +journalDirty :: Annex Bool +journalDirty = not . null <$> getJournalFilesStale + +{- Produces a filename to use in the journal for a file on the branch. + - + - The journal typically won't have a lot of files in it, so the hashing + - used in the branch is not necessary, and all the files are put directly + - in the journal directory. + -} +journalFile :: FilePath -> Git.Repo -> FilePath +journalFile file repo = gitAnnexJournalDir repo concatMap mangle file + where + mangle c + | c == pathSeparator = "_" + | c == '_' = "__" + | otherwise = [c] + +{- Converts a journal file (relative to the journal dir) back to the + - filename on the branch. -} +fileJournal :: FilePath -> FilePath +fileJournal = replace [pathSeparator, pathSeparator] "_" . + replace "_" [pathSeparator] + +{- Sentinal value, only produced by lockJournal; required + - as a parameter by things that need to ensure the journal is + - locked. -} +data JournalLocked = ProduceJournalLocked + +{- Runs an action that modifies the journal, using locking to avoid + - contention with other git-annex processes. -} +lockJournal :: (JournalLocked -> Annex a) -> Annex a +lockJournal a = do + lockfile <- fromRepo gitAnnexJournalLock + createAnnexDirectory $ takeDirectory lockfile + mode <- annexFileMode + bracketIO (lock lockfile mode) unlock (const $ a ProduceJournalLocked) + where +#ifndef mingw32_HOST_OS + lock lockfile mode = do + l <- noUmask mode $ createFile lockfile mode + waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0) + return l +#else + lock lockfile _mode = do + writeFile lockfile "" + return lockfile +#endif +#ifndef mingw32_HOST_OS + unlock = closeFd +#else + unlock = removeFile +#endif diff --git a/Annex/Link.hs b/Annex/Link.hs new file mode 100644 index 0000000000..30d8c2ae8c --- /dev/null +++ b/Annex/Link.hs @@ -0,0 +1,105 @@ +{- git-annex links to content + - + - On file systems that support them, symlinks are used. + - + - On other filesystems, git instead stores the symlink target in a regular + - file. + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Link where + +import Common.Annex +import qualified Annex +import qualified Git.HashObject +import qualified Git.UpdateIndex +import qualified Annex.Queue +import Git.Types +import Git.FilePath + +type LinkTarget = String + +{- Checks if a file is a link to a key. -} +isAnnexLink :: FilePath -> Annex (Maybe Key) +isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file + +{- Gets the link target of a symlink. + - + - On a filesystem that does not support symlinks, fall back to getting the + - link target by looking inside the file. + - + - Returns Nothing if the file is not a symlink, or not a link to annex + - content. + -} +getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget) +getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig) + ( check readSymbolicLink $ + return Nothing + , check readSymbolicLink $ + check probefilecontent $ + return Nothing + ) + where + check getlinktarget fallback = do + v <- liftIO $ catchMaybeIO $ getlinktarget file + case v of + Just l + | isLinkToAnnex (fromInternalGitPath l) -> return v + | otherwise -> return Nothing + Nothing -> fallback + + probefilecontent f = do + h <- openFile f ReadMode + fileEncoding h + -- The first 8k is more than enough to read; link + -- files are small. + s <- take 8192 <$> hGetContents h + -- If we got the full 8k, the file is too large + if length s == 8192 + then do + hClose h + return "" + else do + hClose h + -- If there are any NUL or newline + -- characters, or whitespace, we + -- certianly don't have a link to a + -- git-annex key. + return $ if any (`elem` s) "\0\n\r \t" + then "" + else s + +{- Creates a link on disk. + - + - On a filesystem that does not support symlinks, writes the link target + - to a file. Note that git will only treat the file as a symlink if + - it's staged as such, so use addAnnexLink when adding a new file or + - modified link to git. + -} +makeAnnexLink :: LinkTarget -> FilePath -> Annex () +makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) + ( liftIO $ do + void $ tryIO $ removeFile file + createSymbolicLink linktarget file + , liftIO $ writeFile file linktarget + ) + +{- Creates a link on disk, and additionally stages it in git. -} +addAnnexLink :: LinkTarget -> FilePath -> Annex () +addAnnexLink linktarget file = do + makeAnnexLink linktarget file + stageSymlink file =<< hashSymlink linktarget + +{- Injects a symlink target into git, returning its Sha. -} +hashSymlink :: LinkTarget -> Annex Sha +hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $ + toInternalGitPath linktarget + +{- Stages a symlink to the annex, using a Sha of its target. -} +stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink file sha = + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.stageSymlink file sha) diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs new file mode 100644 index 0000000000..a9a0f31019 --- /dev/null +++ b/Annex/LockPool.hs @@ -0,0 +1,56 @@ +{- git-annex lock pool + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.LockPool where + +import qualified Data.Map as M +import System.Posix.Types (Fd) + +import Common.Annex +import Annex +#ifndef mingw32_HOST_OS +import Annex.Perms +#endif + +{- Create a specified lock file, and takes a shared lock. -} +lockFile :: FilePath -> Annex () +lockFile file = go =<< fromPool file + where + go (Just _) = noop -- already locked + go Nothing = do +#ifndef mingw32_HOST_OS + mode <- annexFileMode + fd <- liftIO $ noUmask mode $ + openFd file ReadOnly (Just mode) defaultFileFlags + liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0) +#else + liftIO $ writeFile file "" + let fd = 0 +#endif + changePool $ M.insert file fd + +unlockFile :: FilePath -> Annex () +unlockFile file = maybe noop go =<< fromPool file + where + go fd = do +#ifndef mingw32_HOST_OS + liftIO $ closeFd fd +#endif + changePool $ M.delete file + +getPool :: Annex (M.Map FilePath Fd) +getPool = getState lockpool + +fromPool :: FilePath -> Annex (Maybe Fd) +fromPool file = M.lookup file <$> getPool + +changePool :: (M.Map FilePath Fd -> M.Map FilePath Fd) -> Annex () +changePool a = do + m <- getPool + changeState $ \s -> s { lockpool = a m } diff --git a/Annex/Perms.hs b/Annex/Perms.hs new file mode 100644 index 0000000000..f5925b741a --- /dev/null +++ b/Annex/Perms.hs @@ -0,0 +1,105 @@ +{- git-annex file permissions + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Perms ( + setAnnexPerm, + annexFileMode, + createAnnexDirectory, + noUmask, + createContentDir, + freezeContentDir, + thawContentDir, +) where + +import Common.Annex +import Utility.FileMode +import Git.SharedRepository +import qualified Annex +import Config + +import System.Posix.Types + +withShared :: (SharedRepository -> Annex a) -> Annex a +withShared a = maybe startup a =<< Annex.getState Annex.shared + where + startup = do + shared <- fromRepo getSharedRepository + Annex.changeState $ \s -> s { Annex.shared = Just shared } + a shared + +{- Sets appropriate file mode for a file or directory in the annex, + - other than the content files and content directory. Normally, + - use the default mode, but with core.sharedRepository set, + - allow the group to write, etc. -} +setAnnexPerm :: FilePath -> Annex () +setAnnexPerm file = unlessM crippledFileSystem $ + withShared $ liftIO . go + where + go GroupShared = groupWriteRead file + go AllShared = modifyFileMode file $ addModes $ + [ ownerWriteMode, groupWriteMode ] ++ readModes + go _ = noop + +{- Gets the appropriate mode to use for creating a file in the annex + - (other than content files, which are locked down more). -} +annexFileMode :: Annex FileMode +annexFileMode = withShared $ return . go + where + go GroupShared = sharedmode + go AllShared = combineModes (sharedmode:readModes) + go _ = stdFileMode + sharedmode = combineModes + [ ownerWriteMode, groupWriteMode + , ownerReadMode, groupReadMode + ] + +{- Creates a directory inside the gitAnnexDir, including any parent + - directories. Makes directories with appropriate permissions. -} +createAnnexDirectory :: FilePath -> Annex () +createAnnexDirectory dir = traverse dir [] =<< top + where + top = parentDir <$> fromRepo gitAnnexDir + traverse d below stop + | d `equalFilePath` stop = done + | otherwise = ifM (liftIO $ doesDirectoryExist d) + ( done + , traverse (parentDir d) (d:below) stop + ) + where + done = forM_ below $ \p -> do + liftIO $ createDirectoryIfMissing True p + setAnnexPerm p + +{- Blocks writing to the directory an annexed file is in, to prevent the + - file accidentially being deleted. However, if core.sharedRepository + - is set, this is not done, since the group must be allowed to delete the + - file. + -} +freezeContentDir :: FilePath -> Annex () +freezeContentDir file = unlessM crippledFileSystem $ + liftIO . go =<< fromRepo getSharedRepository + where + dir = parentDir file + go GroupShared = groupWriteRead dir + go AllShared = groupWriteRead dir + go _ = preventWrite dir + +thawContentDir :: FilePath -> Annex () +thawContentDir file = unlessM crippledFileSystem $ + liftIO $ allowWrite $ parentDir file + +{- Makes the directory tree to store an annexed file's content, + - with appropriate permissions on each level. -} +createContentDir :: FilePath -> Annex () +createContentDir dest = do + unlessM (liftIO $ doesDirectoryExist dir) $ + createAnnexDirectory dir + -- might have already existed with restricted perms + unlessM crippledFileSystem $ + liftIO $ allowWrite dir + where + dir = parentDir dest diff --git a/Annex/Queue.hs b/Annex/Queue.hs new file mode 100644 index 0000000000..a5ef600379 --- /dev/null +++ b/Annex/Queue.hs @@ -0,0 +1,62 @@ +{- git-annex command queue + - + - Copyright 2011, 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Queue ( + addCommand, + addUpdateIndex, + flush, + flushWhenFull, + size +) where + +import Common.Annex +import Annex hiding (new) +import qualified Git.Queue +import qualified Git.UpdateIndex + +{- Adds a git command to the queue. -} +addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () +addCommand command params files = do + q <- get + store <=< inRepo $ Git.Queue.addCommand command params files q + +{- Adds an update-index stream to the queue. -} +addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex () +addUpdateIndex streamer = do + q <- get + store <=< inRepo $ Git.Queue.addUpdateIndex streamer q + +{- Runs the queue if it is full. Should be called periodically. -} +flushWhenFull :: Annex () +flushWhenFull = do + q <- get + when (Git.Queue.full q) flush + +{- Runs (and empties) the queue. -} +flush :: Annex () +flush = do + q <- get + unless (0 == Git.Queue.size q) $ do + showStoringStateAction + q' <- inRepo $ Git.Queue.flush q + store q' + +{- Gets the size of the queue. -} +size :: Annex Int +size = Git.Queue.size <$> get + +get :: Annex Git.Queue.Queue +get = maybe new return =<< getState repoqueue + +new :: Annex Git.Queue.Queue +new = do + q <- Git.Queue.new . annexQueueSize <$> getGitConfig + store q + return q + +store :: Git.Queue.Queue -> Annex () +store q = changeState $ \s -> s { repoqueue = Just q } diff --git a/Annex/Quvi.hs b/Annex/Quvi.hs new file mode 100644 index 0000000000..b0725bae76 --- /dev/null +++ b/Annex/Quvi.hs @@ -0,0 +1,20 @@ +{- quvi options for git-annex + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE Rank2Types #-} + +module Annex.Quvi where + +import Common.Annex +import qualified Annex +import Utility.Quvi +import Utility.Url + +withQuviOptions :: forall a. Query a -> [CommandParam] -> URLString -> Annex a +withQuviOptions a ps url = do + opts <- map Param . annexQuviOptions <$> Annex.getGitConfig + liftIO $ a (ps++opts) url diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs new file mode 100644 index 0000000000..dd93b471c8 --- /dev/null +++ b/Annex/ReplaceFile.hs @@ -0,0 +1,39 @@ +{- git-annex file replacing + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.ReplaceFile where + +import Common.Annex +import Annex.Perms +import Annex.Exception + +{- Replaces a possibly already existing file with a new version, + - atomically, by running an action. + - + - The action is passed a temp file, which it can write to, and once + - done the temp file is moved into place. + - + - The action can throw an IO exception, in which case the temp file + - will be deleted, and the existing file will be preserved. + - + - Throws an IO exception when it was unable to replace the file. + -} +replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex () +replaceFile file a = do + tmpdir <- fromRepo gitAnnexTmpDir + void $ createAnnexDirectory tmpdir + bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do + a tmpfile + liftIO $ catchIO (rename tmpfile file) (fallback tmpfile) + where + setup tmpdir = do + (tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp" + hClose h + return tmpfile + fallback tmpfile _ = do + createDirectoryIfMissing True $ parentDir file + rename tmpfile file diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs new file mode 100644 index 0000000000..8553ee797d --- /dev/null +++ b/Annex/Ssh.hs @@ -0,0 +1,198 @@ +{- git-annex ssh interface, with connection caching + - + - Copyright 2012,2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Ssh ( + sshCachingOptions, + sshCleanup, + sshCacheDir, + sshReadPort, +) where + +import qualified Data.Map as M +import Data.Hash.MD5 +import System.Process (cwd) + +import Common.Annex +import Annex.LockPool +import qualified Build.SysConfig as SysConfig +import qualified Annex +import Config +import Utility.Env +#ifndef mingw32_HOST_OS +import Annex.Perms +#endif + +{- Generates parameters to ssh to a given host (or user@host) on a given + - port, with connection caching. -} +sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam] +sshCachingOptions (host, port) opts = go =<< sshInfo (host, port) + where + go (Nothing, params) = ret params + go (Just socketfile, params) = do + cleanstale + liftIO $ createDirectoryIfMissing True $ parentDir socketfile + lockFile $ socket2lock socketfile + ret params + ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"] + -- If the lock pool is empty, this is the first ssh of this + -- run. There could be stale ssh connections hanging around + -- from a previous git-annex run that was interrupted. + cleanstale = whenM (not . any isLock . M.keys <$> getPool) + sshCleanup + +{- Returns a filename to use for a ssh connection caching socket, and + - parameters to enable ssh connection caching. -} +sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) +sshInfo (host, port) = go =<< sshCacheDir + where + go Nothing = return (Nothing, []) + go (Just dir) = do + r <- liftIO $ bestSocketPath $ dir hostport2socket host port + return $ case r of + Nothing -> (Nothing, []) + Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile) + +{- Given an absolute path to use for a socket file, + - returns whichever is shorter of that or the relative path to the same + - file. + - + - If no path can be constructed that is a valid socket, returns Nothing. -} +bestSocketPath :: FilePath -> IO (Maybe FilePath) +bestSocketPath abssocketfile = do + relsocketfile <- liftIO $ relPathCwdToFile abssocketfile + let socketfile = if length abssocketfile <= length relsocketfile + then abssocketfile + else relsocketfile + return $ if valid_unix_socket_path (socketfile ++ sshgarbage) + then Just socketfile + else Nothing + where + -- ssh appends a 16 char extension to the socket when setting it + -- up, which needs to be taken into account when checking + -- that a valid socket was constructed. + sshgarbage = take (1+16) $ repeat 'X' + +sshConnectionCachingParams :: FilePath -> [CommandParam] +sshConnectionCachingParams socketfile = + [ Param "-S", Param socketfile + , Params "-o ControlMaster=auto -o ControlPersist=yes" + ] + +{- ssh connection caching creates sockets, so will not work on a + - crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use + - a different filesystem. -} +sshCacheDir :: Annex (Maybe FilePath) +sshCacheDir + | SysConfig.sshconnectioncaching = ifM crippledFileSystem + ( maybe (return Nothing) usetmpdir =<< gettmpdir + , ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig) + ( Just <$> fromRepo gitAnnexSshDir + , return Nothing + ) + ) + | otherwise = return Nothing + where + gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR" + usetmpdir tmpdir = liftIO $ catchMaybeIO $ do + createDirectoryIfMissing True tmpdir + return tmpdir + +portParams :: Maybe Integer -> [CommandParam] +portParams Nothing = [] +portParams (Just port) = [Param "-p", Param $ show port] + +{- Stop any unused ssh processes. -} +sshCleanup :: Annex () +sshCleanup = go =<< sshCacheDir + where + go Nothing = noop + go (Just dir) = do + sockets <- liftIO $ filter (not . isLock) + <$> catchDefaultIO [] (dirContents dir) + forM_ sockets cleanup + cleanup socketfile = do +#ifndef mingw32_HOST_OS + -- Drop any shared lock we have, and take an + -- exclusive lock, without blocking. If the lock + -- succeeds, nothing is using this ssh, and it can + -- be stopped. + let lockfile = socket2lock socketfile + unlockFile lockfile + mode <- annexFileMode + fd <- liftIO $ noUmask mode $ + openFd lockfile ReadWrite (Just mode) defaultFileFlags + v <- liftIO $ tryIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> noop + Right _ -> stopssh socketfile + liftIO $ closeFd fd +#else + stopssh socketfile +#endif + stopssh socketfile = do + let (dir, base) = splitFileName socketfile + let params = sshConnectionCachingParams base + -- "ssh -O stop" is noisy on stderr even with -q + void $ liftIO $ catchMaybeIO $ + withQuietOutput createProcessSuccess $ + (proc "ssh" $ toCommand $ + [ Params "-O stop" + ] ++ params ++ [Param "any"]) + { cwd = Just dir } + -- Cannot remove the lock file; other processes may + -- be waiting on our exclusive lock to use it. + +{- This needs to be as short as possible, due to limitations on the length + - of the path to a socket file. At the same time, it needs to be unique + - for each host. + -} +hostport2socket :: String -> Maybe Integer -> FilePath +hostport2socket host Nothing = hostport2socket' host +hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port +hostport2socket' :: String -> FilePath +hostport2socket' s + | length s > lengthofmd5s = md5s (Str s) + | otherwise = s + where + lengthofmd5s = 32 + +socket2lock :: FilePath -> FilePath +socket2lock socket = socket ++ lockExt + +isLock :: FilePath -> Bool +isLock f = lockExt `isSuffixOf` f + +lockExt :: String +lockExt = ".lock" + +{- This is the size of the sun_path component of sockaddr_un, which + - is the limit to the total length of the filename of a unix socket. + - + - On Linux, this is 108. On OSX, 104. TODO: Probe + -} +sizeof_sockaddr_un_sun_path :: Int +sizeof_sockaddr_un_sun_path = 100 + +{- Note that this looks at the true length of the path in bytes, as it will + - appear on disk. -} +valid_unix_socket_path :: FilePath -> Bool +valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path + +{- Parses the SSH port, and returns the other OpenSSH options. If + - several ports are found, the last one takes precedence. -} +sshReadPort :: [String] -> (Maybe Integer, [String]) +sshReadPort params = (port, reverse args) + where + (port,args) = aux (Nothing, []) params + aux (p,ps) [] = (p,ps) + aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest + aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest + | otherwise = aux (p,q:ps) rest + readPort p = fmap fst $ listToMaybe $ reads p diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs new file mode 100644 index 0000000000..039dc0e173 --- /dev/null +++ b/Annex/TaggedPush.hs @@ -0,0 +1,61 @@ +{- git-annex tagged pushes + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.TaggedPush where + +import Common.Annex +import qualified Remote +import qualified Annex.Branch +import qualified Git +import qualified Git.Ref +import qualified Git.Command +import qualified Git.Branch +import Utility.Base64 + +{- Converts a git branch into a branch that is tagged with a UUID, typically + - the UUID of the repo that will be pushing it, and possibly with other + - information. + - + - Pushing to branches on the remote that have our uuid in them is ugly, + - but it reserves those branches for pushing by us, and so our pushes will + - never conflict with other pushes. + - + - To avoid cluttering up the branch display, the branch is put under + - refs/synced/, rather than the usual refs/remotes/ + - + - Both UUIDs and Base64 encoded data are always legal to be used in git + - refs, per git-check-ref-format. + -} +toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch +toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes + [ Just "refs/synced" + , Just $ fromUUID u + , toB64 <$> info + , Just $ show $ Git.Ref.base b + ] + +fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String) +fromTaggedBranch b = case split "/" $ show b of + ("refs":"synced":u:info:_base) -> + Just (toUUID u, fromB64Maybe info) + ("refs":"synced":u:_base) -> + Just (toUUID u, Nothing) + _ -> Nothing + where + +taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool +taggedPush u info branch remote = Git.Command.runBool + [ Param "push" + , Param $ Remote.name remote + {- Using forcePush here is safe because we "own" the tagged branch + - we're pushing; it has no other writers. Ensures it is pushed + - even if it has been rewritten by a transition. -} + , Param $ Git.Branch.forcePush $ refspec Annex.Branch.name + , Param $ refspec branch + ] + where + refspec b = show b ++ ":" ++ show (toTaggedBranch u info b) diff --git a/Annex/UUID.hs b/Annex/UUID.hs new file mode 100644 index 0000000000..4e274503bf --- /dev/null +++ b/Annex/UUID.hs @@ -0,0 +1,96 @@ +{- git-annex uuids + - + - Each git repository used by git-annex has an annex.uuid setting that + - uniquely identifies that repository. + - + - UUIDs of remotes are cached in git config, using keys named + - remote..annex-uuid + - + - Copyright 2010-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.UUID ( + getUUID, + getRepoUUID, + getUncachedUUID, + prepUUID, + genUUID, + genUUIDInNameSpace, + gCryptNameSpace, + removeRepoUUID, + storeUUID, + setUUID, +) where + +import Common.Annex +import qualified Git +import qualified Git.Config +import Config + +import qualified Data.UUID as U +import qualified Data.UUID.V5 as U5 +import System.Random +import Data.Bits.Utils + +configkey :: ConfigKey +configkey = annexConfig "uuid" + +{- Generates a random UUID, that does not include the MAC address. -} +genUUID :: IO UUID +genUUID = UUID . show <$> (randomIO :: IO U.UUID) + +{- Generates a UUID from a given string, using a namespace. + - Given the same namespace, the same string will always result + - in the same UUID. -} +genUUIDInNameSpace :: U.UUID -> String -> UUID +genUUIDInNameSpace namespace = UUID . show . U5.generateNamed namespace . s2w8 + +{- Namespace used for UUIDs derived from git-remote-gcrypt ids. -} +gCryptNameSpace :: U.UUID +gCryptNameSpace = U5.generateNamed U5.namespaceURL $ + s2w8 "http://git-annex.branchable.com/design/gcrypt/" + +{- Get current repository's UUID. -} +getUUID :: Annex UUID +getUUID = getRepoUUID =<< gitRepo + +{- Looks up a repo's UUID, caching it in .git/config if it's not already. -} +getRepoUUID :: Git.Repo -> Annex UUID +getRepoUUID r = do + c <- toUUID <$> getConfig cachekey "" + let u = getUncachedUUID r + + if c /= u && u /= NoUUID + then do + updatecache u + return u + else return c + where + updatecache u = do + g <- gitRepo + when (g /= r) $ storeUUID cachekey u + cachekey = remoteConfig r "uuid" + +removeRepoUUID :: Annex () +removeRepoUUID = unsetConfig configkey + +getUncachedUUID :: Git.Repo -> UUID +getUncachedUUID = toUUID . Git.Config.get key "" + where + (ConfigKey key) = configkey + +{- Make sure that the repo has an annex.uuid setting. -} +prepUUID :: Annex () +prepUUID = whenM ((==) NoUUID <$> getUUID) $ + storeUUID configkey =<< liftIO genUUID + +storeUUID :: ConfigKey -> UUID -> Annex () +storeUUID configfield = setConfig configfield . fromUUID + +{- Only sets the configkey in the Repo; does not change .git/config -} +setUUID :: Git.Repo -> UUID -> IO Git.Repo +setUUID r u = do + let s = show configkey ++ "=" ++ fromUUID u + Git.Config.store s r diff --git a/Annex/Url.hs b/Annex/Url.hs new file mode 100644 index 0000000000..0401ffe07b --- /dev/null +++ b/Annex/Url.hs @@ -0,0 +1,27 @@ +{- Url downloading, with git-annex user agent. + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Url ( + module U, + withUserAgent, + getUserAgent, +) where + +import Common.Annex +import qualified Annex +import Utility.Url as U +import qualified Build.SysConfig as SysConfig + +defaultUserAgent :: U.UserAgent +defaultUserAgent = "git-annex/" ++ SysConfig.packageversion + +getUserAgent :: Annex (Maybe U.UserAgent) +getUserAgent = Annex.getState $ + Just . fromMaybe defaultUserAgent . Annex.useragent + +withUserAgent :: (Maybe U.UserAgent -> IO a) -> Annex a +withUserAgent a = liftIO . a =<< getUserAgent diff --git a/Annex/Version.hs b/Annex/Version.hs new file mode 100644 index 0000000000..05b3f02273 --- /dev/null +++ b/Annex/Version.hs @@ -0,0 +1,53 @@ +{- git-annex repository versioning + - + - Copyright 2010,2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Version where + +import Common.Annex +import Config +import qualified Annex + +type Version = String + +defaultVersion :: Version +defaultVersion = "3" + +directModeVersion :: Version +directModeVersion = "4" + +supportedVersions :: [Version] +supportedVersions = [defaultVersion, directModeVersion] + +upgradableVersions :: [Version] +#ifndef mingw32_HOST_OS +upgradableVersions = ["0", "1", "2"] +#else +upgradableVersions = ["2"] +#endif + +versionField :: ConfigKey +versionField = annexConfig "version" + +getVersion :: Annex (Maybe Version) +getVersion = annexVersion <$> Annex.getGitConfig + +setVersion :: Version -> Annex () +setVersion = setConfig versionField + +removeVersion :: Annex () +removeVersion = unsetConfig versionField + +checkVersion :: Version -> Annex () +checkVersion v + | v `elem` supportedVersions = noop + | v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade" + | otherwise = err "Upgrade git-annex." + where + err msg = error $ "Repository version " ++ v ++ + " is not supported. " ++ msg diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs new file mode 100644 index 0000000000..04dcc1c1ca --- /dev/null +++ b/Annex/Wanted.hs @@ -0,0 +1,32 @@ +{- git-annex checking whether content is wanted + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Wanted where + +import Common.Annex +import Logs.PreferredContent +import Annex.UUID + +import qualified Data.Set as S + +{- Check if a file is preferred content for the local repository. -} +wantGet :: Bool -> AssociatedFile -> Annex Bool +wantGet def Nothing = return def +wantGet def (Just file) = isPreferredContent Nothing S.empty file def + +{- Check if a file is preferred content for a remote. -} +wantSend :: Bool -> AssociatedFile -> UUID -> Annex Bool +wantSend def Nothing _ = return def +wantSend def (Just file) to = isPreferredContent (Just to) S.empty file def + +{- Check if a file can be dropped, maybe from a remote. + - Don't drop files that are preferred content. -} +wantDrop :: Bool -> Maybe UUID -> AssociatedFile -> Annex Bool +wantDrop def _ Nothing = return $ not def +wantDrop def from (Just file) = do + u <- maybe getUUID (return . id) from + not <$> isPreferredContent (Just u) (S.singleton u) file def diff --git a/Assistant.hs b/Assistant.hs new file mode 100644 index 0000000000..781089e060 --- /dev/null +++ b/Assistant.hs @@ -0,0 +1,155 @@ +{- git-annex assistant daemon + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant where + +import qualified Annex +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.NamedThread +import Assistant.Types.ThreadedMonad +import Assistant.Threads.DaemonStatus +import Assistant.Threads.Watcher +import Assistant.Threads.Committer +import Assistant.Threads.Pusher +import Assistant.Threads.Merger +import Assistant.Threads.TransferWatcher +import Assistant.Threads.Transferrer +import Assistant.Threads.SanityChecker +import Assistant.Threads.Cronner +import Assistant.Threads.ProblemFixer +#ifdef WITH_CLIBS +import Assistant.Threads.MountWatcher +#endif +import Assistant.Threads.NetWatcher +import Assistant.Threads.TransferScanner +import Assistant.Threads.TransferPoller +import Assistant.Threads.ConfigMonitor +import Assistant.Threads.Glacier +#ifdef WITH_WEBAPP +import Assistant.WebApp +import Assistant.Threads.WebApp +#ifdef WITH_PAIRING +import Assistant.Threads.PairListener +#endif +#ifdef WITH_XMPP +import Assistant.Threads.XMPPClient +import Assistant.Threads.XMPPPusher +#endif +#else +#warning Building without the webapp. You probably need to install Yesod.. +import Assistant.Types.UrlRenderer +#endif +import qualified Utility.Daemon +import Utility.LogFile +import Utility.ThreadScheduler +import Utility.HumanTime +import qualified Build.SysConfig as SysConfig + +import System.Log.Logger +import Network.Socket (HostName) + +stopDaemon :: Annex () +stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile + +{- Starts the daemon. If the daemon is run in the foreground, once it's + - running, can start the browser. + - + - startbrowser is passed the url and html shim file, as well as the original + - stdout and stderr descriptors. -} +startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () +startDaemon assistant foreground startdelay listenhost startbrowser = do + Annex.changeState $ \s -> s { Annex.daemon = True } + pidfile <- fromRepo gitAnnexPidFile + logfile <- fromRepo gitAnnexLogFile + logfd <- liftIO $ openLog logfile + if foreground + then do + origout <- liftIO $ catchMaybeIO $ + fdToHandle =<< dup stdOutput + origerr <- liftIO $ catchMaybeIO $ + fdToHandle =<< dup stdError + let undaemonize a = do + debugM desc $ "logging to " ++ logfile + Utility.Daemon.lockPidFile pidfile + Utility.LogFile.redirLog logfd + a + start undaemonize $ + case startbrowser of + Nothing -> Nothing + Just a -> Just $ a origout origerr + else + start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing + where + desc + | assistant = "assistant" + | otherwise = "watch" + start daemonize webappwaiter = withThreadState $ \st -> do + checkCanWatch + dstatus <- startDaemonStatus + logfile <- fromRepo gitAnnexLogFile + liftIO $ debugM desc $ "logging to " ++ logfile + liftIO $ daemonize $ + flip runAssistant (go webappwaiter) + =<< newAssistantData st dstatus + + +#ifdef WITH_WEBAPP + go webappwaiter = do + d <- getAssistant id +#else + go _webappwaiter = do +#endif + notice ["starting", desc, "version", SysConfig.packageversion] + urlrenderer <- liftIO newUrlRenderer + mapM_ (startthread urlrenderer) + [ watch $ commitThread +#ifdef WITH_WEBAPP + , assist $ webAppThread d urlrenderer False listenhost Nothing webappwaiter +#ifdef WITH_PAIRING + , assist $ pairListenerThread urlrenderer +#endif +#ifdef WITH_XMPP + , assist $ xmppClientThread urlrenderer + , assist $ xmppSendPackThread urlrenderer + , assist $ xmppReceivePackThread urlrenderer +#endif +#endif + , assist $ pushThread + , assist $ pushRetryThread + , assist $ mergeThread + , assist $ transferWatcherThread + , assist $ transferPollerThread + , assist $ transfererThread + , assist $ daemonStatusThread + , assist $ sanityCheckerDailyThread + , assist $ sanityCheckerHourlyThread + , assist $ problemFixerThread urlrenderer +#ifdef WITH_CLIBS + , assist $ mountWatcherThread urlrenderer +#endif + , assist $ netWatcherThread + , assist $ netWatcherFallbackThread + , assist $ transferScannerThread urlrenderer + , assist $ cronnerThread urlrenderer + , assist $ configMonitorThread + , assist $ glacierThread + , watch $ watchThread + -- must come last so that all threads that wait + -- on it have already started waiting + , watch $ sanityCheckerStartupThread startdelay + ] + + liftIO waitForTermination + + watch a = (True, a) + assist a = (False, a) + startthread urlrenderer (watcher, t) + | watcher || assistant = startNamedThread urlrenderer t + | otherwise = noop diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs new file mode 100644 index 0000000000..8bdedaa3ef --- /dev/null +++ b/Assistant/Alert.hs @@ -0,0 +1,388 @@ +{- git-annex assistant alerts + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, CPP #-} + +module Assistant.Alert where + +import Common.Annex +import Assistant.Types.Alert +import Assistant.Alert.Utility +import qualified Remote +import Utility.Tense +import Logs.Transfer + +import Data.String +import qualified Data.Text as T +import qualified Control.Exception as E + +#ifdef WITH_WEBAPP +import Assistant.DaemonStatus +import Assistant.WebApp.Types +import Assistant.WebApp (renderUrl) +import Yesod +#endif +import Assistant.Monad +import Assistant.Types.UrlRenderer + +{- Makes a button for an alert that opens a Route. + - + - If autoclose is set, the button will close the alert it's + - attached to when clicked. -} +#ifdef WITH_WEBAPP +mkAlertButton :: Bool -> T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton +mkAlertButton autoclose label urlrenderer route = do + close <- asIO1 removeAlert + url <- liftIO $ renderUrl urlrenderer route [] + return $ AlertButton + { buttonLabel = label + , buttonUrl = url + , buttonAction = if autoclose then Just close else Nothing + } +#endif + +renderData :: Alert -> TenseText +renderData = tenseWords . alertData + +baseActivityAlert :: Alert +baseActivityAlert = Alert + { alertClass = Activity + , alertHeader = Nothing + , alertMessageRender = renderData + , alertData = [] + , alertCounter = 0 + , alertBlockDisplay = False + , alertClosable = False + , alertPriority = Medium + , alertIcon = Just ActivityIcon + , alertCombiner = Nothing + , alertName = Nothing + , alertButton = Nothing + } + +warningAlert :: String -> String -> Alert +warningAlert name msg = Alert + { alertClass = Warning + , alertHeader = Just $ tenseWords ["warning"] + , alertMessageRender = renderData + , alertData = [UnTensed $ T.pack msg] + , alertCounter = 0 + , alertBlockDisplay = True + , alertClosable = True + , alertPriority = High + , alertIcon = Just ErrorIcon + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertName = Just $ WarningAlert name + , alertButton = Nothing + } + +errorAlert :: String -> AlertButton -> Alert +errorAlert msg button = Alert + { alertClass = Error + , alertHeader = Nothing + , alertMessageRender = renderData + , alertData = [UnTensed $ T.pack msg] + , alertCounter = 0 + , alertBlockDisplay = True + , alertClosable = True + , alertPriority = Pinned + , alertIcon = Just ErrorIcon + , alertCombiner = Nothing + , alertName = Nothing + , alertButton = Just button + } + +activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert +activityAlert header dat = baseActivityAlert + { alertHeader = header + , alertData = dat + } + +startupScanAlert :: Alert +startupScanAlert = activityAlert Nothing + [Tensed "Performing" "Performed", "startup scan"] + +{- Displayed when a shutdown is occurring, so will be seen after shutdown + - has happened. -} +shutdownAlert :: Alert +shutdownAlert = warningAlert "shutdown" "git-annex has been shut down" + +commitAlert :: Alert +commitAlert = activityAlert Nothing + [Tensed "Committing" "Committed", "changes to git"] + +showRemotes :: [Remote] -> TenseChunk +showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name) + +syncAlert :: [Remote] -> Alert +syncAlert rs = baseActivityAlert + { alertName = Just SyncAlert + , alertHeader = Just $ tenseWords + [Tensed "Syncing" "Synced", "with", showRemotes rs] + , alertPriority = Low + , alertIcon = Just SyncIcon + } + +syncResultAlert :: [Remote] -> [Remote] -> Alert +syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $ + baseActivityAlert + { alertName = Just SyncAlert + , alertHeader = Just $ tenseWords msg + } + where + msg + | null succeeded = ["Failed to sync with", showRemotes failed] + | null failed = ["Synced with", showRemotes succeeded] + | otherwise = + [ "Synced with", showRemotes succeeded + , "but not with", showRemotes failed + ] + +sanityCheckAlert :: Alert +sanityCheckAlert = activityAlert + (Just $ tenseWords [Tensed "Running" "Ran", "daily sanity check"]) + ["to make sure everything is ok."] + +sanityCheckFixAlert :: String -> Alert +sanityCheckFixAlert msg = Alert + { alertClass = Warning + , alertHeader = Just $ tenseWords ["Fixed a problem"] + , alertMessageRender = render + , alertData = [UnTensed $ T.pack msg] + , alertCounter = 0 + , alertBlockDisplay = True + , alertPriority = High + , alertClosable = True + , alertIcon = Just ErrorIcon + , alertName = Just SanityCheckFixAlert + , alertCombiner = Just $ dataCombiner (++) + , alertButton = Nothing + } + where + render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot] + alerthead = "The daily sanity check found and fixed a problem:" + alertfoot = "If these problems persist, consider filing a bug report." + +fsckingAlert :: AlertButton -> Maybe Remote -> Alert +fsckingAlert button mr = baseActivityAlert + { alertData = case mr of + Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ] + Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"] + , alertButton = Just button + } + +showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a +showFscking urlrenderer mr a = do +#ifdef WITH_WEBAPP + button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR + r <- alertDuring (fsckingAlert button mr) $ + liftIO a +#else + r <- liftIO a +#endif + either (liftIO . E.throwIO) return r + +notFsckedNudge :: UrlRenderer -> Maybe Remote -> Assistant () +#ifdef WITH_WEBAPP +notFsckedNudge urlrenderer mr = do + button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR + void $ addAlert (notFsckedAlert mr button) +#else +notFsckedNudge _ _ = noop +#endif + +notFsckedAlert :: Maybe Remote -> AlertButton -> Alert +notFsckedAlert mr button = Alert + { alertHeader = Just $ fromString $ concat + [ "You should enable consistency checking to protect your data" + , maybe "" (\r -> " in " ++ Remote.name r) mr + , "." + ] + , alertIcon = Just InfoIcon + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just NotFsckedAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + +brokenRepositoryAlert :: AlertButton -> Alert +brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!" + +repairingAlert :: String -> Alert +repairingAlert repodesc = activityAlert Nothing + [ Tensed "Attempting to repair" "Repaired" + , UnTensed $ T.pack repodesc + ] + +pairingAlert :: AlertButton -> Alert +pairingAlert button = baseActivityAlert + { alertData = [ UnTensed "Pairing in progress" ] + , alertPriority = High + , alertButton = Just button + } + +pairRequestReceivedAlert :: String -> AlertButton -> Alert +pairRequestReceivedAlert who button = Alert + { alertClass = Message + , alertHeader = Nothing + , alertMessageRender = renderData + , alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."] + , alertCounter = 0 + , alertBlockDisplay = False + , alertPriority = High + , alertClosable = True + , alertIcon = Just InfoIcon + , alertName = Just $ PairAlert who + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertButton = Just button + } + +pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert +pairRequestAcknowledgedAlert who button = baseActivityAlert + { alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"] + , alertPriority = High + , alertName = Just $ PairAlert who + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertButton = button + } + +xmppNeededAlert :: AlertButton -> Alert +xmppNeededAlert button = Alert + { alertHeader = Just "Share with friends, and keep your devices in sync across the cloud." + , alertIcon = Just TheCloud + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just $ XMPPNeededAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + +cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert +cloudRepoNeededAlert friendname button = Alert + { alertHeader = Just $ fromString $ unwords + [ "Unable to download files from" + , (fromMaybe "your other devices" friendname) ++ "." + ] + , alertIcon = Just ErrorIcon + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just $ CloudRepoNeededAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + +remoteRemovalAlert :: String -> AlertButton -> Alert +remoteRemovalAlert desc button = Alert + { alertHeader = Just $ fromString $ + "The repository \"" ++ desc ++ + "\" has been emptied, and can now be removed." + , alertIcon = Just InfoIcon + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just $ RemoteRemovalAlert desc + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + +{- Show a message that relates to a list of files. + - + - The most recent several files are shown, and a count of any others. -} +fileAlert :: TenseChunk -> [FilePath] -> Alert +fileAlert msg files = (activityAlert Nothing shortfiles) + { alertName = Just $ FileAlert msg + , alertMessageRender = renderer + , alertCounter = counter + , alertCombiner = Just $ fullCombiner combiner + } + where + maxfilesshown = 10 + + (somefiles, counter) = splitcounter (dedupadjacent files) + shortfiles = map (fromString . shortFile . takeFileName) somefiles + + renderer alert = tenseWords $ msg : alertData alert ++ showcounter + where + showcounter = case alertCounter alert of + 0 -> [] + _ -> [fromString $ "and " ++ show (alertCounter alert) ++ " other files"] + + dedupadjacent (x:y:rest) + | x == y = dedupadjacent (y:rest) + | otherwise = x : dedupadjacent (y:rest) + dedupadjacent (x:[]) = [x] + dedupadjacent [] = [] + + {- Note that this ensures the counter is never 1; no need to say + - "1 file" when the filename could be shown. -} + splitcounter l + | length l <= maxfilesshown = (l, 0) + | otherwise = + let (keep, rest) = splitAt (maxfilesshown - 1) l + in (keep, length rest) + + combiner new old = + let (fs, n) = splitcounter $ + dedupadjacent $ alertData new ++ alertData old + cnt = n + alertCounter new + alertCounter old + in old + { alertData = fs + , alertCounter = cnt + } + +addFileAlert :: [FilePath] -> Alert +addFileAlert = fileAlert (Tensed "Adding" "Added") + +{- This is only used as a success alert after a transfer, not during it. -} +transferFileAlert :: Direction -> Bool -> FilePath -> Alert +transferFileAlert direction True file + | direction == Upload = fileAlert "Uploaded" [file] + | otherwise = fileAlert "Downloaded" [file] +transferFileAlert direction False file + | direction == Upload = fileAlert "Upload failed" [file] + | otherwise = fileAlert "Download failed" [file] + +dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner +dataCombiner combiner = fullCombiner $ + \new old -> old { alertData = alertData new `combiner` alertData old } + +fullCombiner :: (Alert -> Alert -> Alert) -> AlertCombiner +fullCombiner combiner new old + | alertClass new /= alertClass old = Nothing + | alertName new == alertName old = + Just $! new `combiner` old + | otherwise = Nothing + +shortFile :: FilePath -> String +shortFile f + | len < maxlen = f + | otherwise = take half f ++ ".." ++ drop (len - half) f + where + len = length f + maxlen = 20 + half = (maxlen - 2) `div` 2 + diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs new file mode 100644 index 0000000000..af52a4235d --- /dev/null +++ b/Assistant/Alert/Utility.hs @@ -0,0 +1,130 @@ +{- git-annex assistant alert utilities + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Alert.Utility where + +import Common.Annex +import Assistant.Types.Alert +import Utility.Tense + +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Map as M + +{- 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 + - user with a ton of alerts. -} +displayAlerts :: Int +displayAlerts = 6 + +{- This is not a hard maximum, but there's no point in keeping a great + - many filler alerts in an AlertMap, so when there's more than this many, + - they start being pruned, down toward displayAlerts. -} +maxAlerts :: Int +maxAlerts = displayAlerts * 2 + +type AlertPair = (AlertId, Alert) + +{- The desired order is the reverse of: + - + - - Pinned alerts + - - High priority alerts, newest first + - - Medium priority Activity, newest first (mostly used for Activity) + - - Low priority alerts, newest first + - - Filler priorty alerts, newest first + - - Ties are broken by the AlertClass, with Errors etc coming first. + -} +compareAlertPairs :: AlertPair -> AlertPair -> Ordering +compareAlertPairs + (aid, Alert { alertClass = aclass, alertPriority = aprio }) + (bid, Alert { alertClass = bclass, alertPriority = bprio }) + = compare aprio bprio + `thenOrd` compare aid bid + `thenOrd` compare aclass bclass + +sortAlertPairs :: [AlertPair] -> [AlertPair] +sortAlertPairs = sortBy compareAlertPairs + +{- Renders an alert's header for display, if it has one. -} +renderAlertHeader :: Alert -> Maybe Text +renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert + +{- Renders an alert's message for display. -} +renderAlertMessage :: Alert -> Text +renderAlertMessage alert = renderTense (alertTense alert) $ + (alertMessageRender alert) alert + +showAlert :: Alert -> String +showAlert alert = T.unpack $ T.unwords $ catMaybes + [ renderAlertHeader alert + , Just $ renderAlertMessage alert + ] + +alertTense :: Alert -> Tense +alertTense alert + | alertClass alert == Activity = Present + | otherwise = Past + +{- Checks if two alerts display the same. -} +effectivelySameAlert :: Alert -> Alert -> Bool +effectivelySameAlert x y = all id + [ alertClass x == alertClass y + , alertHeader x == alertHeader y + , alertData x == alertData y + , alertBlockDisplay x == alertBlockDisplay y + , alertClosable x == alertClosable y + , alertPriority x == alertPriority y + ] + +makeAlertFiller :: Bool -> Alert -> Alert +makeAlertFiller success alert + | isFiller alert = alert + | otherwise = alert + { alertClass = if c == Activity then c' else c + , alertPriority = Filler + , alertClosable = True + , alertButton = Nothing + , alertIcon = Just $ if success then SuccessIcon else ErrorIcon + } + where + c = alertClass alert + c' + | success = Success + | otherwise = Error + +isFiller :: Alert -> Bool +isFiller alert = alertPriority alert == Filler + +{- Updates the Alertmap, adding or updating an alert. + - + - Any old filler that looks the same as the alert is removed. + - + - Or, if the alert has an alertCombiner that combines it with + - an old alert, the old alert is replaced with the result, and the + - alert is removed. + - + - Old filler alerts are pruned once maxAlerts is reached. + -} +mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap +mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al) + where + pruneSame k al' = k == i || not (effectivelySameAlert al al') + pruneBloat m' + | bloat > 0 = M.fromList $ pruneold $ M.toList m' + | otherwise = m' + where + bloat = M.size m' - maxAlerts + pruneold 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 + updateCombine combiner = + let combined = M.mapMaybe (combiner al) m + in if M.null combined + then updatePrune + else M.delete i $ M.union combined m diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs new file mode 100644 index 0000000000..c9354544a5 --- /dev/null +++ b/Assistant/BranchChange.hs @@ -0,0 +1,19 @@ +{- git-annex assistant git-annex branch change tracking + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.BranchChange where + +import Assistant.Common +import Assistant.Types.BranchChange + +import Control.Concurrent.MSampleVar + +branchChanged :: Assistant () +branchChanged = flip writeSV () <<~ (fromBranchChangeHandle . branchChangeHandle) + +waitBranchChange :: Assistant () +waitBranchChange = readSV <<~ (fromBranchChangeHandle . branchChangeHandle) diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs new file mode 100644 index 0000000000..2ecd2036ce --- /dev/null +++ b/Assistant/Changes.hs @@ -0,0 +1,47 @@ +{- git-annex assistant change tracking + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Changes where + +import Assistant.Common +import Assistant.Types.Changes +import Utility.TList + +import Data.Time.Clock +import Control.Concurrent.STM + +{- Handlers call this when they made a change that needs to get committed. -} +madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change) +madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t) + +noChange :: Assistant (Maybe Change) +noChange = return Nothing + +{- Indicates an add needs to be done, but has not started yet. -} +pendingAddChange :: FilePath -> Assistant (Maybe Change) +pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f) + +{- Gets all unhandled changes. + - Blocks until at least one change is made. -} +getChanges :: Assistant [Change] +getChanges = (atomically . getTList) <<~ changePool + +{- Gets all unhandled changes, without blocking. -} +getAnyChanges :: Assistant [Change] +getAnyChanges = (atomically . takeTList) <<~ changePool + +{- Puts unhandled changes back into the pool. + - Note: Original order is not preserved. -} +refillChanges :: [Change] -> Assistant () +refillChanges cs = (atomically . flip appendTList cs) <<~ changePool + +{- Records a change to the pool. -} +recordChange :: Change -> Assistant () +recordChange c = (atomically . flip snocTList c) <<~ changePool + +recordChanges :: [Change] -> Assistant () +recordChanges = refillChanges diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs new file mode 100644 index 0000000000..7d1d3780fe --- /dev/null +++ b/Assistant/Commits.hs @@ -0,0 +1,23 @@ +{- git-annex assistant commit tracking + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Commits where + +import Assistant.Common +import Assistant.Types.Commits +import Utility.TList + +import Control.Concurrent.STM + +{- Gets all unhandled commits. + - Blocks until at least one commit is made. -} +getCommits :: Assistant [Commit] +getCommits = (atomically . getTList) <<~ commitChan + +{- Records a commit in the channel. -} +recordCommit :: Assistant () +recordCommit = (atomically . flip consTList Commit) <<~ commitChan diff --git a/Assistant/Common.hs b/Assistant/Common.hs new file mode 100644 index 0000000000..f9719422d9 --- /dev/null +++ b/Assistant/Common.hs @@ -0,0 +1,14 @@ +{- Common infrastructure for the git-annex assistant. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Common (module X) where + +import Common.Annex as X +import Assistant.Monad as X +import Assistant.Types.DaemonStatus as X +import Assistant.Types.NamedThread as X +import Assistant.Types.Alert as X diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs new file mode 100644 index 0000000000..7268bbbfb4 --- /dev/null +++ b/Assistant/DaemonStatus.hs @@ -0,0 +1,262 @@ +{- git-annex assistant daemon status + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.DaemonStatus where + +import Assistant.Common +import Assistant.Alert.Utility +import Utility.Tmp +import Assistant.Types.NetMessager +import Utility.NotificationBroadcaster +import Logs.Transfer +import Logs.Trust +import qualified Remote +import qualified Types.Remote as Remote +import qualified Git + +import Control.Concurrent.STM +import System.Posix.Types +import Data.Time.Clock.POSIX +import Data.Time +import System.Locale +import qualified Data.Map as M +import qualified Data.Text as T + +getDaemonStatus :: Assistant DaemonStatus +getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle + +modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant () +modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ()) + +modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b +modifyDaemonStatus a = do + dstatus <- getAssistant daemonStatusHandle + liftIO $ do + (s, b) <- atomically $ do + r@(s, _) <- a <$> takeTMVar dstatus + putTMVar dstatus s + return r + sendNotification $ changeNotifier s + return b + +{- Returns a function that updates the lists of syncable remotes + - and other associated information. -} +calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus) +calcSyncRemotes = do + rs <- filter (remoteAnnexSync . Remote.gitconfig) . + concat . Remote.byCost <$> Remote.remoteList + alive <- trustExclude DeadTrusted (map Remote.uuid rs) + let good r = Remote.uuid r `elem` alive + let syncable = filter good rs + let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $ + filter (not . isXMPPRemote) syncable + + return $ \dstatus -> dstatus + { syncRemotes = syncable + , syncGitRemotes = filter Remote.syncableRemote syncable + , syncDataRemotes = syncdata + , syncingToCloudRemote = any iscloud syncdata + } + where + iscloud r = not (Remote.readonly r) && Remote.globallyAvailable r + +{- Updates the syncRemotes list from the list of all remotes in Annex state. -} +updateSyncRemotes :: Assistant () +updateSyncRemotes = do + modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes + status <- getDaemonStatus + liftIO $ sendNotification $ syncRemotesNotifier status + + when (syncingToCloudRemote status) $ + updateAlertMap $ + M.filter $ \alert -> + alertName alert /= Just CloudRepoNeededAlert + +updateScheduleLog :: Assistant () +updateScheduleLog = + liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus + +{- Load any previous daemon status file, and store it in a MVar for this + - process to use as its DaemonStatus. Also gets current transfer status. -} +startDaemonStatus :: Annex DaemonStatusHandle +startDaemonStatus = do + file <- fromRepo gitAnnexDaemonStatusFile + status <- liftIO $ + flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus + transfers <- M.fromList <$> getTransfers + addsync <- calcSyncRemotes + liftIO $ atomically $ newTMVar $ addsync $ status + { scanComplete = False + , sanityCheckRunning = False + , currentTransfers = transfers + } + +{- Don't just dump out the structure, because it will change over time, + - and parts of it are not relevant. -} +writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO () +writeDaemonStatusFile file status = + viaTmp writeFile file =<< serialized <$> getPOSIXTime + where + serialized now = unlines + [ "lastRunning:" ++ show now + , "scanComplete:" ++ show (scanComplete status) + , "sanityCheckRunning:" ++ show (sanityCheckRunning status) + , "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status) + ] + +readDaemonStatusFile :: FilePath -> IO DaemonStatus +readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file + where + parse status = foldr parseline status . lines + parseline line status + | key == "lastRunning" = parseval readtime $ \v -> + status { lastRunning = Just v } + | key == "scanComplete" = parseval readish $ \v -> + status { scanComplete = v } + | key == "sanityCheckRunning" = parseval readish $ \v -> + status { sanityCheckRunning = v } + | key == "lastSanityCheck" = parseval readtime $ \v -> + status { lastSanityCheck = Just v } + | otherwise = status -- unparsable line + where + (key, value) = separate (== ':') line + parseval parser a = maybe status a (parser value) + readtime s = do + d <- parseTime defaultTimeLocale "%s%Qs" s + Just $ utcTimeToPOSIXSeconds d + +{- Checks if a time stamp was made after the daemon was lastRunning. + - + - Some slop is built in; this really checks if the time stamp was made + - at least ten minutes after the daemon was lastRunning. This is to + - ensure the daemon shut down cleanly, and deal with minor clock skew. + - + - If the daemon has never ran before, this always returns False. + -} +afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool +afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status) + where + t = realToFrac (timestamp + slop) :: POSIXTime + slop = fromIntegral tenMinutes + +tenMinutes :: Int +tenMinutes = 10 * 60 + +{- Mutates the transfer map. Runs in STM so that the transfer map can + - be modified in the same transaction that modifies the transfer queue. + - Note that this does not send a notification of the change; that's left + - to the caller. -} +adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM () +adjustTransfersSTM dstatus a = do + s <- takeTMVar dstatus + putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) } + +{- Checks if a transfer is currently running. -} +checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool +checkRunningTransferSTM dstatus t = M.member t . currentTransfers + <$> readTMVar dstatus + +{- Alters a transfer's info, if the transfer is in the map. -} +alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant () +alterTransferInfo t a = updateTransferInfo' $ M.adjust a t + +{- Updates a transfer's info. Adds the transfer to the map if necessary, + - or if already present, updates it while preserving the old transferTid, + - transferPaused, and bytesComplete values, which are not written to disk. -} +updateTransferInfo :: Transfer -> TransferInfo -> Assistant () +updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info + where + merge new old = new + { transferTid = maybe (transferTid new) Just (transferTid old) + , transferPaused = transferPaused new || transferPaused old + , bytesComplete = maybe (bytesComplete new) Just (bytesComplete old) + } + +updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant () +updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update + where + update s = s { currentTransfers = a (currentTransfers s) } + +{- Removes a transfer from the map, and returns its info. -} +removeTransfer :: Transfer -> Assistant (Maybe TransferInfo) +removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove + where + remove s = + let (info, ts) = M.updateLookupWithKey + (\_k _v -> Nothing) + t (currentTransfers s) + in (s { currentTransfers = ts }, info) + +{- Send a notification when a transfer is changed. -} +notifyTransfer :: Assistant () +notifyTransfer = do + dstatus <- getAssistant daemonStatusHandle + liftIO $ sendNotification + =<< transferNotifier <$> atomically (readTMVar dstatus) + +{- Send a notification when alerts are changed. -} +notifyAlert :: Assistant () +notifyAlert = do + dstatus <- getAssistant daemonStatusHandle + liftIO $ sendNotification + =<< alertNotifier <$> atomically (readTMVar dstatus) + +{- Returns the alert's identifier, which can be used to remove it. -} +addAlert :: Alert -> Assistant AlertId +addAlert alert = do + notice [showAlert alert] + notifyAlert `after` modifyDaemonStatus add + where + add s = (s { lastAlertId = i, alertMap = m }, i) + where + i = nextAlertId $ lastAlertId s + m = mergeAlert i alert (alertMap s) + +removeAlert :: AlertId -> Assistant () +removeAlert i = updateAlert i (const Nothing) + +updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant () +updateAlert i a = updateAlertMap $ \m -> M.update a i m + +updateAlertMap :: (AlertMap -> AlertMap) -> Assistant () +updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update + where + update s = s { alertMap = a (alertMap s) } + +{- Displays an alert while performing an activity that returns True on + - success. + - + - The alert is left visible afterwards, as filler. + - Old filler is pruned, to prevent the map growing too large. -} +alertWhile :: Alert -> Assistant Bool -> Assistant Bool +alertWhile alert a = alertWhile' alert $ do + r <- a + return (r, r) + +{- Like alertWhile, but allows the activity to return a value too. -} +alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a +alertWhile' alert a = do + let alert' = alert { alertClass = Activity } + i <- addAlert alert' + (ok, r) <- a + updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert' + return r + +{- Displays an alert while performing an activity, then removes it. -} +alertDuring :: Alert -> Assistant a -> Assistant a +alertDuring alert a = do + i <- addAlert $ alert { alertClass = Activity } + removeAlert i `after` a + +{- Remotes using the XMPP transport have urls like xmpp::user@host -} +isXMPPRemote :: Remote -> Bool +isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r + where + r = Remote.repo remote + +getXMPPClientID :: Remote -> ClientID +getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r)) diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs new file mode 100644 index 0000000000..cc05786e40 --- /dev/null +++ b/Assistant/DeleteRemote.hs @@ -0,0 +1,89 @@ +{- git-annex assistant remote deletion utilities + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.DeleteRemote where + +import Assistant.Common +import Assistant.Types.UrlRenderer +import Assistant.TransferQueue +import Logs.Transfer +import Logs.Location +import Assistant.DaemonStatus +import qualified Remote +import Remote.List +import qualified Git.Remote +import Logs.Trust +import qualified Annex + +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import Assistant.Alert +import qualified Data.Text as T +#endif + +{- Removes a remote (but leave the repository as-is), and returns the old + - Remote data. -} +disableRemote :: UUID -> Assistant Remote +disableRemote uuid = do + remote <- fromMaybe (error "unknown remote") + <$> liftAnnex (Remote.remoteFromUUID uuid) + liftAnnex $ do + inRepo $ Git.Remote.remove (Remote.name remote) + void $ remoteListRefresh + updateSyncRemotes + return remote + +{- Removes a remote, marking it dead .-} +removeRemote :: UUID -> Assistant Remote +removeRemote uuid = do + liftAnnex $ trustSet uuid DeadTrusted + disableRemote uuid + +{- Called when a Remote is probably empty, to remove it. + - + - This does one last check for any objects remaining in the Remote, + - and if there are any, queues Downloads of them, and defers removing + - the remote for later. This is to catch any objects not referred to + - in keys in the current branch. + -} +removableRemote :: UrlRenderer -> UUID -> Assistant () +removableRemote urlrenderer uuid = do + keys <- getkeys + if null keys + then finishRemovingRemote urlrenderer uuid + else do + r <- fromMaybe (error "unknown remote") + <$> liftAnnex (Remote.remoteFromUUID uuid) + mapM_ (queueremaining r) keys + where + 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 + - the Annex monad while doing it, so other threads continue to + - run. -} + getkeys = do + a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid + liftIO a + +{- With the webapp, this asks the user to click on a button to finish + - removing the remote. + - + - Without the webapp, just do the removal now. + -} +finishRemovingRemote :: UrlRenderer -> UUID -> Assistant () +#ifdef WITH_WEBAPP +finishRemovingRemote urlrenderer uuid = do + desc <- liftAnnex $ Remote.prettyUUID uuid + button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $ + FinishDeleteRepositoryR uuid + void $ addAlert $ remoteRemovalAlert desc button +#else +finishRemovingRemote _ uuid = void $ removeRemote uuid +#endif diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs new file mode 100644 index 0000000000..d677a69c8b --- /dev/null +++ b/Assistant/Drop.hs @@ -0,0 +1,112 @@ +{- git-annex assistant dropping of unwanted content + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Drop where + +import Assistant.Common +import Assistant.DaemonStatus +import Logs.Location +import Logs.Trust +import Types.Remote (uuid) +import qualified Remote +import qualified Command.Drop +import Command +import Annex.Wanted +import Annex.Exception +import Config +import Annex.Content.Direct + +import qualified Data.Set as S + +type Reason = String + +{- Drop from local and/or remote when allowed by the preferred content and + - numcopies settings. -} +handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant () +handleDrops _ _ _ Nothing _ = noop +handleDrops reason fromhere key f knownpresentremote = do + syncrs <- syncDataRemotes <$> getDaemonStatus + locs <- liftAnnex $ loggedLocations key + handleDropsFrom locs syncrs reason fromhere key f knownpresentremote + +{- The UUIDs are ones where the content is believed to be present. + - The Remote list can include other remotes that do not have the content; + - only ones that match the UUIDs will be dropped from. + - If allowed to drop fromhere, that drop will be tried first. + - + - In direct mode, all associated files are checked, and only if all + - of them are unwanted are they dropped. + -} +handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant () +handleDropsFrom _ _ _ _ _ Nothing _ = noop +handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do + fs <- liftAnnex $ ifM isDirect + ( do + l <- associatedFilesRelative key + if null l + then return [afile] + else return l + , return [afile] + ) + n <- getcopies fs + if fromhere && checkcopies n Nothing + then go fs rs =<< dropl fs n + else go fs rs n + where + getcopies fs = liftAnnex $ do + (untrusted, have) <- trustPartition UnTrusted locs + numcopies <- maximum <$> mapM (getNumCopies <=< numCopies) fs + return (length have, numcopies, S.fromList untrusted) + + {- Check that we have enough copies still to drop the content. + - When the remote being dropped from is untrusted, it was not + - counted as a copy, so having only numcopies suffices. Otherwise, + - we need more than numcopies to safely drop. -} + checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies + checkcopies (have, numcopies, untrusted) (Just u) + | S.member u untrusted = have >= numcopies + | otherwise = have > numcopies + + decrcopies (have, numcopies, untrusted) Nothing = + (have - 1, numcopies, untrusted) + decrcopies v@(_have, _numcopies, untrusted) (Just u) + | S.member u untrusted = v + | otherwise = decrcopies v Nothing + + go _ [] _ = noop + go fs (r:rest) n + | uuid r `S.notMember` slocs = go fs rest n + | checkcopies n (Just $ Remote.uuid r) = + dropr fs r n >>= go fs rest + | otherwise = noop + + checkdrop fs n@(have, numcopies, _untrusted) u a = + ifM (liftAnnex $ allM (wantDrop True u . Just) fs) + ( ifM (liftAnnex $ safely $ doCommand $ a (Just numcopies)) + ( do + debug + [ "dropped" + , afile + , "(from " ++ maybe "here" show u ++ ")" + , "(copies now " ++ show (have - 1) ++ ")" + , ": " ++ reason + ] + return $ decrcopies n u + , return n + ) + , return n + ) + + dropl fs n = checkdrop fs n Nothing $ \numcopies -> + Command.Drop.startLocal afile numcopies key knownpresentremote + + dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> + Command.Drop.startRemote afile numcopies key r + + safely a = either (const False) id <$> tryAnnex a + + slocs = S.fromList locs diff --git a/Assistant/Fsck.hs b/Assistant/Fsck.hs new file mode 100644 index 0000000000..791c0cf170 --- /dev/null +++ b/Assistant/Fsck.hs @@ -0,0 +1,50 @@ +{- git-annex assistant fscking + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Assistant.Fsck where + +import Assistant.Common +import Types.ScheduledActivity +import qualified Types.Remote as Remote +import Annex.UUID +import Assistant.Alert +import Assistant.Types.UrlRenderer +import Logs.Schedule +import qualified Annex + +import qualified Data.Set as S + +{- Displays a nudge in the webapp if a fsck is not configured for + - the specified remote, or for the local repository. -} +fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant () +fsckNudge urlrenderer mr + | maybe True fsckableRemote mr = + whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $ + unlessM (liftAnnex $ checkFscked mr) $ + notFsckedNudge urlrenderer mr + | otherwise = noop + +fsckableRemote :: Remote -> Bool +fsckableRemote = isJust . Remote.remoteFsck + +{- Checks if the remote, or the local repository, has a fsck scheduled. + - Only looks at fscks configured to run via the local repository, not + - other repositories. -} +checkFscked :: Maybe Remote -> Annex Bool +checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID) + where + wanted = case mr of + Nothing -> isSelfFsck + Just r -> flip isFsckOf (Remote.uuid r) + +isSelfFsck :: ScheduledActivity -> Bool +isSelfFsck (ScheduledSelfFsck _ _) = True +isSelfFsck _ = False + +isFsckOf :: ScheduledActivity -> UUID -> Bool +isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u' +isFsckOf _ _ = False diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs new file mode 100644 index 0000000000..a55a0cab73 --- /dev/null +++ b/Assistant/Gpg.hs @@ -0,0 +1,36 @@ +{- git-annex assistant gpg stuff + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} + +module Assistant.Gpg where + +import Utility.Gpg +import Utility.UserInfo +import Types.Remote (RemoteConfigKey) + +import qualified Data.Map as M + +{- Generates a gpg user id that is not used by any existing secret key -} +newUserId :: IO UserId +newUserId = do + oldkeys <- secretKeys + username <- myUserName + let basekeyname = username ++ "'s git-annex encryption key" + return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys) + ( basekeyname + : map (\n -> basekeyname ++ show n) ([2..] :: [Int]) + ) + +data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption + deriving (Eq) + +{- Generates Remote configuration for encryption. -} +configureEncryption :: EnableEncryption -> (RemoteConfigKey, String) +configureEncryption SharedEncryption = ("encryption", "shared") +configureEncryption NoEncryption = ("encryption", "none") +configureEncryption HybridEncryption = ("encryption", "hybrid") diff --git a/Assistant/Install.hs b/Assistant/Install.hs new file mode 100644 index 0000000000..dee1b5be37 --- /dev/null +++ b/Assistant/Install.hs @@ -0,0 +1,101 @@ +{- Assistant installation + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Install where + +import Assistant.Common +import Assistant.Install.AutoStart +import Assistant.Install.Menu +import Assistant.Ssh +import Config.Files +import Utility.FileMode +import Utility.Shell +import Utility.Tmp +import Utility.Env + +#ifdef darwin_HOST_OS +import Utility.OSX +#else +import Utility.FreeDesktop +#endif + +standaloneAppBase :: IO (Maybe FilePath) +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 + - + - 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. + -} +ensureInstalled :: IO () +ensureInstalled = go =<< standaloneAppBase + where + go Nothing = noop + go (Just base) = do + let program = base "git-annex" + programfile <- programFile + createDirectoryIfMissing True (parentDir programfile) + writeFile programfile program + +#ifdef darwin_HOST_OS + autostartfile <- userAutoStart osxAutoStartLabel +#else + menufile <- desktopMenuFilePath "git-annex" <$> userDataDir + icondir <- iconDir <$> userDataDir + installMenu program menufile base icondir + autostartfile <- autoStartPath "git-annex" <$> userConfigDir +#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 + [ shebang_local + , "set -e" + , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" + , runshell "$SSH_ORIGINAL_COMMAND" + , "else" + , runshell "$@" + , "fi" + ] + + curr <- catchDefaultIO "" $ readFileStrict shim + when (curr /= content) $ do + createDirectoryIfMissing True (parentDir shim) + viaTmp writeFile shim content + modifyFileMode shim $ addModes [ownerExecuteMode] + +{- Returns a cleaned up environment that lacks settings used to make the + - standalone builds use their bundled libraries and programs. + - Useful when calling programs not included in the standalone builds. + - + - For a non-standalone build, returns Nothing. + -} +cleanEnvironment :: IO (Maybe [(String, String)]) +cleanEnvironment = clean <$> getEnvironment + where + clean env + | null vars = Nothing + | otherwise = Just $ catMaybes $ map (restoreorig env) env + | 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 + Nothing -> Nothing + (Just v') -> Just (k, v') + | otherwise = Just p diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs new file mode 100644 index 0000000000..b03d202244 --- /dev/null +++ b/Assistant/Install/AutoStart.hs @@ -0,0 +1,39 @@ +{- Assistant autostart file installation + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Install.AutoStart where + +import Utility.FreeDesktop +#ifdef darwin_HOST_OS +import Utility.OSX +import Utility.Path +import System.Directory +#endif + +installAutoStart :: FilePath -> FilePath -> IO () +installAutoStart command file = do +#ifdef darwin_HOST_OS + createDirectoryIfMissing True (parentDir file) + writeFile file $ genOSXAutoStartFile osxAutoStartLabel command + ["assistant", "--autostart"] +#else + writeDesktopMenuFile (fdoAutostart command) file +#endif + +osxAutoStartLabel :: String +osxAutoStartLabel = "com.branchable.git-annex.assistant" + +fdoAutostart :: FilePath -> DesktopEntry +fdoAutostart command = genDesktopEntry + "Git Annex Assistant" + "Autostart" + False + (command ++ " assistant --autostart") + Nothing + [] diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs new file mode 100644 index 0000000000..41ec855b69 --- /dev/null +++ b/Assistant/Install/Menu.hs @@ -0,0 +1,47 @@ +{- Assistant menu installation. + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Install.Menu where + +import Common + +import Utility.FreeDesktop + +installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO () +installMenu command menufile iconsrcdir icondir = do +#ifdef darwin_HOST_OS + return () +#else + writeDesktopMenuFile (fdoDesktopMenu command) menufile + installIcon (iconsrcdir "logo.svg") $ + iconFilePath (iconBaseName ++ ".svg") "scalable" icondir + installIcon (iconsrcdir "favicon.png") $ + iconFilePath (iconBaseName ++ ".png") "16x16" icondir +#endif + +{- The command can be either just "git-annex", or the full path to use + - to run it. -} +fdoDesktopMenu :: FilePath -> DesktopEntry +fdoDesktopMenu command = genDesktopEntry + "Git Annex" + "Track and sync the files in your Git Annex" + False + (command ++ " webapp") + (Just iconBaseName) + ["Network", "FileTransfer"] + +installIcon :: FilePath -> FilePath -> IO () +installIcon src dest = do + createDirectoryIfMissing True (parentDir dest) + withBinaryFile src ReadMode $ \hin -> + withBinaryFile dest WriteMode $ \hout -> + hGetContents hin >>= hPutStr hout + +iconBaseName :: String +iconBaseName = "git-annex" diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs new file mode 100644 index 0000000000..32a3fd6f52 --- /dev/null +++ b/Assistant/MakeRemote.hs @@ -0,0 +1,164 @@ +{- git-annex assistant remote creation utilities + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.MakeRemote where + +import Assistant.Common +import Assistant.Ssh +import qualified Types.Remote as R +import qualified Remote +import Remote.List +import qualified Remote.Rsync as Rsync +import qualified Remote.GCrypt as GCrypt +import qualified Git +import qualified Git.Command +import qualified Command.InitRemote +import Logs.UUID +import Logs.Remote +import Git.Remote +import Creds +import Assistant.Gpg +import Utility.Gpg (KeyId) + +import qualified Data.Map as M + +{- Sets up a new git or rsync remote, accessed over ssh. -} +makeSshRemote :: SshData -> Annex RemoteName +makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata) + where + maker + | onlyCapability sshdata RsyncCapable = makeRsyncRemote + | otherwise = makeGitRemote + +{- Runs an action that returns a name of the remote, and finishes adding it. -} +addRemote :: Annex RemoteName -> Annex Remote +addRemote a = do + name <- a + void remoteListRefresh + maybe (error "failed to add remote") return + =<< Remote.byName (Just name) + +{- Inits a rsync special remote, and returns its name. -} +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, Command.InitRemote.newConfig name) + go (Just (u, c)) = setupSpecialRemote name Rsync.remote config (Just u, c) + config = M.fromList + [ ("encryption", "shared") + , ("rsyncurl", location) + , ("type", "rsync") + ] + +{- Inits a gcrypt special remote, and returns its name. -} +makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName +makeGCryptRemote remotename location keyid = + initSpecialRemote remotename GCrypt.remote $ M.fromList + [ ("type", "gcrypt") + , ("gitrepo", location) + , configureEncryption HybridEncryption + , ("keyid", keyid) + ] + +type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName + +{- Inits a new special remote. The name is used as a suggestion, but + - will be changed if there is already a special remote with that name. -} +initSpecialRemote :: SpecialRemoteMaker +initSpecialRemote name remotetype config = go 0 + where + go :: Int -> Annex RemoteName + go n = do + let fullname = if n == 0 then name else name ++ show n + r <- Command.InitRemote.findExisting fullname + case r of + Nothing -> setupSpecialRemote fullname remotetype config + (Nothing, Command.InitRemote.newConfig fullname) + Just _ -> go (n + 1) + +{- Enables an existing special remote. -} +enableSpecialRemote :: SpecialRemoteMaker +enableSpecialRemote name remotetype 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 (Just u, c) + +setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName +setupSpecialRemote name remotetype config (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 $ + M.insert "highRandomQuality" "false" $ M.union config c + describeUUID u name + configSet u c' + return name + +{- Returns the name of the git remote it created. If there's already a + - remote at the location, returns its name. -} +makeGitRemote :: String -> String -> Annex RemoteName +makeGitRemote basename location = makeRemote basename location $ \name -> + void $ inRepo $ Git.Command.runBool + [Param "remote", Param "add", Param name, Param location] + +{- If there's not already a remote at the location, adds it using the + - action, which is passed the name of the remote to make. + - + - Returns the name of the remote. -} +makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName +makeRemote basename location a = do + g <- gitRepo + if not (any samelocation $ Git.remotes g) + then do + let name = uniqueRemoteName basename 0 g + a name + return name + else return basename + where + samelocation x = Git.repoLocation x == location + +{- Generate an unused name for a remote, adding a number if + - necessary. + - + - Ensures that the returned name is a legal git remote name. -} +uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName +uniqueRemoteName basename n r + | null namecollision = name + | otherwise = uniqueRemoteName legalbasename (succ n) r + where + namecollision = filter samename (Git.remotes r) + samename x = Git.remoteName x == Just name + name + | n == 0 = legalbasename + | otherwise = legalbasename ++ show n + legalbasename = makeLegalName basename + +{- Finds a CredPair belonging to any Remote that is of a given type + - and matches some other criteria. + - + - This can be used as a default when another repository is being set up + - using the same service. + - + - A function must be provided that returns the CredPairStorage + - to use for a particular Remote's uuid. + -} +previouslyUsedCredPair + :: (UUID -> CredPairStorage) + -> RemoteType + -> (Remote -> Bool) + -> Annex (Maybe CredPair) +previouslyUsedCredPair getstorage remotetype criteria = + getM fromstorage =<< filter criteria . filter sametype <$> remoteList + where + sametype r = R.typename (R.remotetype r) == R.typename remotetype + fromstorage r = do + let storage = getstorage (R.uuid r) + getRemoteCredPair (R.config r) storage diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs new file mode 100644 index 0000000000..6b843ea88f --- /dev/null +++ b/Assistant/Monad.hs @@ -0,0 +1,144 @@ +{- git-annex assistant monad + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +module Assistant.Monad ( + Assistant, + AssistantData(..), + newAssistantData, + runAssistant, + getAssistant, + LiftAnnex, + liftAnnex, + (<~>), + (<<~), + asIO, + asIO1, + asIO2, + ThreadName, + debug, + notice +) where + +import "mtl" Control.Monad.Reader +import System.Log.Logger + +import Common.Annex +import Assistant.Types.ThreadedMonad +import Assistant.Types.DaemonStatus +import Assistant.Types.ScanRemotes +import Assistant.Types.TransferQueue +import Assistant.Types.TransferSlots +import Assistant.Types.TransferrerPool +import Assistant.Types.Pushes +import Assistant.Types.BranchChange +import Assistant.Types.Commits +import Assistant.Types.Changes +import Assistant.Types.RepoProblem +import Assistant.Types.Buddies +import Assistant.Types.NetMessager +import Assistant.Types.ThreadName + +newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } + deriving ( + Monad, + MonadIO, + MonadReader AssistantData, + Functor, + Applicative + ) + +data AssistantData = AssistantData + { threadName :: ThreadName + , threadState :: ThreadState + , daemonStatusHandle :: DaemonStatusHandle + , scanRemoteMap :: ScanRemoteMap + , transferQueue :: TransferQueue + , transferSlots :: TransferSlots + , transferrerPool :: TransferrerPool + , failedPushMap :: FailedPushMap + , commitChan :: CommitChan + , changePool :: ChangePool + , repoProblemChan :: RepoProblemChan + , branchChangeHandle :: BranchChangeHandle + , buddyList :: BuddyList + , netMessager :: NetMessager + } + +newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData +newAssistantData st dstatus = AssistantData + <$> pure (ThreadName "main") + <*> pure st + <*> pure dstatus + <*> newScanRemoteMap + <*> newTransferQueue + <*> newTransferSlots + <*> newTransferrerPool + <*> newFailedPushMap + <*> newCommitChan + <*> newChangePool + <*> newRepoProblemChan + <*> newBranchChangeHandle + <*> newBuddyList + <*> newNetMessager + +runAssistant :: AssistantData -> Assistant a -> IO a +runAssistant d a = runReaderT (mkAssistant a) d + +getAssistant :: (AssistantData -> a) -> Assistant a +getAssistant = reader + +{- Using a type class for lifting into the annex monad allows + - easily lifting to it from multiple different monads. -} +class LiftAnnex m where + liftAnnex :: Annex a -> m a + +{- Runs an action in the git-annex monad. Note that the same monad state + - is shared amoung all assistant threads, so only one of these can run at + - a time. Therefore, long-duration actions should be avoided. -} +instance LiftAnnex Assistant where + liftAnnex a = do + st <- reader threadState + liftIO $ runThreadState st a + +{- Runs an IO action, passing it an IO action that runs an Assistant action. -} +(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b +io <~> a = do + d <- reader id + liftIO $ io $ runAssistant d a + +{- Creates an IO action that will run an Assistant action when run. -} +asIO :: Assistant a -> Assistant (IO a) +asIO a = do + d <- reader id + return $ runAssistant d a + +asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b) +asIO1 a = do + d <- reader id + return $ \v -> runAssistant d $ a v + +asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c) +asIO2 a = do + d <- reader id + return $ \v1 v2 -> runAssistant d (a v1 v2) + +{- Runs an IO action on a selected field of the AssistantData. -} +(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b +io <<~ v = reader v >>= liftIO . io + +debug :: [String] -> Assistant () +debug = logaction debugM + +notice :: [String] -> Assistant () +notice = logaction noticeM + +logaction :: (String -> String -> IO ()) -> [String] -> Assistant () +logaction a ws = do + ThreadName name <- getAssistant threadName + liftIO $ a name $ unwords $ (name ++ ":") : ws diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs new file mode 100644 index 0000000000..2440c45bf5 --- /dev/null +++ b/Assistant/NamedThread.hs @@ -0,0 +1,102 @@ +{- git-annex assistant named threads. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.NamedThread where + +import Common.Annex +import Assistant.Types.NamedThread +import Assistant.Types.ThreadName +import Assistant.Types.DaemonStatus +import Assistant.Types.UrlRenderer +import Assistant.DaemonStatus +import Assistant.Monad +import Utility.NotificationBroadcaster + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Data.Map as M +import qualified Control.Exception as E + +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import Assistant.Types.Alert +import Assistant.Alert +import qualified Data.Text as T +#endif + +{- Starts a named thread, if it's not already running. + - + - Named threads are run by a management thread, so if they crash + - an alert is displayed, allowing the thread to be restarted. -} +startNamedThread :: UrlRenderer -> NamedThread -> Assistant () +startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do + m <- startedThreads <$> getDaemonStatus + case M.lookup name m of + Nothing -> start + Just (aid, _) -> do + r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ())))) + case r of + Right Nothing -> noop + _ -> start + where + start + | afterstartupsanitycheck = do + status <- getDaemonStatus + h <- liftIO $ newNotificationHandle False $ + startupSanityCheckNotifier status + startwith $ runmanaged $ + liftIO $ waitNotification h + | otherwise = startwith $ runmanaged noop + startwith runner = do + d <- getAssistant id + aid <- liftIO $ runner $ d { threadName = name } + restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a) + modifyDaemonStatus_ $ \s -> s + { startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) } + runmanaged first d = do + aid <- async $ runAssistant d $ do + void first + a + void $ forkIO $ manager d aid + return aid + manager d aid = do + r <- E.try (wait aid) :: IO (Either E.SomeException ()) + case r of + Right _ -> noop + Left e -> do + let msg = unwords + [ fromThreadName $ threadName d + , "crashed:", show e + ] + hPutStrLn stderr msg +#ifdef WITH_WEBAPP + button <- runAssistant d $ mkAlertButton True + (T.pack "Restart Thread") + urlrenderer + (RestartThreadR name) + runAssistant d $ void $ addAlert $ + (warningAlert (fromThreadName name) msg) + { alertButton = Just button } +#endif + +namedThreadId :: NamedThread -> Assistant (Maybe ThreadId) +namedThreadId (NamedThread _ name _) = do + m <- startedThreads <$> getDaemonStatus + return $ asyncThreadId . fst <$> M.lookup name m + +{- Waits for all named threads that have been started to finish. + - + - Note that if a named thread crashes, it will probably + - cause this to crash as well. Also, named threads that are started + - after this is called will not be waited on. -} +waitNamedThreads :: Assistant () +waitNamedThreads = do + m <- startedThreads <$> getDaemonStatus + liftIO $ mapM_ (wait . fst) $ M.elems m + diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs new file mode 100644 index 0000000000..acb18b6484 --- /dev/null +++ b/Assistant/NetMessager.hs @@ -0,0 +1,180 @@ +{- git-annex assistant out of band network messager interface + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Assistant.NetMessager where + +import Assistant.Common +import Assistant.Types.NetMessager + +import Control.Concurrent.STM +import Control.Concurrent.MSampleVar +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.DList as D + +sendNetMessage :: NetMessage -> Assistant () +sendNetMessage m = + (atomically . flip writeTChan m) <<~ (netMessages . netMessager) + +waitNetMessage :: Assistant (NetMessage) +waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager) + +notifyNetMessagerRestart :: Assistant () +notifyNetMessagerRestart = + flip writeSV () <<~ (netMessagerRestart . netMessager) + +{- This can be used to get an early indication if the network has + - changed, to immediately restart a connection. However, that is not + - available on all systems, so clients also need to deal with + - restarting dropped connections in the usual way. -} +waitNetMessagerRestart :: Assistant () +waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager) + +{- Store a new important NetMessage for a client, and if an equivilant + - older message is already stored, remove it from both importantNetMessages + - and sentImportantNetMessages. -} +storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant () +storeImportantNetMessage m client matchingclient = go <<~ netMessager + where + go nm = atomically $ do + q <- takeTMVar $ importantNetMessages nm + sent <- takeTMVar $ sentImportantNetMessages nm + putTMVar (importantNetMessages nm) $ + M.alter (Just . maybe (S.singleton m) (S.insert m)) client $ + M.mapWithKey removematching q + putTMVar (sentImportantNetMessages nm) $ + M.mapWithKey removematching sent + removematching someclient s + | matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s + | otherwise = s + +{- Indicates that an important NetMessage has been sent to a client. -} +sentImportantNetMessage :: NetMessage -> ClientID -> Assistant () +sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager) + where + go v = atomically $ do + sent <- takeTMVar v + putTMVar v $ + M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent + +{- Checks for important NetMessages that have been stored for a client, and + - sent to a client. Typically the same client for both, although + - a modified or more specific client may need to be used. -} +checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage) +checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager + where + go nm = atomically $ do + stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm) + sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm) + return (fromMaybe S.empty stored, fromMaybe S.empty sent) + +{- Queues a push initiation message in the queue for the appropriate + - side of the push but only if there is not already an initiation message + - from the same client in the queue. -} +queuePushInitiation :: NetMessage -> Assistant () +queuePushInitiation msg@(Pushing clientid stage) = do + tv <- getPushInitiationQueue side + liftIO $ atomically $ do + r <- tryTakeTMVar tv + case r of + Nothing -> putTMVar tv [msg] + Just l -> do + let !l' = msg : filter differentclient l + putTMVar tv l' + where + side = pushDestinationSide stage + differentclient (Pushing cid _) = cid /= clientid + differentclient _ = True +queuePushInitiation _ = noop + +{- Waits for a push inititation message to be received, and runs + - function to select a message from the queue. -} +waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage +waitPushInitiation side selector = do + tv <- getPushInitiationQueue side + liftIO $ atomically $ do + q <- takeTMVar tv + if null q + then retry + else do + let (msg, !q') = selector q + unless (null q') $ + putTMVar tv q' + return msg + +{- Stores messages for a push into the appropriate inbox. + - + - To avoid overflow, only 1000 messages max are stored in any + - inbox, which should be far more than necessary. + - + - TODO: If we have more than 100 inboxes for different clients, + - discard old ones that are not currently being used by any push. + -} +storeInbox :: NetMessage -> Assistant () +storeInbox msg@(Pushing clientid stage) = do + inboxes <- getInboxes side + stored <- liftIO $ atomically $ do + m <- readTVar inboxes + let update = \v -> do + writeTVar inboxes $ + M.insertWith' const clientid v m + return True + case M.lookup clientid m of + Nothing -> update (1, tostore) + Just (sz, l) + | sz > 1000 -> return False + | otherwise -> + let !sz' = sz + 1 + !l' = D.append l tostore + in update (sz', l') + if stored + then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"] + else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"] + where + side = pushDestinationSide stage + tostore = D.singleton msg +storeInbox _ = noop + +{- Gets the new message for a push from its inbox. + - Blocks until a message has been received. -} +waitInbox :: ClientID -> PushSide -> Assistant (NetMessage) +waitInbox clientid side = do + inboxes <- getInboxes side + liftIO $ atomically $ do + m <- readTVar inboxes + case M.lookup clientid m of + Nothing -> retry + Just (sz, dl) + | sz < 1 -> retry + | otherwise -> do + let msg = D.head dl + let dl' = D.tail dl + let !sz' = sz - 1 + writeTVar inboxes $ + M.insertWith' const clientid (sz', dl') m + return msg + +emptyInbox :: ClientID -> PushSide -> Assistant () +emptyInbox clientid side = do + inboxes <- getInboxes side + liftIO $ atomically $ + modifyTVar' inboxes $ + M.delete clientid + +getInboxes :: PushSide -> Assistant Inboxes +getInboxes side = + getSide side . netMessagerInboxes <$> getAssistant netMessager + +getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage]) +getPushInitiationQueue side = + getSide side . netMessagerPushInitiations <$> getAssistant netMessager + +netMessagerDebug :: ClientID -> [String] -> Assistant () +netMessagerDebug clientid l = debug $ + "NetMessager" : l ++ [show $ logClientID clientid] diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs new file mode 100644 index 0000000000..bb1384a151 --- /dev/null +++ b/Assistant/Pairing.hs @@ -0,0 +1,92 @@ +{- git-annex assistant repo pairing, core data types + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Pairing where + +import Common.Annex +import Utility.Verifiable +import Assistant.Ssh + +import Control.Concurrent +import Network.Socket +import Data.Char +import qualified Data.Text as T + +data PairStage + {- "I'll pair with anybody who shares the secret that can be used + - to verify this request." -} + = PairReq + {- "I've verified your request, and you can verify this to see + - that I know the secret. I set up your ssh key already. + - Here's mine for you to set up." -} + | PairAck + {- "I saw your PairAck; you can stop sending them." -} + | PairDone + deriving (Eq, Read, Show, Ord, Enum) + +newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr)) + deriving (Eq, Read, Show) + +verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool +verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip + +fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr) +fromPairMsg (PairMsg m) = m + +pairMsgStage :: PairMsg -> PairStage +pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s + +pairMsgData :: PairMsg -> PairData +pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d + +pairMsgAddr :: PairMsg -> SomeAddr +pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a + +data PairData = PairData + -- uname -n output, not a full domain name + { remoteHostName :: Maybe HostName + , remoteUserName :: UserName + , remoteDirectory :: FilePath + , remoteSshPubKey :: SshPubKey + , pairUUID :: UUID + } + deriving (Eq, Read, Show) + +type UserName = String + +{- A pairing that is in progress has a secret, a thread that is + - broadcasting pairing messages, and a SshKeyPair that has not yet been + - set up on disk. -} +data PairingInProgress = PairingInProgress + { inProgressSecret :: Secret + , inProgressThreadId :: Maybe ThreadId + , inProgressSshKeyPair :: SshKeyPair + , inProgressPairData :: PairData + , inProgressPairStage :: PairStage + } + deriving (Show) + +data SomeAddr = IPv4Addr HostAddress +{- My Android build of the Network library does not currently have IPV6 + - support. -} +#ifndef __ANDROID__ + | IPv6Addr HostAddress6 +#endif + deriving (Ord, Eq, Read, Show) + +{- This contains the whole secret, just lightly obfuscated to make it not + - too obvious. It's only displayed in the user's web browser. -} +newtype SecretReminder = SecretReminder [Int] + deriving (Show, Eq, Ord, Read) + +toSecretReminder :: T.Text -> SecretReminder +toSecretReminder = SecretReminder . map ord . T.unpack + +fromSecretReminder :: SecretReminder -> T.Text +fromSecretReminder (SecretReminder s) = T.pack $ map chr s diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs new file mode 100644 index 0000000000..144b236a41 --- /dev/null +++ b/Assistant/Pairing/MakeRemote.hs @@ -0,0 +1,95 @@ +{- git-annex assistant pairing remote creation + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Pairing.MakeRemote where + +import Assistant.Common +import Assistant.Ssh +import Assistant.Pairing +import Assistant.Pairing.Network +import Assistant.MakeRemote +import Assistant.Sync +import Config.Cost +import Config + +import Network.Socket +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 + +{- When local pairing is complete, this is used to set up the remote for + - the host we paired with. -} +finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant () +finishedLocalPairing msg keypair = do + sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg + {- Ensure that we know the ssh host key for the host we paired with. + - If we don't, ssh over to get it. -} + liftIO $ unlessM (knownHost $ sshHostName sshdata) $ + void $ sshTranscript + [ sshOpt "StrictHostKeyChecking" "no" + , sshOpt "NumberOfPasswordPrompts" "0" + , "-n" + , genSshHost (sshHostName sshdata) (sshUserName sshdata) + , "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) + ] + Nothing + r <- liftAnnex $ addRemote $ makeSshRemote sshdata + liftAnnex $ setRemoteCost r semiExpensiveRemoteCost + syncRemote r + +{- Mostly a straightforward conversion. Except: + - * Determine the best hostname to use to contact the host. + - * Strip leading ~/ from the directory name. + -} +pairMsgToSshData :: PairMsg -> IO SshData +pairMsgToSshData msg = do + let d = pairMsgData msg + hostname <- liftIO $ bestHostName msg + let dir = case remoteDirectory d of + ('~':'/':v) -> v + v -> v + return SshData + { sshHostName = T.pack hostname + , sshUserName = Just (T.pack $ remoteUserName d) + , sshDirectory = T.pack dir + , sshRepoName = genSshRepoName hostname dir + , sshPort = 22 + , needsPubKey = True + , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] + } + +{- Finds the best hostname to use for the host that sent the PairMsg. + - + - If remoteHostName is set, tries to use a .local address based on it. + - That's the most robust, if this system supports .local. + - Otherwise, looks up the hostname in the DNS for the remoteAddress, + - if any. May fall back to remoteAddress if there's no DNS. Ugh. -} +bestHostName :: PairMsg -> IO HostName +bestHostName msg = case remoteHostName $ pairMsgData msg of + Just h -> do + let localname = h ++ ".local" + addrs <- catchDefaultIO [] $ + getAddrInfo Nothing (Just localname) Nothing + maybe fallback (const $ return localname) (headMaybe addrs) + Nothing -> fallback + where + fallback = do + let a = pairMsgAddr msg + let sockaddr = case a of + IPv4Addr addr -> SockAddrInet (PortNum 0) addr + IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0 + fromMaybe (showAddr a) + <$> catchDefaultIO Nothing + (fst <$> getNameInfo [] True False sockaddr) diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs new file mode 100644 index 0000000000..6c625f8814 --- /dev/null +++ b/Assistant/Pairing/Network.hs @@ -0,0 +1,130 @@ +{- git-annex assistant pairing network code + - + - All network traffic is sent over multicast UDP. For reliability, + - 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 + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Pairing.Network where + +import Assistant.Common +import Assistant.Pairing +import Assistant.DaemonStatus +import Utility.ThreadScheduler +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 + +{- This is an arbitrary port in the dynamic port range, that could + - conceivably be used for some other broadcast messages. + - If so, hope they ignore the garbage from us; we'll certianly + - ignore garbage from them. Wild wild west. -} +pairingPort :: PortNumber +pairingPort = 55556 + +{- Goal: Reach all hosts on the same network segment. + - Method: Use same address that avahi uses. Other broadcast addresses seem + - to not be let through some routers. -} +multicastAddress :: SomeAddr -> HostName +multicastAddress (IPv4Addr _) = "224.0.0.251" +multicastAddress (IPv6Addr _) = "ff02::fb" + +{- Multicasts a message repeatedly on all interfaces, with a 2 second + - delay between each transmission. The message is repeated forever + - unless a number of repeats is specified. + - + - The remoteHostAddress is set to the interface's IP address. + - + - Note that new sockets are opened each time. This is hardly efficient, + - but it allows new network interfaces to be used as they come up. + - On the other hand, the expensive DNS lookups are cached. + -} +multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO () +multicastPairMsg repeats secret pairdata stage = go M.empty repeats + where + go _ (Just 0) = noop + go cache n = do + addrs <- activeNetworkAddresses + let cache' = updatecache cache addrs + mapM_ (sendinterface cache') addrs + threadDelaySeconds (Seconds 2) + go cache' $ pred <$> n + {- The multicast library currently chokes on ipv6 addresses. -} + sendinterface _ (IPv6Addr _) = noop + sendinterface cache i = void $ tryIO $ + withSocketsDo $ bracket setup cleanup use + where + setup = multicastSender (multicastAddress i) pairingPort + cleanup (sock, _) = sClose sock -- FIXME does not work + use (sock, addr) = do + setInterface sock (showAddr i) + maybe noop (\s -> void $ sendTo sock s addr) + (M.lookup i cache) + updatecache cache [] = cache + updatecache cache (i:is) + | M.member i cache = updatecache cache is + | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is + mkmsg addr = PairMsg $ + mkVerifiable (stage, pairdata, addr) secret + +startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant () +startSending pip stage sender = do + a <- asIO start + void $ liftIO $ forkIO a + where + start = do + tid <- liftIO myThreadId + let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid } + oldpip <- modifyDaemonStatus $ + \s -> (s { pairingInProgress = Just pip' }, pairingInProgress s) + maybe noop stopold oldpip + liftIO $ sender stage + stopold = maybe noop (liftIO . killThread) . inProgressThreadId + +stopSending :: PairingInProgress -> Assistant () +stopSending pip = do + maybe noop (liftIO . killThread) $ inProgressThreadId pip + modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing } + +class ToSomeAddr a where + toSomeAddr :: a -> SomeAddr + +instance ToSomeAddr IPv4 where + toSomeAddr (IPv4 a) = IPv4Addr a + +instance ToSomeAddr IPv6 where + toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4) + +showAddr :: SomeAddr -> HostName +showAddr (IPv4Addr a) = show $ IPv4 a +showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4 + +activeNetworkAddresses :: IO [SomeAddr] +activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr) + . concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni]) + <$> getNetworkInterfaces + +{- A human-visible description of the repository being paired with. + - Note that the repository's description is not shown to the user, because + - it could be something like "my repo", which is confusing when pairing + - with someone else's repo. However, this has the same format as the + - default decription of a repo. -} +pairRepo :: PairMsg -> String +pairRepo msg = concat + [ remoteUserName d + , "@" + , fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d) + , ":" + , remoteDirectory d + ] + where + d = pairMsgData msg diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs new file mode 100644 index 0000000000..54f31a84bc --- /dev/null +++ b/Assistant/Pushes.hs @@ -0,0 +1,40 @@ +{- git-annex assistant push tracking + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Pushes where + +import Assistant.Common +import Assistant.Types.Pushes + +import Control.Concurrent.STM +import Data.Time.Clock +import qualified Data.Map as M + +{- Blocks until there are failed pushes. + - Returns Remotes whose pushes failed a given time duration or more ago. + - (This may be an empty list.) -} +getFailedPushesBefore :: NominalDiffTime -> Assistant [Remote] +getFailedPushesBefore duration = do + v <- getAssistant failedPushMap + liftIO $ do + m <- atomically $ readTMVar v + now <- getCurrentTime + return $ M.keys $ M.filter (not . toorecent now) m + where + toorecent now time = now `diffUTCTime` time < duration + +{- Modifies the map. -} +changeFailedPushMap :: (PushMap -> PushMap) -> Assistant () +changeFailedPushMap a = do + v <- getAssistant failedPushMap + liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v + where + {- tryTakeTMVar empties the TMVar; refill it only if + - the modified map is not itself empty -} + store v m + | m == M.empty = noop + | otherwise = putTMVar v $! m diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs new file mode 100644 index 0000000000..1f54451251 --- /dev/null +++ b/Assistant/Repair.hs @@ -0,0 +1,153 @@ +{- git-annex assistant repository repair + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Repair where + +import Assistant.Common +import Command.Repair (repairAnnexBranch) +import Git.Fsck (FsckResults, foundBroken) +import Git.Repair (runRepairOf) +import qualified Git +import qualified Remote +import qualified Types.Remote as Remote +import Logs.FsckResults +import Annex.UUID +import Utility.Batch +import Config.Files +import Assistant.Sync +import Assistant.Alert +import Assistant.DaemonStatus +import Assistant.Types.UrlRenderer +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import qualified Data.Text as T +#endif +import qualified Utility.Lsof as Lsof +import Utility.ThreadScheduler + +import Control.Concurrent.Async + +{- When the FsckResults require a repair, tries to do a non-destructive + - repair. If that fails, pops up an alert. -} +repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant Bool +repairWhenNecessary urlrenderer u mrmt fsckresults + | foundBroken fsckresults = do + liftAnnex $ writeFsckResults u fsckresults + repodesc <- liftAnnex $ Remote.prettyUUID u + ok <- alertWhile (repairingAlert repodesc) + (runRepair u mrmt False) +#ifdef WITH_WEBAPP + unless ok $ do + button <- mkAlertButton True (T.pack "Click Here") urlrenderer $ + RepairRepositoryR u + void $ addAlert $ brokenRepositoryAlert button +#endif + return ok + | otherwise = return False + +runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool +runRepair u mrmt destructiverepair = do + fsckresults <- liftAnnex $ readFsckResults u + myu <- liftAnnex getUUID + ok <- if u == myu + then localrepair fsckresults + else remoterepair fsckresults + liftAnnex $ writeFsckResults u Nothing + debug [ "Repaired", show u, show ok ] + + return ok + where + localrepair fsckresults = do + -- Stop the watcher from running while running repairs. + changeSyncable Nothing False + + -- This intentionally runs the repair inside the Annex + -- monad, which is not strictly necessary, but keeps + -- other threads that might be trying to use the Annex + -- from running until it completes. + ok <- liftAnnex $ repair fsckresults Nothing + + -- Run a background fast fsck if a destructive repair had + -- to be done, to ensure that the git-annex branch + -- reflects the current state of the repo. + when destructiverepair $ + backgroundfsck [ Param "--fast" ] + + -- Start the watcher running again. This also triggers it to + -- do a startup scan, which is especially important if the + -- git repo repair removed files from the index file. Those + -- files will be seen as new, and re-added to the repository. + when (ok || destructiverepair) $ + changeSyncable Nothing True + + return ok + + remoterepair fsckresults = case Remote.repairRepo =<< mrmt of + Nothing -> return False + Just mkrepair -> do + thisrepopath <- liftIO . absPath + =<< liftAnnex (fromRepo Git.repoPath) + a <- liftAnnex $ mkrepair $ + repair fsckresults (Just thisrepopath) + liftIO $ catchBoolIO a + + repair fsckresults referencerepo = do + (ok, stillmissing, modifiedbranches) <- inRepo $ + runRepairOf fsckresults destructiverepair referencerepo + when destructiverepair $ + repairAnnexBranch stillmissing modifiedbranches + return ok + + backgroundfsck params = liftIO $ void $ async $ do + program <- readProgramFile + batchCommand program (Param "fsck" : params) + +{- Detect when a git lock file exists and has no git process currently + - writing to it. This strongly suggests it is a stale lock file. + - + - However, this could be on a network filesystem. Which is not very safe + - anyway (the assistant relies on being able to check when files have + - no writers to know when to commit them). Just in case, when the lock + - file appears stale, we delay for one minute, and check its size. If + - the size changed, delay for another minute, and so on. This will at + - least work to detect is another machine is writing out a new index + - file, since git does so by writing the new content to index.lock. + - + - Returns true if locks were cleaned up. + -} +repairStaleGitLocks :: Git.Repo -> Assistant Bool +repairStaleGitLocks r = do + lockfiles <- filter (not . isInfixOf "gc.pid") + . filter (".lock" `isSuffixOf`) + <$> liftIO (findgitfiles r) + repairStaleLocks lockfiles + return $ not $ null lockfiles + where + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) . Git.localGitDir +repairStaleLocks :: [FilePath] -> Assistant () +repairStaleLocks lockfiles = go =<< getsizes + where + getsize lf = catchMaybeIO $ + (\s -> (lf, fileSize s)) <$> getFileStatus lf + getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles + go [] = return () + go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l)) + ( do + waitforit "to check stale git lock file" + l' <- getsizes + if l' == l + then liftIO $ mapM_ nukeFile (map fst l) + else go l' + , do + waitforit "for git lock file writer" + go =<< getsizes + ) + waitforit why = do + notice ["Waiting for 60 seconds", why] + liftIO $ threadDelaySeconds $ Seconds 60 diff --git a/Assistant/RepoProblem.hs b/Assistant/RepoProblem.hs new file mode 100644 index 0000000000..6913fefc62 --- /dev/null +++ b/Assistant/RepoProblem.hs @@ -0,0 +1,34 @@ +{- git-annex assistant remote problem handling + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.RepoProblem where + +import Assistant.Common +import Assistant.Types.RepoProblem +import Utility.TList + +import Control.Concurrent.STM + +{- Gets all repositories that have problems. Blocks until there is at + - least one. -} +getRepoProblems :: Assistant [RepoProblem] +getRepoProblems = nubBy sameRepoProblem + <$> (atomically . getTList) <<~ repoProblemChan + +{- Indicates that there was a problem with a repository, and the problem + - appears to not be a transient (eg network connection) problem. + - + - If the problem is able to be repaired, the passed action will be run. + - (However, if multiple problems are reported with a single repository, + - only a single action will be run.) + -} +repoHasProblem :: UUID -> Assistant () -> Assistant () +repoHasProblem u afterrepair = do + rp <- RepoProblem + <$> pure u + <*> asIO afterrepair + (atomically . flip consTList rp) <<~ repoProblemChan diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs new file mode 100644 index 0000000000..2743c0f361 --- /dev/null +++ b/Assistant/ScanRemotes.hs @@ -0,0 +1,41 @@ +{- git-annex assistant remotes needing scanning + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.ScanRemotes where + +import Assistant.Common +import Assistant.Types.ScanRemotes +import qualified Types.Remote as Remote + +import Data.Function +import Control.Concurrent.STM +import qualified Data.Map as M + +{- Blocks until there is a remote or remotes that need to be scanned. + - + - The list has higher priority remotes listed first. -} +getScanRemote :: Assistant [(Remote, ScanInfo)] +getScanRemote = do + v <- getAssistant scanRemoteMap + liftIO $ atomically $ + reverse . sortBy (compare `on` scanPriority . snd) . M.toList + <$> takeTMVar v + +{- Adds new remotes that need scanning. -} +addScanRemotes :: Bool -> [Remote] -> Assistant () +addScanRemotes _ [] = noop +addScanRemotes full rs = do + v <- getAssistant scanRemoteMap + liftIO $ atomically $ do + m <- fromMaybe M.empty <$> tryTakeTMVar v + putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m + where + info r = ScanInfo (-1 * Remote.cost r) full + merge x y = ScanInfo + { scanPriority = max (scanPriority x) (scanPriority y) + , fullScan = fullScan x || fullScan y + } diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs new file mode 100644 index 0000000000..f316aa5008 --- /dev/null +++ b/Assistant/Ssh.hs @@ -0,0 +1,345 @@ +{- git-annex assistant ssh utilities + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Ssh where + +import Common.Annex +import Utility.Tmp +import Utility.UserInfo +import Utility.Shell +import Utility.Rsync +import Git.Remote + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Char +import Network.URI + +data SshData = SshData + { sshHostName :: Text + , sshUserName :: Maybe Text + , sshDirectory :: Text + , sshRepoName :: String + , sshPort :: Int + , needsPubKey :: Bool + , sshCapabilities :: [SshServerCapability] + } + deriving (Read, Show, Eq) + +data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable + deriving (Read, Show, Eq) + +hasCapability :: SshData -> SshServerCapability -> Bool +hasCapability d c = c `elem` sshCapabilities d + +onlyCapability :: SshData -> SshServerCapability -> Bool +onlyCapability d c = all (== c) (sshCapabilities d) + +data SshKeyPair = SshKeyPair + { sshPubKey :: String + , sshPrivKey :: String + } + +instance Show SshKeyPair where + show = sshPubKey + +type SshPubKey = String + +{- ssh -ofoo=bar command-line option -} +sshOpt :: String -> String -> String +sshOpt k v = concat ["-o", k, "=", v] + +sshDir :: IO FilePath +sshDir = do + home <- myHomeDir + return $ home ".ssh" + +{- user@host or host -} +genSshHost :: Text -> Maybe Text -> String +genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host + +{- Generates a ssh or rsync url from a SshData. -} +genSshUrl :: SshData -> String +genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $ + if (onlyCapability sshdata RsyncCapable) + then [u, h, T.pack ":", sshDirectory sshdata] + else [T.pack "ssh://", u, h, d] + where + u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata + h = sshHostName sshdata + d + | T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata + | T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata] + | otherwise = T.concat [T.pack "/~/", sshDirectory sshdata] + addtrailingslash s + | "/" `isSuffixOf` s = s + | otherwise = s ++ "/" + +{- Reverses genSshUrl -} +parseSshUrl :: String -> Maybe SshData +parseSshUrl u + | "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u) + | otherwise = fromrsync u + where + mkdata (userhost, dir) = Just $ SshData + { sshHostName = T.pack host + , sshUserName = if null user then Nothing else Just $ T.pack user + , sshDirectory = T.pack dir + , sshRepoName = genSshRepoName host dir + -- dummy values, cannot determine from url + , sshPort = 22 + , needsPubKey = True + , sshCapabilities = [] + } + where + (user, host) = if '@' `elem` userhost + then separate (== '@') userhost + else ("", userhost) + fromrsync s + | not (rsyncUrlIsShell u) = Nothing + | otherwise = mkdata $ separate (== ':') s + fromssh = mkdata . break (== '/') + +{- Generates a git remote name, like host_dir or host -} +genSshRepoName :: String -> FilePath -> String +genSshRepoName host dir + | null dir = makeLegalName host + | otherwise = makeLegalName $ host ++ "_" ++ dir + +{- The output of ssh, including both stdout and stderr. -} +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 () +validateSshPubKey pubkey + | length (lines pubkey) == 1 = + either error return $ check $ words pubkey + | otherwise = error "too many lines in ssh public key" + where + check [prefix, _key, comment] = do + checkprefix prefix + checkcomment comment + check [prefix, _key] = + checkprefix prefix + 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 + | 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 ] + +removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO () +removeAuthorizedKeys gitannexshellonly dir pubkey = do + let keyline = authorizedKeysLine gitannexshellonly dir pubkey + sshdir <- sshDir + let keyfile = sshdir "authorized_keys" + ls <- lines <$> readFileStrict keyfile + writeFile keyfile $ unlines $ filter (/= keyline) ls + +{- Implemented as a shell command, so it can be run on remote servers over + - ssh. + - + - The ~/.ssh/git-annex-shell wrapper script is created if not already + - present. + -} +addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String +addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" + [ "mkdir -p ~/.ssh" + , intercalate "; " + [ "if [ ! -e " ++ wrapper ++ " ]" + , "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper + , "fi" + ] + , "chmod 700 " ++ wrapper + , "touch ~/.ssh/authorized_keys" + , "chmod 600 ~/.ssh/authorized_keys" + , unwords + [ "echo" + , shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey + , ">>~/.ssh/authorized_keys" + ] + ] + where + echoval v = "echo " ++ shellEscape v + wrapper = "~/.ssh/git-annex-shell" + script = + [ shebang_portable + , "set -e" + , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" + , runshell "$SSH_ORIGINAL_COMMAND" + , "else" + , runshell "$@" + , "fi" + ] + runshell var = "exec git-annex-shell -c \"" ++ var ++ "\"" + +authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String +authorizedKeysLine gitannexshellonly dir pubkey + | gitannexshellonly = limitcommand ++ pubkey + {- TODO: Locking down rsync is difficult, requiring a rather + - 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 " + +{- Generates a ssh key pair. -} +genSshKeyPair :: IO SshKeyPair +genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do + ok <- boolSystem "ssh-keygen" + [ Param "-P", Param "" -- no password + , Param "-f", File $ dir "key" + ] + unless ok $ + error "ssh-keygen failed" + SshKeyPair + <$> readFile (dir "key.pub") + <*> readFile (dir "key") + +{- Installs a ssh key pair, and sets up ssh config with a mangled hostname + - that will enable use of the key. This way we avoid changing the user's + - regular ssh experience at all. Returns a modified SshData containing the + - mangled hostname. + - + - Note that the key files are put in ~/.ssh/git-annex/, rather than directly + - in ssh because of an **INSANE** behavior of gnome-keyring: It loads + - ~/.ssh/ANYTHING.pub, and uses them indiscriminately. But using this key + - for a normal login to the server will force git-annex-shell to run, + - and locks the user out. Luckily, it does not recurse into subdirectories. + - + - Similarly, IdentitiesOnly is set in the ssh config to prevent the + - ssh-agent from forcing use of a different key. + -} +setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData +setupSshKeyPair sshkeypair sshdata = do + sshdir <- sshDir + createDirectoryIfMissing True $ parentDir $ sshdir sshprivkeyfile + + unlessM (doesFileExist $ sshdir sshprivkeyfile) $ do + h <- fdToHandle =<< + createFile (sshdir sshprivkeyfile) + (unionFileModes ownerWriteMode ownerReadMode) + hPutStr h (sshPrivKey sshkeypair) + hClose h + unlessM (doesFileExist $ sshdir sshpubkeyfile) $ + writeFile (sshdir sshpubkeyfile) (sshPubKey sshkeypair) + + setSshConfig sshdata + [ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) + , ("IdentitiesOnly", "yes") + ] + where + sshprivkeyfile = "git-annex" "key." ++ mangleSshHostName sshdata + sshpubkeyfile = sshprivkeyfile ++ ".pub" + +{- Fixes git-annex ssh key pairs configured in .ssh/config + - by old versions to set IdentitiesOnly. -} +fixSshKeyPair :: IO () +fixSshKeyPair = do + sshdir <- sshDir + let configfile = sshdir "config" + whenM (doesFileExist configfile) $ do + ls <- lines <$> readFileStrict configfile + let ls' = fixSshKeyPair' ls + when (ls /= ls') $ + viaTmp writeFile configfile $ unlines ls' + +{- Strategy: Search for IdentityFile lines in for files with key.git-annex + - in their names. These are for git-annex ssh key pairs. + - Add the IdentitiesOnly line immediately after them, if not already + - present. -} +fixSshKeyPair' :: [String] -> [String] +fixSshKeyPair' = go [] + where + go c [] = reverse c + go c (l:[]) + | all (`isInfixOf` l) indicators = go (fixedline l:l:c) [] + | otherwise = go (l:c) [] + go c (l:next:rest) + | 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"] + fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes" + +{- Setups up a ssh config with a mangled hostname. + - Returns a modified SshData containing the mangled hostname. -} +setSshConfig :: SshData -> [(String, String)] -> IO SshData +setSshConfig sshdata config = do + sshdir <- sshDir + createDirectoryIfMissing True sshdir + let configfile = sshdir "config" + unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ + appendFile configfile $ unlines $ + [ "" + , "# Added automatically by git-annex" + , "Host " ++ mangledhost + ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) + (settings ++ config) + return $ sshdata { sshHostName = T.pack mangledhost } + where + mangledhost = mangleSshHostName sshdata + settings = + [ ("Hostname", T.unpack $ sshHostName sshdata) + , ("Port", show $ sshPort sshdata) + ] + +{- 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 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 "%" + - (the latter has special meaning to ssh). + -} +mangleSshHostName :: SshData -> String +mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata) + ++ "-" ++ escape extra + where + extra = intercalate "_" $ map T.unpack $ catMaybes + [ sshUserName sshdata + , Just $ sshDirectory sshdata + ] + safe c + | isAlphaNum c = True + | c == '_' = True + | otherwise = False + escape s = replace "%" "." $ escapeURIString safe s + +{- Extracts the real hostname from a mangled ssh hostname. -} +unMangleSshHostName :: String -> String +unMangleSshHostName h = case split "-" h of + ("git":"annex":rest) -> intercalate "-" (beginning rest) + _ -> h + +{- Does ssh have known_hosts data for a hostname? -} +knownHost :: Text -> IO Bool +knownHost hostname = do + sshdir <- sshDir + ifM (doesFileExist $ sshdir "known_hosts") + ( not . null <$> checkhost + , return False + ) + where + {- ssh-keygen -F can crash on some old known_hosts file -} + checkhost = catchDefaultIO "" $ + readProcess "ssh-keygen" ["-F", T.unpack hostname] diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs new file mode 100644 index 0000000000..f7656f52df --- /dev/null +++ b/Assistant/Sync.hs @@ -0,0 +1,276 @@ +{- git-annex assistant repo syncing + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Sync where + +import Assistant.Common +import Assistant.Pushes +import Assistant.NetMessager +import Assistant.Types.NetMessager +import Assistant.Alert +import Assistant.Alert.Utility +import Assistant.DaemonStatus +import Assistant.ScanRemotes +import qualified Command.Sync +import Utility.Parallel +import qualified Git +import qualified Git.Branch +import qualified Git.Command +import qualified Git.Ref +import qualified Remote +import qualified Types.Remote as Remote +import qualified Remote.List as Remote +import qualified Annex.Branch +import Annex.UUID +import Annex.TaggedPush +import qualified Config +import Git.Config +import Assistant.NamedThread +import Assistant.Threads.Watcher (watchThread, WatcherControl(..)) +import Assistant.TransferSlots +import Assistant.TransferQueue +import Assistant.RepoProblem +import Logs.Transfer + +import Data.Time.Clock +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Concurrent + +{- Syncs with remotes that may have been disconnected for a while. + - + - First gets git in sync, and then prepares any necessary file transfers. + - + - An expensive full scan is queued when the git-annex branches of some of + - the remotes have diverged from the local git-annex branch. Otherwise, + - it's sufficient to requeue failed transfers. + - + - XMPP remotes are also signaled that we can push to them, and we request + - they push to us. Since XMPP pushes run ansynchronously, any scan of the + - XMPP remotes has to be deferred until they're done pushing to us, so + - all XMPP remotes are marked as possibly desynced. + - + - Also handles signaling any connectRemoteNotifiers, after the syncing is + - done. + -} +reconnectRemotes :: Bool -> [Remote] -> Assistant () +reconnectRemotes _ [] = noop +reconnectRemotes notifypushes rs = void $ do + rs' <- liftIO $ filterM (Remote.checkAvailable True) rs + unless (null rs') $ do + modifyDaemonStatus_ $ \s -> s + { desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) } + failedrs <- syncAction rs' (const go) + forM_ failedrs $ \r -> + whenM (liftIO $ Remote.checkAvailable False r) $ + repoHasProblem (Remote.uuid r) (syncRemote r) + mapM_ signal $ filter (`notElem` failedrs) rs' + where + gitremotes = filter (notspecialremote . Remote.repo) rs + (xmppremotes, nonxmppremotes) = partition isXMPPRemote rs + notspecialremote r + | Git.repoIsUrl r = True + | Git.repoIsLocal r = True + | Git.repoIsLocalUnknown r = True + | otherwise = False + sync (Just branch) = do + (failedpull, diverged) <- manualPull (Just branch) gitremotes + now <- liftIO getCurrentTime + failedpush <- pushToRemotes' now notifypushes gitremotes + return (nub $ failedpull ++ failedpush, diverged) + {- No local branch exists yet, but we can try pulling. -} + sync Nothing = manualPull Nothing gitremotes + go = do + (failed, diverged) <- sync + =<< liftAnnex (inRepo Git.Branch.current) + addScanRemotes diverged $ + filter (not . remoteAnnexIgnore . Remote.gitconfig) + nonxmppremotes + return failed + signal r = liftIO . mapM_ (flip tryPutMVar ()) + =<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers + <$> getDaemonStatus + +{- Updates the local sync branch, then pushes it 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". + - + - After the pushes to normal git remotes, also signals XMPP clients that + - they can request an XMPP push. + - + - Avoids running possibly long-duration commands in the Annex monad, so + - as not to block other threads. + - + - This can fail, when the remote's sync branch (or git-annex branch) has + - been updated by some other remote pushing into it, or by the remote + - itself. To handle failure, a manual pull and merge is done, and the push + - is retried. + - + - When there's a lot of activity, we may fail more than once. + - On the other hand, we may fail because the remote is not available. + - Rather than retrying indefinitely, after the first retry we enter a + - fallback mode, where our push is guarenteed to succeed if the remote is + - reachable. If the fallback fails, the push is queued to be retried + - later. + - + - Returns any remotes that it failed to push to. + -} +pushToRemotes :: Bool -> [Remote] -> Assistant [Remote] +pushToRemotes notifypushes remotes = do + now <- liftIO getCurrentTime + syncAction remotes (pushToRemotes' now notifypushes) +pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote] +pushToRemotes' now notifypushes remotes = do + (g, branch, u) <- liftAnnex $ do + Annex.Branch.commit "update" + (,,) + <$> gitRepo + <*> inRepo Git.Branch.current + <*> getUUID + let (xmppremotes, normalremotes) = partition isXMPPRemote remotes + ret <- go True branch g u normalremotes + unless (null xmppremotes) $ do + shas <- liftAnnex $ map fst <$> + inRepo (Git.Ref.matchingWithHEAD + [Annex.Branch.fullname, Git.Ref.headRef]) + forM_ xmppremotes $ \r -> sendNetMessage $ + Pushing (getXMPPClientID r) (CanPush u shas) + return ret + where + go _ Nothing _ _ _ = return [] -- no branch, so nothing to 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 + then do + when notifypushes $ + sendNetMessage $ NotifyPush $ + map Remote.uuid succeeded + return failed + else if shouldretry + then retry branch g u failed + else fallback branch g u failed + + updatemap succeeded failed = changeFailedPushMap $ \m -> + M.union (makemap failed) $ + M.difference m (makemap succeeded) + makemap l = M.fromList $ zip l (repeat now) + + retry branch g u rs = do + debug ["trying manual pull to resolve failed pushes"] + void $ manualPull (Just branch) rs + go False (Just branch) g u rs + + fallback branch g u rs = do + debug ["fallback pushing to", show rs] + (succeeded, failed) <- liftIO $ + inParallel (\r -> taggedPush u Nothing branch r g) rs + updatemap succeeded failed + when (notifypushes && (not $ null succeeded)) $ + sendNetMessage $ NotifyPush $ + map Remote.uuid succeeded + return failed + + push g branch remote = Command.Sync.pushBranch remote branch g + +{- Displays an alert while running an action that syncs with some remotes, + - and returns any remotes that it failed to sync with. + - + - XMPP remotes are handled specially; since the action can only start + - an async process for them, they are not included in the alert, but are + - still passed to the action. + - + - Readonly remotes are also hidden (to hide the web special remote). + -} +syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote] +syncAction rs a + | null visibleremotes = a rs + | otherwise = do + i <- addAlert $ syncAlert visibleremotes + failed <- a rs + let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed + let succeeded = filter (`notElem` failed) visibleremotes + if null succeeded && null failed' + then removeAlert i + else updateAlertMap $ mergeAlert i $ + syncResultAlert succeeded failed' + return failed + where + visibleremotes = filter (not . Remote.readonly) $ + filter (not . isXMPPRemote) rs + +{- Manually pull from remotes and merge their branches. Returns any + - remotes that it failed to pull from, and a Bool indicating + - whether the git-annex branches of the remotes and local had + - diverged before the pull. + - + - After pulling from the normal git remotes, requests pushes from any + - XMPP remotes. However, those pushes will run asynchronously, so their + - results are not included in the return data. + -} +manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool) +manualPull currentbranch remotes = do + g <- liftAnnex gitRepo + let (xmppremotes, normalremotes) = partition isXMPPRemote remotes + failed <- liftIO $ forM normalremotes $ \r -> + ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g) + ( return Nothing + , return $ Just r + ) + haddiverged <- liftAnnex Annex.Branch.forceUpdate + forM_ normalremotes $ \r -> + liftAnnex $ Command.Sync.mergeRemote r currentbranch + u <- liftAnnex getUUID + forM_ xmppremotes $ \r -> + sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u) + return (catMaybes failed, haddiverged) + +{- Start syncing a remote, using a background thread. -} +syncRemote :: Remote -> Assistant () +syncRemote remote = do + updateSyncRemotes + thread <- asIO $ do + reconnectRemotes False [remote] + addScanRemotes True [remote] + void $ liftIO $ forkIO $ thread + +{- Use Nothing to change autocommit setting; or a remote to change + - its sync setting. -} +changeSyncable :: Maybe Remote -> Bool -> Assistant () +changeSyncable Nothing enable = do + liftAnnex $ Config.setConfig key (boolConfig enable) + liftIO . maybe noop (`throwTo` signal) + =<< namedThreadId watchThread + where + key = Config.annexConfig "autocommit" + signal + | enable = ResumeWatcher + | otherwise = PauseWatcher +changeSyncable (Just r) True = do + liftAnnex $ changeSyncFlag r True + syncRemote r +changeSyncable (Just r) False = do + liftAnnex $ changeSyncFlag r False + updateSyncRemotes + {- Stop all transfers to or from this remote. + - XXX Can't stop any ongoing scan, or git syncs. -} + void $ dequeueTransfers tofrom + mapM_ (cancelTransfer False) =<< + filter tofrom . M.keys . currentTransfers <$> getDaemonStatus + where + tofrom t = transferUUID t == Remote.uuid r + +changeSyncFlag :: Remote -> Bool -> Annex () +changeSyncFlag r enabled = do + Config.setConfig key (boolConfig enabled) + void Remote.remoteListRefresh + where + key = Config.remoteConfig (Remote.repo r) "sync" diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs new file mode 100644 index 0000000000..695703e224 --- /dev/null +++ b/Assistant/Threads/Committer.hs @@ -0,0 +1,493 @@ +{- git-annex assistant commit thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Threads.Committer where + +import Assistant.Common +import Assistant.Changes +import Assistant.Types.Changes +import Assistant.Commits +import Assistant.Alert +import Assistant.DaemonStatus +import Assistant.TransferQueue +import Assistant.Drop +import Logs.Transfer +import Logs.Location +import qualified Annex.Queue +import qualified Git.Command +import qualified Git.LsFiles +import qualified Git.BuildVersion +import qualified Command.Add +import Utility.ThreadScheduler +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 +import qualified Annex +import Utility.InodeCache +import Annex.Content.Direct + +import Data.Time.Clock +import Data.Tuple.Utils +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Either +import Control.Concurrent + +{- This thread makes git commits at appropriate times. -} +commitThread :: NamedThread +commitThread = namedThread "Committer" $ do + delayadd <- liftAnnex $ + maybe delayaddDefault (return . Just . Seconds) + =<< annexDelayAdd <$> Annex.getGitConfig + waitChangeTime $ \(changes, time) -> do + readychanges <- handleAdds delayadd changes + if shouldCommit time (length readychanges) readychanges + then do + debug + [ "committing" + , show (length readychanges) + , "changes" + ] + void $ alertWhile commitAlert $ + liftAnnex commitStaged + recordCommit + let numchanges = length readychanges + mapM_ checkChangeContent readychanges + return numchanges + else do + refill readychanges + return 0 + +refill :: [Change] -> Assistant () +refill [] = noop +refill cs = do + debug ["delaying commit of", show (length cs), "changes"] + refillChanges cs + +{- Wait for one or more changes to arrive to be committed, and then + - runs an action to commit them. If more changes arrive while this is + - going on, they're handled intelligently, batching up changes into + - large commits where possible, doing rename detection, and + - commiting immediately otherwise. -} +waitChangeTime :: (([Change], UTCTime) -> Assistant Int) -> Assistant () +waitChangeTime a = waitchanges 0 + where + waitchanges lastcommitsize = do + -- Wait one one second as a simple rate limiter. + liftIO $ threadDelaySeconds (Seconds 1) + -- Now, wait until at least one change is available for + -- processing. + cs <- getChanges + handlechanges cs lastcommitsize + handlechanges changes lastcommitsize = do + let len = length changes + -- See if now's a good time to commit. + now <- liftIO getCurrentTime + case (lastcommitsize >= maxCommitSize, shouldCommit now len changes, possiblyrename changes) of + (True, True, _) + | len > maxCommitSize -> + waitchanges =<< a (changes, now) + | otherwise -> aftermaxcommit changes + (_, True, False) -> + waitchanges =<< a (changes, now) + (_, True, True) -> do + morechanges <- getrelatedchanges changes + waitchanges =<< a (changes ++ morechanges, now) + _ -> do + refill changes + waitchanges lastcommitsize + + {- Did we perhaps only get one of the AddChange and RmChange pair + - that make up a file rename? Or some of the pairs that make up + - a directory rename? + -} + possiblyrename = all renamepart + + renamepart (PendingAddChange _ _) = True + renamepart c = isRmChange c + + {- Gets changes related to the passed changes, without blocking + - very long. + - + - If there are multiple RmChanges, this is probably a directory + - rename, in which case it may be necessary to wait longer to get + - all the Changes involved. + -} + getrelatedchanges oldchanges + | length (filter isRmChange oldchanges) > 1 = + concat <$> getbatchchanges [] + | otherwise = do + liftIO humanImperceptibleDelay + getAnyChanges + getbatchchanges cs = do + liftIO $ threadDelay $ fromIntegral $ oneSecond `div` 10 + cs' <- getAnyChanges + if null cs' + then return cs + else getbatchchanges (cs':cs) + + {- The last commit was maximum size, so it's very likely there + - are more changes and we'd like to ensure we make another commit + - of maximum size if possible. + - + - But, it can take a while for the Watcher to wake back up + - after a commit. It can get blocked by another thread + - that is using the Annex state, such as a git-annex branch + - commit. Especially after such a large commit, this can + - take several seconds. When this happens, it defeats the + - normal commit batching, which sees some old changes the + - Watcher found while the commit was being prepared, and sees + - no recent ones, and wants to commit immediately. + - + - All that we need to do, then, is wait for the Watcher to + - wake up, and queue up one more change. + - + - However, it's also possible that we're at the end of changes for + - now. So to avoid waiting a really long time before committing + - those changes we have, poll for up to 30 seconds, and then + - commit them. + - + - Also, try to run something in Annex, to ensure we block + - longer if the Annex state is indeed blocked. + -} + aftermaxcommit oldchanges = loop (30 :: Int) + where + loop 0 = continue oldchanges + loop n = do + liftAnnex noop -- ensure Annex state is free + liftIO $ threadDelaySeconds (Seconds 1) + changes <- getAnyChanges + if null changes + then loop (n - 1) + else continue (oldchanges ++ changes) + continue cs + | null cs = waitchanges 0 + | otherwise = handlechanges cs 0 + +isRmChange :: Change -> Bool +isRmChange (Change { changeInfo = i }) | i == RmChange = True +isRmChange _ = False + +{- An amount of time that is hopefully imperceptably short for humans, + - while long enough for a computer to get some work done. + - Note that 0.001 is a little too short for rename change batching to + - work. -} +humanImperceptibleInterval :: NominalDiffTime +humanImperceptibleInterval = 0.01 + +humanImperceptibleDelay :: IO () +humanImperceptibleDelay = threadDelay $ + truncate $ humanImperceptibleInterval * fromIntegral oneSecond + +maxCommitSize :: Int +maxCommitSize = 5000 + +{- Decide if now is a good time to make a commit. + - Note that the list of changes has an undefined order. + - + - Current strategy: If there have been 10 changes within the past second, + - a batch activity is taking place, so wait for later. + -} +shouldCommit :: UTCTime -> Int -> [Change] -> Bool +shouldCommit now len changes + | len == 0 = False + | len >= maxCommitSize = True + | length recentchanges < 10 = True + | otherwise = False -- batch activity + where + thissecond c = timeDelta c <= 1 + recentchanges = filter thissecond changes + timeDelta c = now `diffUTCTime` changeTime c + +commitStaged :: Annex Bool +commitStaged = do + {- This could fail if there's another commit being made by + - something else. -} + v <- tryAnnex Annex.Queue.flush + case v of + Left _ -> return False + Right _ -> do + {- Empty commits may be made if tree changes cancel + - each other out, etc. Git returns nonzero on those, + - so don't propigate out commit failures. -} + void $ inRepo $ catchMaybeIO . + Git.Command.runQuiet + (Param "commit" : nomessage params) + return True + where + params = + [ Param "--quiet" + {- Avoid running the usual pre-commit hook; + - the Watcher does the same symlink fixing, + - and direct mode bookkeeping updating. -} + , Param "--no-verify" + ] + nomessage ps + | Git.BuildVersion.older "1.7.2" = + Param "-m" : Param "autocommit" : ps + | Git.BuildVersion.older "1.7.8" = + Param "--allow-empty-message" : + Param "-m" : Param "" : ps + | otherwise = + Param "--allow-empty-message" : + Param "--no-edit" : Param "-m" : Param "" : ps + +{- 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 + - try to set file permissions or otherwise access the file after closing + - it. -} +delayaddDefault :: Annex (Maybe Seconds) +#ifdef darwin_HOST_OS +delayaddDefault = ifM isDirect + ( return Nothing + , return $ Just $ Seconds 1 + ) +#else +delayaddDefault = return Nothing +#endif + +{- If there are PendingAddChanges, or InProcessAddChanges, the files + - have not yet actually been added to the annex, and that has to be done + - now, before committing. + - + - Deferring the adds to this point causes batches to be bundled together, + - which allows faster checking with lsof that the files are not still open + - for write by some other process, and faster checking with git-ls-files + - that the files are not already checked into git. + - + - When a file is added, Inotify will notice the new symlink. So this waits + - for additional Changes to arrive, so that the symlink has hopefully been + - staged before returning, and will be committed immediately. + - + - OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly + - created and staged. + - + - Returns a list of all changes that are ready to be committed. + - Any pending adds that are not ready yet are put back into the ChangeChan, + - where they will be retried later. + -} +handleAdds :: Maybe Seconds -> [Change] -> Assistant [Change] +handleAdds delayadd cs = returnWhen (null incomplete) $ do + let (pending, inprocess) = partition isPendingAddChange incomplete + direct <- liftAnnex isDirect + (pending', cleanup) <- if direct + then return (pending, noop) + else findnew pending + (postponed, toadd) <- partitionEithers <$> safeToAdd delayadd pending' inprocess + cleanup + + unless (null postponed) $ + refillChanges postponed + + returnWhen (null toadd) $ do + added <- addaction toadd $ + catMaybes <$> if direct + then adddirect toadd + else forM toadd add + if DirWatcher.eventsCoalesce || null added || direct + then return $ added ++ otherchanges + else do + r <- handleAdds delayadd =<< getChanges + return $ r ++ added ++ otherchanges + where + (incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs + + findnew [] = return ([], noop) + findnew pending@(exemplar:_) = do + (newfiles, cleanup) <- liftAnnex $ + inRepo (Git.LsFiles.notInRepo False $ map changeFile pending) + -- note: timestamp info is lost here + let ts = changeTime exemplar + return (map (PendingAddChange ts) newfiles, void $ liftIO cleanup) + + returnWhen c a + | c = return otherchanges + | otherwise = a + + add :: Change -> Assistant (Maybe Change) + add change@(InProcessAddChange { keySource = ks }) = + catchDefaultIO Nothing <~> doadd + where + doadd = sanitycheck ks $ do + (mkey, mcache) <- liftAnnex $ do + showStart "add" $ keyFilename ks + Command.Add.ingest $ Just ks + maybe (failedingest change) (done change mcache $ keyFilename ks) mkey + add _ = return Nothing + + {- In direct mode, avoid overhead of re-injesting a renamed + - file, by examining the other Changes to see if a removed + - file has the same InodeCache as the new file. If so, + - we can just update bookkeeping, and stage the file in git. + -} + adddirect :: [Change] -> Assistant [Maybe Change] + adddirect toadd = do + ct <- liftAnnex compareInodeCachesWith + m <- liftAnnex $ removedKeysMap ct cs + if M.null m + then forM toadd add + else forM toadd $ \c -> do + mcache <- liftIO $ genInodeCache $ changeFile c + case mcache of + Nothing -> add c + Just cache -> + case M.lookup (inodeCacheToKey ct cache) m of + Nothing -> add c + Just k -> fastadd c k + + fastadd :: Change -> Key -> Assistant (Maybe Change) + fastadd change key = do + let source = keySource change + liftAnnex $ Command.Add.finishIngestDirect key source + done change Nothing (keyFilename source) key + + removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) + removedKeysMap ct l = do + mks <- forM (filter isRmChange l) $ \c -> + catKeyFile $ changeFile c + M.fromList . concat <$> mapM mkpairs (catMaybes mks) + where + mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> + recordedInodeCache k + + failedingest change = do + refill [retryChange change] + liftAnnex showEndFail + return Nothing + + done change mcache file key = liftAnnex $ do + logStatus key InfoPresent + link <- ifM isDirect + ( inRepo $ gitAnnexLink file key + , Command.Add.link file key mcache + ) + whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ + stageSymlink file =<< hashSymlink link + showEndOk + return $ Just $ finishedChange change key + + {- Check that the keysource's keyFilename still exists, + - and is still a hard link to its contentLocation, + - before ingesting it. -} + sanitycheck keysource a = do + fs <- liftIO $ getSymbolicLinkStatus $ keyFilename keysource + ks <- liftIO $ getSymbolicLinkStatus $ contentLocation keysource + if deviceID ks == deviceID fs && fileID ks == fileID fs + then a + else do + -- remove the hard link + when (contentLocation keysource /= keyFilename keysource) $ + void $ liftIO $ tryIO $ removeFile $ contentLocation keysource + return Nothing + + {- Shown an alert while performing an action to add a file or + - files. When only a few files are added, their names are shown + - in the alert. When it's a batch add, the number of files added + - is shown. + - + - Add errors tend to be transient and will be + - automatically dealt with, so the alert is always told + - the add succeeded. + -} + addaction [] a = a + addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $ + (,) + <$> pure True + <*> a + +{- Files can Either be Right to be added now, + - or are unsafe, and must be Left for later. + - + - Check by running lsof on the repository. + -} +safeToAdd :: Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] +safeToAdd _ [] [] = return [] +safeToAdd delayadd pending inprocess = do + maybe noop (liftIO . threadDelaySeconds) delayadd + liftAnnex $ do + keysources <- forM pending $ Command.Add.lockDown . changeFile + let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending keysources) + openfiles <- S.fromList . map fst3 . filter openwrite <$> + findopenfiles (map keySource inprocess') + let checked = map (check openfiles) inprocess' + + {- If new events are received when files are closed, + - there's no need to retry any changes that cannot + - be done now. -} + if DirWatcher.closingTracked + then do + mapM_ canceladd $ lefts checked + allRight $ rights checked + else return checked + where + check openfiles change@(InProcessAddChange { keySource = ks }) + | S.member (contentLocation ks) openfiles = Left change + check _ change = Right change + + mkinprocess (c, Just ks) = Just InProcessAddChange + { changeTime = changeTime c + , keySource = ks + } + mkinprocess (_, Nothing) = Nothing + + canceladd (InProcessAddChange { keySource = ks }) = do + warning $ keyFilename ks + ++ " still has writers, not adding" + -- remove the hard link + when (contentLocation ks /= keyFilename ks) $ + void $ liftIO $ tryIO $ removeFile $ contentLocation ks + canceladd _ = noop + + openwrite (_file, mode, _pid) + | mode == Lsof.OpenWriteOnly = True + | mode == Lsof.OpenReadWrite = True + | mode == Lsof.OpenUnknown = True + | otherwise = False + + allRight = return . map Right + + {- Normally the KeySources are locked down inside the temp directory, + - so can just lsof that, which is quite efficient. + - + - In crippled filesystem mode, there is no lock down, so must run lsof + - on each individual file. + -} + findopenfiles keysources = ifM crippledFileSystem + ( liftIO $ do + let segments = segmentXargs $ map keyFilename keysources + concat <$> forM segments (\fs -> Lsof.query $ "--" : fs) + , do + tmpdir <- fromRepo gitAnnexTmpDir + liftIO $ Lsof.queryDir tmpdir + ) + +{- After a Change is committed, queue any necessary transfers or drops + - of the content of the key. + - + - This is not done during the startup scan, because the expensive + - transfer scan does the same thing then. + -} +checkChangeContent :: Change -> Assistant () +checkChangeContent change@(Change { changeInfo = i }) = + case changeInfoKey i of + Nothing -> noop + Just k -> whenM (scanComplete <$> getDaemonStatus) $ do + present <- liftAnnex $ inAnnex k + if present + then queueTransfers "new file created" Next k (Just f) Upload + else queueTransfers "new or renamed file wanted" Next k (Just f) Download + handleDrops "file renamed" present k (Just f) Nothing + where + f = changeFile change +checkChangeContent _ = noop diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs new file mode 100644 index 0000000000..c180c4da92 --- /dev/null +++ b/Assistant/Threads/ConfigMonitor.hs @@ -0,0 +1,87 @@ +{- git-annex assistant config monitor thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.ConfigMonitor where + +import Assistant.Common +import Assistant.BranchChange +import Assistant.DaemonStatus +import Assistant.Commits +import Utility.ThreadScheduler +import Logs +import Logs.UUID +import Logs.Trust +import Logs.PreferredContent +import Logs.Group +import Remote.List (remoteListRefresh) +import qualified Git.LsTree as LsTree +import Git.FilePath +import qualified Annex.Branch + +import qualified Data.Set as S + +{- This thread detects when configuration changes have been made to the + - git-annex branch and reloads cached configuration. + - + - If the branch is frequently changing, it's checked for configuration + - changes no more often than once every 60 seconds. On the other hand, + - if the branch has not changed in a while, configuration changes will + - be detected immediately. + -} +configMonitorThread :: NamedThread +configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs + where + loop old = do + waitBranchChange + new <- getConfigs + when (old /= new) $ do + let changedconfigs = new `S.difference` old + debug $ "reloading config" : + map fst (S.toList changedconfigs) + reloadConfigs new + {- Record a commit to get this config + - change pushed out to remotes. -} + recordCommit + liftIO $ threadDelaySeconds (Seconds 60) + loop new + +{- Config files, and their checksums. -} +type Configs = S.Set (FilePath, String) + +{- All git-annex's config files, and actions to run when they change. -} +configFilesActions :: [(FilePath, Assistant ())] +configFilesActions = + [ (uuidLog, void $ liftAnnex uuidMapLoad) + , (remoteLog, void $ liftAnnex remoteListRefresh) + , (trustLog, void $ liftAnnex trustMapLoad) + , (groupLog, void $ liftAnnex groupMapLoad) + , (scheduleLog, void updateScheduleLog) + -- Preferred content settings depend on most of the other configs, + -- so will be reloaded whenever any configs change. + , (preferredContentLog, noop) + ] + +reloadConfigs :: Configs -> Assistant () +reloadConfigs changedconfigs = do + sequence_ as + void $ liftAnnex preferredContentMapLoad + {- 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. -} + when (any (`elem` fs) [remoteLog, trustLog, uuidLog]) + updateSyncRemotes + where + (fs, as) = unzip $ filter (flip S.member changedfiles . fst) + configFilesActions + changedfiles = S.map fst changedconfigs + +getConfigs :: Assistant Configs +getConfigs = S.fromList . map extract + <$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files) + where + files = map fst configFilesActions + extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs new file mode 100644 index 0000000000..55b3ca2f10 --- /dev/null +++ b/Assistant/Threads/Cronner.hs @@ -0,0 +1,225 @@ +{- git-annex assistant sceduled jobs runner + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE DeriveDataTypeable #-} + +module Assistant.Threads.Cronner ( + cronnerThread +) where + +import Assistant.Common +import Assistant.DaemonStatus +import Utility.NotificationBroadcaster +import Annex.UUID +import Config.Files +import Logs.Schedule +import Utility.Scheduled +import Types.ScheduledActivity +import Utility.ThreadScheduler +import Utility.HumanTime +import Utility.Batch +import Assistant.TransferQueue +import Annex.Content +import Logs.Transfer +import Assistant.Types.UrlRenderer +import Assistant.Alert +import Remote +import qualified Types.Remote as Remote +import qualified Git +import qualified Git.Fsck +import Assistant.Fsck +import Assistant.Repair + +import Control.Concurrent.Async +import Control.Concurrent.MVar +import Data.Time.LocalTime +import Data.Time.Clock +import qualified Data.Map as M +import qualified Data.Set as S + +{- Loads schedules for this repository, and fires off one thread for each + - scheduled event that runs on this repository. Each thread sleeps until + - its event is scheduled to run. + - + - To handle events that run on remotes, which need to only run when + - their remote gets connected, threads are also started, and are passed + - a MVar to wait on, which is stored in the DaemonStatus's + - connectRemoteNotifiers. + - + - In the meantime the main thread waits for any changes to the + - schedules. When there's a change, compare the old and new list of + - schedules to find deleted and added ones. Start new threads for added + - ones, and kill the threads for deleted ones. -} +cronnerThread :: UrlRenderer -> NamedThread +cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do + fsckNudge urlrenderer Nothing + dstatus <- getDaemonStatus + h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus) + go h M.empty M.empty + where + go h amap nmap = do + activities <- liftAnnex $ scheduleGet =<< getUUID + + let addedactivities = activities `S.difference` M.keysSet amap + let removedactivities = M.keysSet amap `S.difference` activities + + forM_ (S.toList removedactivities) $ \activity -> + case M.lookup activity amap of + Just a -> do + debug ["stopping removed job for", fromScheduledActivity activity, show (asyncThreadId a)] + liftIO $ cancel a + Nothing -> noop + + lastruntimes <- liftAnnex getLastRunTimes + started <- startactivities (S.toList addedactivities) lastruntimes + let addedamap = M.fromList $ map fst started + let addednmap = M.fromList $ catMaybes $ map snd started + + let removefiltered = M.filterWithKey (\k _ -> S.member k removedactivities) + let amap' = M.difference (M.union addedamap amap) (removefiltered amap) + let nmap' = M.difference (M.union addednmap nmap) (removefiltered nmap) + modifyDaemonStatus_ $ \s -> s { connectRemoteNotifiers = M.fromListWith (++) (M.elems nmap') } + + liftIO $ waitNotification h + debug ["reloading changed activities"] + go h amap' nmap' + startactivities as lastruntimes = forM as $ \activity -> + case connectActivityUUID activity of + Nothing -> do + runner <- asIO2 (sleepingActivityThread urlrenderer) + a <- liftIO $ async $ + runner activity (M.lookup activity lastruntimes) + return ((activity, a), Nothing) + Just u -> do + mvar <- liftIO newEmptyMVar + runner <- asIO2 (remoteActivityThread urlrenderer mvar) + a <- liftIO $ async $ + runner activity (M.lookup activity lastruntimes) + return ((activity, a), Just (activity, (u, [mvar]))) + +{- Calculate the next time the activity is scheduled to run, then + - sleep until that time, and run it. Then call setLastRunTime, and + - loop. + -} +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] + go l (Just (NextTimeExactly t)) = waitrun l t Nothing + go l (Just (NextTimeWindow windowstart windowend)) = + waitrun l windowstart (Just windowend) + desc = fromScheduledActivity activity + schedule = getSchedule activity + waitrun l t mmaxt = do + seconds <- liftIO $ secondsUntilLocalTime t + when (seconds > Seconds 0) $ do + debug ["waiting", show seconds, "for next scheduled", desc] + liftIO $ threadDelaySeconds seconds + now <- liftIO getCurrentTime + tz <- liftIO $ getTimeZone now + let nowt = utcToLocalTime tz now + if tolate nowt tz + then do + debug ["too late to run scheduled", desc] + go l =<< getnexttime l + else run nowt + where + tolate nowt tz = case mmaxt of + Just maxt -> nowt > maxt + -- allow the job to start 10 minutes late + Nothing ->diffUTCTime + (localTimeToUTC tz nowt) + (localTimeToUTC tz t) > 600 + run nowt = do + runActivity urlrenderer activity nowt + go (Just nowt) =<< getnexttime (Just nowt) + +{- Wait for the remote to become available by waiting on the MVar. + - Then check if the time is within a time window when activity + - is scheduled to run, and if so run it. + - Otherwise, just wait again on the MVar. + -} +remoteActivityThread :: UrlRenderer -> MVar () -> ScheduledActivity -> Maybe LocalTime -> Assistant () +remoteActivityThread urlrenderer mvar activity lasttime = do + liftIO $ takeMVar mvar + go =<< liftIO (nextTime (getSchedule activity) lasttime) + where + go (Just (NextTimeWindow windowstart windowend)) = do + now <- liftIO getCurrentTime + tz <- liftIO $ getTimeZone now + if now >= localTimeToUTC tz windowstart && now <= localTimeToUTC tz windowend + then do + let nowt = utcToLocalTime tz now + runActivity urlrenderer activity nowt + loop (Just nowt) + else loop lasttime + go _ = noop -- running at exact time not handled here + loop = remoteActivityThread urlrenderer mvar activity + +secondsUntilLocalTime :: LocalTime -> IO Seconds +secondsUntilLocalTime t = do + now <- getCurrentTime + tz <- getTimeZone now + let secs = truncate $ diffUTCTime (localTimeToUTC tz t) now + return $ if secs > 0 + then Seconds secs + else Seconds 0 + +runActivity :: UrlRenderer -> ScheduledActivity -> LocalTime -> Assistant () +runActivity urlrenderer activity nowt = do + debug ["starting", desc] + runActivity' urlrenderer activity + debug ["finished", desc] + liftAnnex $ setLastRunTime activity nowt + where + desc = fromScheduledActivity activity + +runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant () +runActivity' urlrenderer (ScheduledSelfFsck _ d) = do + program <- liftIO $ readProgramFile + g <- liftAnnex gitRepo + fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do + void $ batchCommand program (Param "fsck" : annexFsckParams d) + Git.Fsck.findBroken True g + u <- liftAnnex getUUID + void $ repairWhenNecessary urlrenderer u Nothing fsckresults + 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) + 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 + Nothing -> go rmt $ do + program <- readProgramFile + void $ batchCommand program $ + [ Param "fsck" + -- avoid downloading files + , Param "--fast" + , Param "--from" + , Param $ Remote.name rmt + ] ++ annexFsckParams d + Just mkfscker -> do + {- Note that having mkfsker return an IO action + - avoids running a long duration fsck in the + - Annex monad. -} + go rmt =<< liftAnnex (mkfscker (annexFsckParams d)) + go rmt annexfscker = do + fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do + void annexfscker + let r = Remote.repo rmt + if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) + then Just <$> Git.Fsck.findBroken True r + else pure Nothing + maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults + +annexFsckParams :: Duration -> [CommandParam] +annexFsckParams d = + [ Param "--incremental-schedule=1d" + , Param $ "--time-limit=" ++ fromDuration d + ] diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs new file mode 100644 index 0000000000..5bbb15acbe --- /dev/null +++ b/Assistant/Threads/DaemonStatus.hs @@ -0,0 +1,29 @@ +{- git-annex assistant daemon status thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.DaemonStatus where + +import Assistant.Common +import Assistant.DaemonStatus +import Utility.ThreadScheduler +import Utility.NotificationBroadcaster + +{- This writes the daemon status to disk, when it changes, but no more + - frequently than once every ten minutes. + -} +daemonStatusThread :: NamedThread +daemonStatusThread = namedThread "DaemonStatus" $ do + notifier <- liftIO . newNotificationHandle False + =<< changeNotifier <$> getDaemonStatus + checkpoint + runEvery (Seconds tenMinutes) <~> do + liftIO $ waitNotification notifier + checkpoint + where + checkpoint = do + file <- liftAnnex $ fromRepo gitAnnexDaemonStatusFile + liftIO . writeDaemonStatusFile file =<< getDaemonStatus diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs new file mode 100644 index 0000000000..4c4012a676 --- /dev/null +++ b/Assistant/Threads/Glacier.hs @@ -0,0 +1,43 @@ +{- git-annex assistant Amazon Glacier retrieval + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Assistant.Threads.Glacier where + +import Assistant.Common +import Utility.ThreadScheduler +import qualified Types.Remote as Remote +import qualified Remote.Glacier as Glacier +import Logs.Transfer +import Assistant.DaemonStatus +import Assistant.TransferQueue + +import qualified Data.Set as S + +{- Wakes up every half hour and checks if any glacier remotes have failed + - downloads. If so, runs glacier-cli to check if the files are now + - available, and queues the downloads. -} +glacierThread :: NamedThread +glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go + where + isglacier r = Remote.remotetype r == Glacier.remote + go = do + rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus + forM_ rs $ \r -> + check r =<< liftAnnex (getFailedTransfers $ Remote.uuid r) + check _ [] = noop + check r l = do + let keys = map getkey l + (availkeys, failedkeys) <- liftAnnex $ Glacier.jobList r keys + let s = S.fromList (failedkeys ++ availkeys) + let l' = filter (\p -> S.member (getkey p) s) l + forM_ l' $ \(t, info) -> do + liftAnnex $ removeFailedTransfer t + queueTransferWhenSmall "object available from glacier" (associatedFile info) t r + getkey = transferKey . fst diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs new file mode 100644 index 0000000000..3f4fcb0cca --- /dev/null +++ b/Assistant/Threads/Merger.hs @@ -0,0 +1,118 @@ +{- git-annex assistant git merge thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.Merger where + +import Assistant.Common +import Assistant.TransferQueue +import Assistant.BranchChange +import Assistant.DaemonStatus +import Assistant.ScanRemotes +import Utility.DirWatcher +import Utility.DirWatcher.Types +import qualified Annex.Branch +import qualified Git +import qualified Git.Branch +import qualified Command.Sync +import Annex.TaggedPush +import Remote (remoteFromUUID) + +import qualified Data.Set as S +import qualified Data.Text as T + +{- This thread watches for changes to .git/refs/, and handles incoming + - pushes. -} +mergeThread :: NamedThread +mergeThread = namedThread "Merger" $ do + g <- liftAnnex gitRepo + let dir = Git.localGitDir g "refs" + liftIO $ createDirectoryIfMissing True dir + let hook a = Just <$> asIO2 (runHandler a) + changehook <- hook onChange + errhook <- hook onErr + let hooks = mkWatchHooks + { addHook = changehook + , modifyHook = changehook + , errHook = errhook + } + void $ liftIO $ watchDir dir (const False) hooks id + debug ["watching", dir] + +type Handler = FilePath -> Assistant () + +{- Runs an action handler. + - + - Exceptions are ignored, otherwise a whole thread could be crashed. + -} +runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () +runHandler handler file _filestatus = + either (liftIO . print) (const noop) =<< tryIO <~> handler file + +{- Called when there's an error with inotify. -} +onErr :: Handler +onErr = error + +{- Called when a new branch ref is written, or a branch ref is modified. + - + - At startup, synthetic add events fire, causing this to run, but that's + - ok; it ensures that any changes pushed since the last time the assistant + - ran are merged in. + -} +onChange :: Handler +onChange file + | ".lock" `isSuffixOf` file = noop + | isAnnexBranch file = do + branchChanged + diverged <- liftAnnex Annex.Branch.forceUpdate + when diverged $ + unlessM handleDesynced $ + queueDeferredDownloads "retrying deferred download" Later + | "/synced/" `isInfixOf` file = + mergecurrent =<< liftAnnex (inRepo Git.Branch.current) + | otherwise = noop + where + changedbranch = fileToBranch file + + mergecurrent (Just current) + | equivBranches changedbranch current = do + debug + [ "merging", show changedbranch + , "into", show current + ] + void $ liftAnnex $ Command.Sync.mergeFrom changedbranch + mergecurrent _ = noop + + handleDesynced = case fromTaggedBranch changedbranch of + Nothing -> return False + Just (u, info) -> do + mr <- liftAnnex $ remoteFromUUID u + case mr of + Nothing -> return False + Just r -> do + s <- desynced <$> getDaemonStatus + if S.member u s || Just (T.unpack $ getXMPPClientID r) == info + then do + modifyDaemonStatus_ $ \st -> st + { desynced = S.delete u s } + addScanRemotes True [r] + return True + else return False + +equivBranches :: Git.Ref -> Git.Ref -> Bool +equivBranches x y = base x == base y + where + base = takeFileName . show + +isAnnexBranch :: FilePath -> Bool +isAnnexBranch f = n `isSuffixOf` f + where + n = '/' : show Annex.Branch.name + +fileToBranch :: FilePath -> Git.Ref +fileToBranch f = Git.Ref $ "refs" base + where + base = Prelude.last $ split "/refs/" f diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs new file mode 100644 index 0000000000..39ae67537f --- /dev/null +++ b/Assistant/Threads/MountWatcher.hs @@ -0,0 +1,195 @@ +{- git-annex assistant mount watcher, using either dbus or mtab polling + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Assistant.Threads.MountWatcher where + +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.Sync +import qualified Annex +import qualified Git +import Utility.ThreadScheduler +import Utility.Mounts +import Remote.List +import qualified Types.Remote as Remote +import Assistant.Types.UrlRenderer +import Assistant.Fsck + +import qualified Data.Set as S + +#if WITH_DBUS +import Utility.DBus +import DBus.Client +import DBus +import Data.Word (Word32) +import Control.Concurrent +import qualified Control.Exception as E +#else +#warning Building without dbus support; will use mtab polling +#endif + +mountWatcherThread :: UrlRenderer -> NamedThread +mountWatcherThread urlrenderer = namedThread "MountWatcher" $ +#if WITH_DBUS + dbusThread urlrenderer +#else + pollingThread urlrenderer +#endif + +#if WITH_DBUS + +dbusThread :: UrlRenderer -> Assistant () +dbusThread urlrenderer = do + runclient <- asIO1 go + r <- liftIO $ E.try $ runClient getSessionAddress runclient + either onerr (const noop) r + where + go client = ifM (checkMountMonitor client) + ( do + {- Store the current mount points in an MVar, to be + - compared later. We could in theory work out the + - mount point from the dbus message, but this is + - easier. -} + mvar <- liftIO $ newMVar =<< currentMountPoints + handleevent <- asIO1 $ \_event -> do + nowmounted <- liftIO $ currentMountPoints + wasmounted <- liftIO $ swapMVar mvar nowmounted + handleMounts urlrenderer wasmounted nowmounted + liftIO $ forM_ mountChanged $ \matcher -> + listen client matcher handleevent + , do + liftAnnex $ + warning "No known volume monitor available through dbus; falling back to mtab polling" + pollingThread urlrenderer + ) + onerr :: E.SomeException -> Assistant () + onerr e = do + {- If the session dbus fails, the user probably + - logged out of their desktop. Even if they log + - back in, we won't have access to the dbus + - session key, so polling is the best that can be + - done in this situation. -} + liftAnnex $ + warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" + pollingThread urlrenderer + +{- Examine the list of services connected to dbus, to see if there + - are any we can use to monitor mounts. If not, will attempt to start one. -} +checkMountMonitor :: Client -> Assistant Bool +checkMountMonitor client = do + running <- filter (`elem` usableservices) + <$> liftIO (listServiceNames client) + case running of + [] -> startOneService client startableservices + (service:_) -> do + debug [ "Using running DBUS service" + , service + , "to monitor mount events." + ] + return True + where + startableservices = [gvfs, gvfsgdu] + usableservices = startableservices ++ [kde] + gvfs = "org.gtk.Private.UDisks2VolumeMonitor" + gvfsgdu = "org.gtk.Private.GduVolumeMonitor" + kde = "org.kde.DeviceNotifications" + +startOneService :: Client -> [ServiceName] -> Assistant Bool +startOneService _ [] = return False +startOneService client (x:xs) = do + _ <- liftIO $ tryNonAsync $ callDBus client "StartServiceByName" + [toVariant x, toVariant (0 :: Word32)] + ifM (liftIO $ elem x <$> listServiceNames client) + ( do + debug + [ "Started DBUS service", x + , "to monitor mount events." + ] + return True + , startOneService client xs + ) + +{- Filter matching events recieved when drives are mounted and unmounted. -} +mountChanged :: [MatchRule] +mountChanged = [gvfs True, gvfs False, kde, kdefallback] + where + {- gvfs reliably generates this event whenever a + - drive is mounted/unmounted, whether automatically, or manually -} + gvfs mount = matchAny + { matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor" + , matchMember = Just $ if mount then "MountAdded" else "MountRemoved" + } + {- This event fires when KDE prompts the user what to do with a drive, + - but maybe not at other times. And it's not received -} + kde = matchAny + { matchInterface = Just "org.kde.Solid.Device" + , matchMember = Just "setupDone" + } + {- This event may not be closely related to mounting a drive, but it's + - observed reliably when a drive gets mounted or unmounted. -} + kdefallback = matchAny + { matchInterface = Just "org.kde.KDirNotify" + , matchMember = Just "enteredDirectory" + } + +#endif + +pollingThread :: UrlRenderer -> Assistant () +pollingThread urlrenderer = go =<< liftIO currentMountPoints + where + go wasmounted = do + liftIO $ threadDelaySeconds (Seconds 10) + nowmounted <- liftIO currentMountPoints + handleMounts urlrenderer wasmounted nowmounted + go nowmounted + +handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant () +handleMounts urlrenderer wasmounted nowmounted = + mapM_ (handleMount urlrenderer . mnt_dir) $ + S.toList $ newMountPoints wasmounted nowmounted + +handleMount :: UrlRenderer -> FilePath -> Assistant () +handleMount urlrenderer dir = do + debug ["detected mount of", dir] + rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir + mapM_ (fsckNudge urlrenderer . Just) rs + reconnectRemotes True rs + +{- Finds remotes located underneath the mount point. + - + - Updates state to include the remotes. + - + - The config of git remotes is re-read, as it may not have been available + - at startup time, or may have changed (it could even be a different + - repository at the same remote location..) + -} +remotesUnder :: FilePath -> Assistant [Remote] +remotesUnder dir = do + repotop <- liftAnnex $ fromRepo Git.repoPath + rs <- liftAnnex remoteList + pairs <- liftAnnex $ mapM (checkremote repotop) rs + let (waschanged, rs') = unzip pairs + when (or waschanged) $ do + liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = catMaybes rs' } + updateSyncRemotes + return $ mapMaybe snd $ filter fst pairs + where + checkremote repotop r = case Remote.localpath r of + Just p | dirContains dir (absPathFrom repotop p) -> + (,) <$> pure True <*> updateRemote r + _ -> return (False, Just r) + +type MountPoints = S.Set Mntent + +currentMountPoints :: IO MountPoints +currentMountPoints = S.fromList <$> getMounts + +newMountPoints :: MountPoints -> MountPoints -> MountPoints +newMountPoints old new = S.difference new old diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs new file mode 100644 index 0000000000..0d8442c696 --- /dev/null +++ b/Assistant/Threads/NetWatcher.hs @@ -0,0 +1,135 @@ +{- git-annex assistant network connection watcher, using dbus + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Assistant.Threads.NetWatcher where + +import Assistant.Common +import Assistant.Sync +import Utility.ThreadScheduler +import qualified Types.Remote as Remote +import Assistant.DaemonStatus + +#if WITH_DBUS +import Utility.DBus +import DBus.Client +import DBus +import Data.Word (Word32) +import Assistant.NetMessager +#else +#warning Building without dbus support; will poll for network connection changes +#endif + +netWatcherThread :: NamedThread +#if WITH_DBUS +netWatcherThread = thread dbusThread +#else +netWatcherThread = thread noop +#endif + where + thread = namedThread "NetWatcher" + +{- This is a fallback for when dbus cannot be used to detect + - network connection changes, but it also ensures that + - any networked remotes that may have not been routable for a + - 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. + -} +netWatcherFallbackThread :: NamedThread +netWatcherFallbackThread = namedThread "NetWatcherFallback" $ + runEvery (Seconds 3600) <~> handleConnection + +#if WITH_DBUS + +dbusThread :: Assistant () +dbusThread = do + handleerr <- asIO2 onerr + runclient <- asIO1 go + liftIO $ persistentClient getSystemAddress () handleerr runclient + where + go client = ifM (checkNetMonitor client) + ( do + listenNMConnections client <~> handleconn + listenWicdConnections client <~> handleconn + , do + liftAnnex $ + warning "No known network monitor available through dbus; falling back to polling" + ) + handleconn = do + debug ["detected network connection"] + notifyNetMessagerRestart + handleConnection + onerr e _ = do + liftAnnex $ + warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" + {- Wait, in hope that dbus will come back -} + liftIO $ threadDelaySeconds (Seconds 60) + +{- Examine the list of services connected to dbus, to see if there + - are any we can use to monitor network connections. -} +checkNetMonitor :: Client -> Assistant Bool +checkNetMonitor client = do + running <- liftIO $ filter (`elem` [networkmanager, wicd]) + <$> listServiceNames client + case running of + [] -> return False + (service:_) -> do + debug [ "Using running DBUS service" + , service + , "to monitor network connection events." + ] + return True + where + 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 + where + matcher = matchAny + { matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active" + , 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 + +{- Listens for new Wicd connections. -} +listenWicdConnections :: Client -> IO () -> IO () +listenWicdConnections client callback = + listen client matcher $ \event -> + when (any (== wicd_success) (signalBody event)) $ + callback + where + matcher = matchAny + { matchInterface = Just "org.wicd.daemon" + , matchMember = Just "ConnectResultsSent" + } + wicd_success = toVariant ("success" :: String) + +#endif + +handleConnection :: Assistant () +handleConnection = reconnectRemotes True =<< networkRemotes + +{- Network remotes to sync with. -} +networkRemotes :: Assistant [Remote] +networkRemotes = filter (isNothing . Remote.localpath) . syncRemotes + <$> getDaemonStatus diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs new file mode 100644 index 0000000000..cd95ab5a43 --- /dev/null +++ b/Assistant/Threads/PairListener.hs @@ -0,0 +1,160 @@ +{- git-annex assistant thread to listen for incoming pairing traffic + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.PairListener where + +import Assistant.Common +import Assistant.Pairing +import Assistant.Pairing.Network +import Assistant.Pairing.MakeRemote +import Assistant.WebApp (UrlRenderer) +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 + listener <- asIO1 $ go [] [] + liftIO $ withSocketsDo $ + runEvery (Seconds 60) $ void $ tryIO $ + listener =<< getsock + where + {- Note this can crash if there's no network interface, + - or only one like lo that doesn't support multicast. -} + getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort + + go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of + 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 + (_, True, _, _) -> do + debug ["ignoring message that looped back"] + go reqs cache sock + (_, _, False, _) -> go reqs cache sock + -- PairReq starts a pairing process, so a + -- new one is always heeded, even if + -- some other pairing is in process. + (_, _, _, PairReq) -> if m `elem` reqs + then go reqs (invalidateCache m cache) sock + else do + pairReqReceived verified urlrenderer m + go (m:take 10 reqs) (invalidateCache m cache) sock + (True, _, _, _) -> do + debug + ["ignoring out of order message" + , show (pairMsgStage m) + , "expected" + , show (succ . inProgressPairStage <$> pip) + ] + go reqs cache sock + (_, _, _, PairAck) -> do + cache' <- pairAckReceived verified pip m cache + go reqs cache' sock + (_,_ , _, PairDone) -> do + pairDoneReceived verified pip m + go reqs cache sock + + {- As well as verifying the message using the shared secret, + - check its UUID against the UUID we have stored. If + - they're the same, someone is sending bogus messages, + - which could be an attempt to brute force the shared secret. -} + verificationCheck _ Nothing = return (Nothing, False) + verificationCheck m (Just pip) + | not verified && sameuuid = do + liftAnnex $ warning + "detected possible pairing brute force attempt; disabled pairing" + stopSending pip + return (Nothing, False) + |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 + - same secret used before, a bogus PairDone is not sent. -} + invalidateCache msg = filter (not . verifiedPairMsg msg) + + getmsg sock c = do + (msg, n, _) <- recvFrom sock chunksz + if n < chunksz + then return $ c ++ msg + else getmsg sock $ c ++ msg + where + chunksz = 1024 + +{- Show an alert when a PairReq is seen. -} +pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant () +pairReqReceived True _ _ = noop -- ignore our own PairReq +pairReqReceived False urlrenderer msg = do + button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg) + void $ addAlert $ pairRequestReceivedAlert repo button + where + repo = pairRepo msg + +{- When a verified PairAck is seen, a host is ready to pair with us, and has + - already configured our ssh key. Stop sending PairReqs, finish the pairing, + - and send a single PairDone. -} +pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] +pairAckReceived True (Just pip) msg cache = do + stopSending pip + repodir <- repoPath <$> liftAnnex gitRepo + liftIO $ setupAuthorizedKeys msg repodir + finishedLocalPairing msg (inProgressSshKeyPair pip) + startSending pip PairDone $ multicastPairMsg + (Just 1) (inProgressSecret pip) (inProgressPairData pip) + return $ pip : take 10 cache +{- A stale PairAck might also be seen, after we've finished pairing. + - Perhaps our PairDone was not received. To handle this, we keep + - a cache of recently finished pairings, and re-send PairDone in + - response to stale PairAcks for them. -} +pairAckReceived _ _ msg cache = do + let pips = filter (verifiedPairMsg msg) cache + unless (null pips) $ + forM_ pips $ \pip -> + startSending pip PairDone $ multicastPairMsg + (Just 1) (inProgressSecret pip) (inProgressPairData pip) + return cache + +{- If we get a verified PairDone, the host has accepted our PairAck, and + - has paired with us. Stop sending PairAcks, and finish pairing with them. + - + - TODO: Should third-party hosts remove their pair request alert when they + - see a PairDone? + - Complication: The user could have already clicked on the alert and be + - entering the secret. Would be better to start a fresh pair request in this + - situation. + -} +pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant () +pairDoneReceived False _ _ = noop -- not verified +pairDoneReceived True Nothing _ = noop -- not in progress +pairDoneReceived True (Just pip) msg = do + stopSending pip + finishedLocalPairing msg (inProgressSshKeyPair pip) diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs new file mode 100644 index 0000000000..8095581a69 --- /dev/null +++ b/Assistant/Threads/ProblemFixer.hs @@ -0,0 +1,70 @@ +{- git-annex assistant thread to handle fixing problems with repositories + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.ProblemFixer ( + problemFixerThread +) where + +import Assistant.Common +import Assistant.Types.RepoProblem +import Assistant.RepoProblem +import Assistant.Types.UrlRenderer +import Assistant.Alert +import Remote +import qualified Types.Remote as Remote +import qualified Git.Fsck +import Assistant.Repair +import qualified Git +import Annex.UUID +import Utility.ThreadScheduler + +{- Waits for problems with a repo, and tries to fsck the repo and repair + - the problem. -} +problemFixerThread :: UrlRenderer -> NamedThread +problemFixerThread urlrenderer = namedThread "ProblemFixer" $ + go =<< getRepoProblems + where + go problems = do + mapM_ (handleProblem urlrenderer) problems + liftIO $ threadDelaySeconds (Seconds 60) + -- Problems may have been re-reported while they were being + -- fixed, so ignore those. If a new unique problem happened + -- 60 seconds after the last was fixed, we're unlikely + -- to do much good anyway. + go =<< filter (\p -> not (any (sameRepoProblem p) problems)) + <$> getRepoProblems + +handleProblem :: UrlRenderer -> RepoProblem -> Assistant () +handleProblem urlrenderer repoproblem = do + fixed <- ifM ((==) (problemUUID repoproblem) <$> liftAnnex getUUID) + ( handleLocalRepoProblem urlrenderer + , maybe (return False) (handleRemoteProblem urlrenderer) + =<< liftAnnex (remoteFromUUID $ problemUUID repoproblem) + ) + when fixed $ + liftIO $ afterFix repoproblem + +handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool +handleRemoteProblem urlrenderer rmt + | Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) = + ifM (liftIO $ checkAvailable True rmt) + ( do + fixedlocks <- repairStaleGitLocks r + fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ + Git.Fsck.findBroken True r + repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults + return $ fixedlocks || repaired + , return False + ) + | otherwise = return False + where + r = Remote.repo rmt + +{- This is not yet used, and should probably do a fsck. -} +handleLocalRepoProblem :: UrlRenderer -> Assistant Bool +handleLocalRepoProblem _urlrenderer = do + repairStaleGitLocks =<< liftAnnex gitRepo diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs new file mode 100644 index 0000000000..3ec922fe48 --- /dev/null +++ b/Assistant/Threads/Pusher.hs @@ -0,0 +1,49 @@ +{- git-annex assistant git pushing thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.Pusher where + +import Assistant.Common +import Assistant.Commits +import Assistant.Pushes +import Assistant.DaemonStatus +import Assistant.Sync +import Utility.ThreadScheduler +import qualified Remote +import qualified Types.Remote as Remote + +{- This thread retries pushes that failed before. -} +pushRetryThread :: NamedThread +pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do + -- We already waited half an hour, now wait until there are failed + -- pushes to retry. + topush <- getFailedPushesBefore (fromIntegral halfhour) + unless (null topush) $ do + debug ["retrying", show (length topush), "failed pushes"] + void $ pushToRemotes True topush + where + halfhour = 1800 + +{- This thread pushes git commits out to remotes soon after they are made. -} +pushThread :: NamedThread +pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do + -- We already waited two seconds as a simple rate limiter. + -- Next, wait until at least one commit has been made + void getCommits + -- Now see if now's a good time to push. + void $ pushToRemotes True =<< pushTargets + +{- We want to avoid pushing to remotes that are marked readonly. + - + - Also, avoid pushing to local remotes we can easily tell are not available, + - to avoid ugly messages when a removable drive is not attached. + -} +pushTargets :: Assistant [Remote] +pushTargets = liftIO . filterM (Remote.checkAvailable True) + =<< candidates <$> getDaemonStatus + where + candidates = filter (not . Remote.readonly) . syncGitRemotes diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs new file mode 100644 index 0000000000..b03298510a --- /dev/null +++ b/Assistant/Threads/SanityChecker.hs @@ -0,0 +1,158 @@ +{- git-annex assistant sanity checker + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.SanityChecker ( + sanityCheckerStartupThread, + sanityCheckerDailyThread, + sanityCheckerHourlyThread +) where + +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.Alert +import Assistant.Repair +import qualified Git.LsFiles +import qualified Git.Command +import qualified Git.Config +import Utility.ThreadScheduler +import qualified Assistant.Threads.Watcher as Watcher +import Utility.LogFile +import Utility.Batch +import Utility.NotificationBroadcaster +import Config +import Utility.HumanTime + +import Data.Time.Clock.POSIX + +{- This thread runs once at startup, and most other threads wait for it + - to finish. (However, the webapp thread does not, to prevent the UI + - being nonresponsive.) -} +sanityCheckerStartupThread :: Maybe Duration -> NamedThread +sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerStartup" $ do + {- Stale git locks can prevent commits from happening, etc. -} + void $ repairStaleGitLocks =<< liftAnnex gitRepo + + {- If there's a startup delay, it's done here. -} + liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay + + {- Notify other threads that the startup sanity check is done. -} + status <- getDaemonStatus + liftIO $ sendNotification $ startupSanityCheckNotifier status + +{- This thread wakes up hourly for inxepensive frequent sanity checks. -} +sanityCheckerHourlyThread :: NamedThread +sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do + liftIO $ threadDelaySeconds $ Seconds oneHour + hourlyCheck + +{- This thread wakes up daily to make sure the tree is in good shape. -} +sanityCheckerDailyThread :: NamedThread +sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do + waitForNextCheck + + debug ["starting sanity check"] + void $ alertWhile sanityCheckAlert go + debug ["sanity check complete"] + where + go = do + modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True } + + now <- liftIO getPOSIXTime -- before check started + r <- either showerr return =<< (tryIO . batch) <~> dailyCheck + + modifyDaemonStatus_ $ \s -> s + { sanityCheckRunning = False + , lastSanityCheck = Just now + } + + return r + + showerr e = do + liftAnnex $ warning $ show e + return False + +{- Only run one check per day, from the time of the last check. -} +waitForNextCheck :: Assistant () +waitForNextCheck = do + v <- lastSanityCheck <$> getDaemonStatus + now <- liftIO getPOSIXTime + liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v + where + calcdelay _ Nothing = oneDay + calcdelay now (Just lastcheck) + | lastcheck < now = max oneDay $ + oneDay - truncate (now - lastcheck) + | otherwise = oneDay + +{- It's important to stay out of the Annex monad as much as possible while + - running potentially expensive parts of this check, since remaining in it + - will block the watcher. -} +dailyCheck :: Assistant Bool +dailyCheck = do + g <- liftAnnex gitRepo + + -- Find old unstaged symlinks, and add them to git. + (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g + now <- liftIO getPOSIXTime + forM_ unstaged $ \file -> do + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + case ms of + Just s | toonew (statusChangeTime s) now -> noop + | isSymbolicLink s -> addsymlink file ms + _ -> noop + liftIO $ void cleanup + + {- Allow git-gc to run once per day. More frequent gc is avoided + - by default to avoid slowing things down. Only run repacks when 100x + - the usual number of loose objects are present; we tend + - 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.runBool + [ Param "-c", Param "gc.auto=670000" + , Param "gc" + , Param "--auto" + ] g + + return True + where + toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) + slop = fromIntegral tenMinutes + insanity msg = do + liftAnnex $ warning msg + void $ addAlert $ sanityCheckFixAlert msg + addsymlink file s = do + isdirect <- liftAnnex isDirect + Watcher.runHandler (Watcher.onAddSymlink isdirect) file s + insanity $ "found unstaged symlink: " ++ file + +hourlyCheck :: Assistant () +hourlyCheck = checkLogSize 0 + +{- Rotate logs until log file size is < 1 mb. -} +checkLogSize :: Int -> Assistant () +checkLogSize n = do + f <- liftAnnex $ fromRepo gitAnnexLogFile + logs <- liftIO $ listLogs f + totalsize <- liftIO $ sum <$> mapM filesize logs + when (totalsize > oneMegabyte) $ do + notice ["Rotated logs due to size:", show totalsize] + liftIO $ openLog f >>= redirLog + when (n < maxLogs + 1) $ + checkLogSize $ n + 1 + where + filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f) + +oneMegabyte :: Int +oneMegabyte = 1000000 + +oneHour :: Int +oneHour = 60 * 60 + +oneDay :: Int +oneDay = 24 * oneHour + diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs new file mode 100644 index 0000000000..68075cac8a --- /dev/null +++ b/Assistant/Threads/TransferPoller.hs @@ -0,0 +1,56 @@ +{- git-annex assistant transfer polling thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.TransferPoller where + +import Assistant.Common +import Assistant.DaemonStatus +import Logs.Transfer +import Utility.NotificationBroadcaster +import qualified Assistant.Threads.TransferWatcher as TransferWatcher + +import Control.Concurrent +import qualified Data.Map as M + +{- This thread polls the status of ongoing transfers, determining how much + - of each transfer is complete. -} +transferPollerThread :: NamedThread +transferPollerThread = namedThread "TransferPoller" $ do + g <- liftAnnex gitRepo + tn <- liftIO . newNotificationHandle True =<< + transferNotifier <$> getDaemonStatus + forever $ do + liftIO $ threadDelay 500000 -- 0.5 seconds + ts <- currentTransfers <$> getDaemonStatus + if M.null ts + -- block until transfers running + then liftIO $ waitNotification tn + else mapM_ (poll g) $ M.toList ts + where + poll g (t, info) + {- Downloads are polled by checking the size of the + - temp file being used for the transfer. -} + | transferDirection t == Download = do + let f = gitAnnexTmpLocation (transferKey t) g + sz <- liftIO $ catchMaybeIO $ + fromIntegral . fileSize <$> getFileStatus f + newsize t info sz + {- Uploads don't need to be polled for when the TransferWatcher + - thread can track file modifications. -} + | TransferWatcher.watchesTransferSize = noop + {- Otherwise, this code polls the upload progress + - by reading the transfer info file. -} + | otherwise = do + let f = transferFile t g + mi <- liftIO $ catchDefaultIO Nothing $ + readTransferInfoFile Nothing f + maybe noop (newsize t info . bytesComplete) mi + + newsize t info sz + | bytesComplete info /= sz && isJust sz = + alterTransferInfo t $ \i -> i { bytesComplete = sz } + | otherwise = noop diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs new file mode 100644 index 0000000000..ba302d6bb9 --- /dev/null +++ b/Assistant/Threads/TransferScanner.hs @@ -0,0 +1,183 @@ +{- git-annex assistant thread to scan remotes to find needed transfers + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.TransferScanner where + +import Assistant.Common +import Assistant.Types.ScanRemotes +import Assistant.ScanRemotes +import Assistant.TransferQueue +import Assistant.DaemonStatus +import Assistant.Drop +import Assistant.Sync +import Assistant.DeleteRemote +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 +import Utility.NotificationBroadcaster +import Utility.Batch +import qualified Git.LsFiles as LsFiles +import qualified Backend +import Annex.Content +import Annex.Wanted + +import qualified Data.Set as S + +{- This thread waits until a remote needs to be scanned, to find transfers + - that need to be made, to keep data in sync. + -} +transferScannerThread :: UrlRenderer -> NamedThread +transferScannerThread urlrenderer = namedThread "TransferScanner" $ do + startupScan + go S.empty + where + go scanned = do + scanrunning False + liftIO $ threadDelaySeconds (Seconds 2) + (rs, infos) <- unzip <$> getScanRemote + scanrunning True + if any fullScan infos || any (`S.notMember` scanned) rs + then do + expensiveScan urlrenderer rs + go $ scanned `S.union` S.fromList rs + else do + mapM_ failedTransferScan rs + go scanned + scanrunning b = do + ds <- modifyDaemonStatus $ \s -> + (s { transferScanRunning = b }, s) + liftIO $ sendNotification $ transferNotifier ds + + {- All git remotes are synced, and all available remotes + - are scanned in full on startup, for multiple reasons, including: + - + - * This may be the first run, and there may be remotes + - already in place, that need to be synced. + - * Changes may have been made last time we run, but remotes were + - not available to be synced with. + - * Changes may have been made to remotes while we were down. + - * We may have run before, and scanned a remote, but + - only been in a subdirectory of the git remote, and so + - not synced it all. + - * We may have run before, and had transfers queued, + - and then the system (or us) crashed, and that info was + - lost. + - * A remote may be in the unwanted group, and this is a chance + - to determine if the remote has been emptied. + -} + startupScan = do + reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus + addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus + +{- This is a cheap scan for failed transfers involving a remote. -} +failedTransferScan :: Remote -> Assistant () +failedTransferScan r = do + failed <- liftAnnex $ clearFailedTransfers (Remote.uuid r) + mapM_ retry failed + where + retry (t, info) + | transferDirection t == Download = + {- Check if the remote still has the key. + - If not, relies on the expensiveScan to + - get it queued from some other remote. -} + whenM (liftAnnex $ remoteHas r $ transferKey t) $ + requeue t info + | otherwise = + {- The Transferrer checks when uploading + - that the remote doesn't already have the + - key, so it's not redundantly checked here. -} + requeue t info + requeue t info = queueTransferWhenSmall "retrying failed transfer" (associatedFile info) t r + +{- This is a expensive scan through the full git work tree, finding + - files to transfer. The scan is blocked when the transfer queue gets + - too large. + - + - This also finds files that are present either here or on a remote + - but that are not preferred content, and drops them. Searching for files + - to drop is done concurrently with the scan for transfers. + - + - TODO: It would be better to first drop as much as we can, before + - transferring much, to minimise disk use. + - + - During the scan, we'll also check if any unwanted repositories are empty, + - and can be removed. While unrelated, this is a cheap place to do it, + - since we need to look at the locations of all keys anyway. + -} +expensiveScan :: UrlRenderer -> [Remote] -> Assistant () +expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do + debug ["starting scan of", show visiblers] + + let us = map Remote.uuid rs + + mapM_ (liftAnnex . clearFailedTransfers) us + + unwantedrs <- liftAnnex $ S.fromList + <$> filterM inUnwantedGroup us + + g <- liftAnnex gitRepo + (files, cleanup) <- liftIO $ LsFiles.inRepo [] g + removablers <- scan unwantedrs files + void $ liftIO cleanup + + debug ["finished scan of", show visiblers] + + 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' + + scan unwanted [] = return unwanted + scan unwanted (f:fs) = do + (unwanted', ts) <- maybe + (return (unwanted, [])) + (findtransfers f unwanted) + =<< liftAnnex (Backend.lookupFile f) + mapM_ (enqueue f) ts + scan unwanted' fs + + enqueue f (r, t) = + queueTransferWhenSmall "expensive scan found missing object" + (Just f) t r + findtransfers f unwanted (key, _) = do + {- The syncable remotes may have changed since this + - scan began. -} + syncrs <- syncDataRemotes <$> getDaemonStatus + locs <- liftAnnex $ loggedLocations key + present <- liftAnnex $ inAnnex key + handleDropsFrom locs syncrs + "expensive scan found too many copies of object" + present key (Just f) Nothing + liftAnnex $ do + let slocs = S.fromList locs + let use a = return $ mapMaybe (a key slocs) syncrs + ts <- if present + then filterM (wantSend True (Just f) . Remote.uuid . fst) + =<< use (genTransfer Upload False) + else ifM (wantGet True $ Just f) + ( use (genTransfer Download True) , return [] ) + let unwanted' = S.difference unwanted slocs + return (unwanted', ts) + +genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) +genTransfer direction want key slocs r + | direction == Upload && Remote.readonly r = Nothing + | S.member (Remote.uuid r) slocs == want = Just + (r, Transfer direction (Remote.uuid r) key) + | otherwise = Nothing + +remoteHas :: Remote -> Key -> Annex Bool +remoteHas r key = elem + <$> pure (Remote.uuid r) + <*> loggedLocations key diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs new file mode 100644 index 0000000000..fc09373e79 --- /dev/null +++ b/Assistant/Threads/TransferWatcher.hs @@ -0,0 +1,98 @@ +{- git-annex assistant transfer watching thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.TransferWatcher where + +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.TransferSlots +import Logs.Transfer +import Utility.DirWatcher +import Utility.DirWatcher.Types +import qualified Remote + +import Control.Concurrent + +{- This thread watches for changes to the gitAnnexTransferDir, + - and updates the DaemonStatus's map of ongoing transfers. -} +transferWatcherThread :: NamedThread +transferWatcherThread = namedThread "TransferWatcher" $ do + dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo + liftIO $ createDirectoryIfMissing True dir + let hook a = Just <$> asIO2 (runHandler a) + addhook <- hook onAdd + delhook <- hook onDel + modifyhook <- hook onModify + errhook <- hook onErr + let hooks = mkWatchHooks + { addHook = addhook + , delHook = delhook + , modifyHook = modifyhook + , errHook = errhook + } + void $ liftIO $ watchDir dir (const False) hooks id + debug ["watching for transfers"] + +type Handler = FilePath -> Assistant () + +{- Runs an action handler. + - + - Exceptions are ignored, otherwise a whole thread could be crashed. + -} +runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () +runHandler handler file _filestatus = + either (liftIO . print) (const noop) =<< tryIO <~> handler file + +{- Called when there's an error with inotify. -} +onErr :: Handler +onErr = error + +{- Called when a new transfer information file is written. -} +onAdd :: Handler +onAdd file = case parseTransferFile file of + Nothing -> noop + Just t -> go t =<< liftAnnex (checkTransfer t) + where + go _ Nothing = noop -- transfer already finished + go t (Just info) = do + debug [ "transfer starting:", describeTransfer t info ] + r <- liftAnnex $ Remote.remoteFromUUID $ transferUUID t + updateTransferInfo t info { transferRemote = r } + +{- Called when a transfer information file is updated. + - + - The only thing that should change in the transfer info is the + - bytesComplete, so that's the only thing updated in the DaemonStatus. -} +onModify :: Handler +onModify file = case parseTransferFile file of + Nothing -> noop + Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) + where + go _ Nothing = noop + go t (Just newinfo) = alterTransferInfo t $ + \i -> i { bytesComplete = bytesComplete newinfo } + +{- This thread can only watch transfer sizes when the DirWatcher supports + - tracking modificatons to files. -} +watchesTransferSize :: Bool +watchesTransferSize = modifyTracked + +{- Called when a transfer information file is removed. -} +onDel :: Handler +onDel file = case parseTransferFile file of + Nothing -> noop + Just t -> do + debug [ "transfer finishing:", show t] + minfo <- removeTransfer t + + finished <- asIO2 finishedTransfer + void $ liftIO $ forkIO $ do + {- XXX race workaround delay. The location + - log needs to be updated before finishedTransfer + - runs. -} + threadDelay 10000000 -- 10 seconds + finished t minfo diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs new file mode 100644 index 0000000000..0bc419e15e --- /dev/null +++ b/Assistant/Threads/Transferrer.hs @@ -0,0 +1,25 @@ +{- git-annex assistant data transferrer thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.Transferrer where + +import Assistant.Common +import Assistant.TransferQueue +import Assistant.TransferSlots +import Logs.Transfer +import Config.Files + +{- Dispatches transfers from the queue. -} +transfererThread :: NamedThread +transfererThread = namedThread "Transferrer" $ do + program <- liftIO readProgramFile + forever $ inTransferSlot program $ + maybe (return Nothing) (uncurry genTransfer) + =<< getNextTransfer notrunning + where + {- Skip transfers that are already running. -} + notrunning = isNothing . startedTime diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs new file mode 100644 index 0000000000..3eedbe145d --- /dev/null +++ b/Assistant/Threads/Watcher.hs @@ -0,0 +1,352 @@ +{- git-annex assistant tree watcher + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE DeriveDataTypeable, CPP #-} + +module Assistant.Threads.Watcher ( + watchThread, + WatcherControl(..), + checkCanWatch, + needLsof, + onAddSymlink, + runHandler, +) where + +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.Changes +import Assistant.Types.Changes +import Assistant.Alert +import Utility.DirWatcher +import Utility.DirWatcher.Types +import qualified Utility.Lsof as Lsof +import qualified Annex +import qualified Annex.Queue +import qualified Git +import qualified Git.UpdateIndex +import qualified Git.LsFiles as LsFiles +import qualified Backend +import Annex.Direct +import Annex.Content.Direct +import Annex.CatFile +import Annex.CheckIgnore +import Annex.Link +import Annex.FileMatcher +import Annex.ReplaceFile +import Git.Types +import Config +import Utility.ThreadScheduler + +import Data.Bits.Utils +import Data.Typeable +import qualified Data.ByteString.Lazy as L +import qualified Control.Exception as E +import Data.Time.Clock + +checkCanWatch :: Annex () +checkCanWatch + | canWatch = do + liftIO Lsof.setup + unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) + needLsof + | otherwise = error "watch mode is not available on this system" + +needLsof :: Annex () +needLsof = error $ unlines + [ "The lsof command is needed for watch mode to be safe, and is not in PATH." + , "To override lsof checks to ensure that files are not open for writing" + , "when added to the annex, you can use --force" + , "Be warned: This can corrupt data in the annex, and make fsck complain." + ] + +{- A special exception that can be thrown to pause or resume the watcher. -} +data WatcherControl = PauseWatcher | ResumeWatcher + deriving (Show, Eq, Typeable) + +instance E.Exception WatcherControl + +watchThread :: NamedThread +watchThread = namedThread "Watcher" $ + ifM (liftAnnex $ annexAutoCommit <$> Annex.getGitConfig) + ( runWatcher + , waitFor ResumeWatcher runWatcher + ) + +runWatcher :: Assistant () +runWatcher = do + startup <- asIO1 startupScan + matcher <- liftAnnex largeFilesMatcher + direct <- liftAnnex isDirect + symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig + addhook <- hook $ if direct + then onAddDirect symlinkssupported matcher + else onAdd matcher + delhook <- hook onDel + addsymlinkhook <- hook $ onAddSymlink direct + deldirhook <- hook onDelDir + errhook <- hook onErr + let hooks = mkWatchHooks + { addHook = addhook + , delHook = delhook + , addSymlinkHook = addsymlinkhook + , delDirHook = deldirhook + , errHook = errhook + } + handle <- liftIO $ watchDir "." ignored 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 + waitFor ResumeWatcher runWatcher + where + hook a = Just <$> asIO2 (runHandler a) + +waitFor :: WatcherControl -> Assistant () -> Assistant () +waitFor sig next = do + r <- liftIO (E.try pause :: IO (Either E.SomeException ())) + case r of + Left e -> case E.fromException e of + Just s + | s == sig -> next + _ -> noop + _ -> noop + where + pause = runEvery (Seconds 86400) noop + +{- Initial scartup scan. The action should return once the scan is complete. -} +startupScan :: IO a -> Assistant a +startupScan scanner = do + liftAnnex $ showAction "scanning" + alertWhile' startupScanAlert $ do + r <- liftIO scanner + + -- Notice any files that were deleted before + -- watching was started. + top <- liftAnnex $ fromRepo Git.repoPath + (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] + forM_ fs $ \f -> do + liftAnnex $ onDel' f + maybe noop recordChange =<< madeChange f RmChange + void $ liftIO cleanup + + liftAnnex $ showAction "started" + liftIO $ putStrLn "" + + modifyDaemonStatus_ $ \s -> s { scanComplete = True } + + return (True, r) + +{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking + - at the entire .git directory. Does not include .gitignores. -} +ignored :: FilePath -> Bool +ignored = ig . takeFileName + where + ig ".git" = True + ig ".gitignore" = True + ig ".gitattributes" = True +#ifdef darwin_HOST_OS + ig ".DS_Store" = True +#endif + ig _ = False + +unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) +unlessIgnored file a = ifM (liftAnnex $ checkIgnored file) + ( noChange + , a + ) + +type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change) + +{- Runs an action handler, and if there was a change, adds it to the ChangeChan. + - + - Exceptions are ignored, otherwise a whole watcher thread could be crashed. + -} +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 + Right Nothing -> noop + Right (Just change) -> do + -- Just in case the commit thread is not + -- flushing the queue fast enough. + liftAnnex Annex.Queue.flushWhenFull + recordChange change + where + 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 bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file) + ( pendingAddChange file + , do + liftAnnex $ Annex.Queue.addCommand "add" + [Params "--force --"] [file] + madeChange file AddFileChange + ) + +onAdd :: FileMatcher -> Handler +onAdd matcher file filestatus + | maybe False isRegularFile filestatus = + unlessIgnored file $ + add matcher file + | otherwise = noChange + +{- In direct mode, add events are received for both new files, and + - modified existing files. + -} +onAddDirect :: Bool -> FileMatcher -> Handler +onAddDirect symlinkssupported matcher file fs = do + v <- liftAnnex $ catKeyFile file + case (v, fs) of + (Just key, Just filestatus) -> + ifM (liftAnnex $ sameFileStatus key filestatus) + {- It's possible to get an add event for + - an existing file that is not + - really modified, but it might have + - just been deleted and been put back, + - so it symlink is restaged to make sure. -} + ( ifM (scanComplete <$> getDaemonStatus) + ( do + link <- liftAnnex $ inRepo $ gitAnnexLink file key + addLink file link (Just key) + , noChange + ) + , guardSymlinkStandin (Just key) $ do + debug ["changed direct", file] + liftAnnex $ changedDirect key file + add matcher file + ) + _ -> unlessIgnored file $ + guardSymlinkStandin Nothing $ do + debug ["add direct", file] + add matcher file + where + {- 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. -} + guardSymlinkStandin mk a + | symlinkssupported = a + | otherwise = do + linktarget <- liftAnnex $ getAnnexLinkTarget file + case linktarget of + Nothing -> a + Just lt -> do + case fileKey $ takeFileName lt of + Nothing -> noop + Just key -> void $ liftAnnex $ + addAssociatedFile key file + onAddSymlink' linktarget mk True file fs + +{- A symlink might be an arbitrary symlink, which is just added. + - Or, if it is a git-annex symlink, ensure it points to the content + - before adding it. + -} +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' :: Maybe String -> Maybe Key -> Bool -> Handler +onAddSymlink' linktarget mk isdirect file filestatus = go mk + where + go (Just key) = do + when isdirect $ + liftAnnex $ void $ addAssociatedFile key file + link <- liftAnnex $ inRepo $ gitAnnexLink file key + if linktarget == Just link + then ensurestaged (Just link) =<< getDaemonStatus + else do + unless isdirect $ + liftAnnex $ replaceFile file $ + makeAnnexLink link + addLink file link (Just key) + -- other symlink, not git-annex + go Nothing = ensurestaged linktarget =<< getDaemonStatus + + {- This is often called on symlinks that are already + - staged correctly. A symlink may have been deleted + - and being re-added, or added when the watcher was + - not running. So they're normally restaged to make sure. + - + - As an optimisation, during the startup scan, avoid + - restaging everything. Only links that were created since + - the last time the daemon was running are staged. + - (If the daemon has never ran before, avoid staging + - links too.) + -} + ensurestaged (Just link) daemonstatus + | scanComplete daemonstatus = addLink file link mk + | otherwise = case filestatus of + Just s + | not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange + _ -> addLink file link mk + ensurestaged Nothing _ = noChange + +{- For speed, tries to reuse the existing blob for symlink target. -} +addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change) +addLink file link mk = do + debug ["add symlink", file] + liftAnnex $ do + v <- catObjectDetails $ Ref $ ':':file + case v of + Just (currlink, sha, _type) + | s2w8 link == L.unpack currlink -> + stageSymlink file sha + _ -> stageSymlink file =<< hashSymlink link + madeChange file $ LinkChange mk + +onDel :: Handler +onDel file _ = do + debug ["file deleted", file] + liftAnnex $ onDel' file + madeChange file RmChange + +onDel' :: FilePath -> Annex () +onDel' file = do + whenM isDirect $ do + mkey <- catKeyFile file + case mkey of + Nothing -> noop + Just key -> void $ removeAssociatedFile key file + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.unstageFile file) + +{- A directory has been deleted, or moved, so tell git to remove anything + - that was inside it from its cache. Since it could reappear at any time, + - use --cached to only delete it from the index. + - + - This queues up a lot of RmChanges, which assists the Committer in + - pairing up renamed files when the directory was renamed. -} +onDelDir :: Handler +onDelDir dir _ = do + debug ["directory deleted", dir] + (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir] + + liftAnnex $ mapM_ onDel' fs + + -- Get the events queued up as fast as possible, so the + -- committer sees them all in one block. + now <- liftIO getCurrentTime + recordChanges $ map (\f -> Change now f RmChange) fs + + void $ liftIO clean + liftAnnex Annex.Queue.flushWhenFull + noChange + +{- Called when there's an error with inotify or kqueue. -} +onErr :: Handler +onErr msg _ = do + liftAnnex $ warning msg + void $ addAlert $ warningAlert "watcher" msg + noChange diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs new file mode 100644 index 0000000000..a5f4f42011 --- /dev/null +++ b/Assistant/Threads/WebApp.hs @@ -0,0 +1,106 @@ +{- git-annex assistant webapp thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Assistant.Threads.WebApp where + +import Assistant.Common +import Assistant.WebApp +import Assistant.WebApp.Types +import Assistant.WebApp.DashBoard +import Assistant.WebApp.SideBar +import Assistant.WebApp.Notifications +import Assistant.WebApp.RepoList +import Assistant.WebApp.Configurators +import Assistant.WebApp.Configurators.Local +import Assistant.WebApp.Configurators.Ssh +import Assistant.WebApp.Configurators.Pairing +import Assistant.WebApp.Configurators.AWS +import Assistant.WebApp.Configurators.IA +import Assistant.WebApp.Configurators.WebDAV +import Assistant.WebApp.Configurators.XMPP +import Assistant.WebApp.Configurators.Preferences +import Assistant.WebApp.Configurators.Edit +import Assistant.WebApp.Configurators.Delete +import Assistant.WebApp.Configurators.Fsck +import Assistant.WebApp.Documentation +import Assistant.WebApp.Control +import Assistant.WebApp.OtherRepos +import Assistant.WebApp.Repair +import Assistant.Types.ThreadedMonad +import Utility.WebApp +import Utility.Tmp +import Utility.FileMode +import Git + +import Yesod +import Network.Socket (SockAddr, HostName) +import Data.Text (pack, unpack) + +mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") + +type Url = String + +webAppThread + :: AssistantData + -> UrlRenderer + -> Bool + -> Maybe HostName + -> Maybe (IO Url) + -> Maybe (Url -> FilePath -> IO ()) + -> NamedThread +webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do +#ifdef __ANDROID__ + when (isJust listenhost) $ + -- See Utility.WebApp + error "Sorry, --listen is not currently supported on Android" +#endif + webapp <- WebApp + <$> pure assistantdata + <*> (pack <$> genRandomToken) + <*> getreldir + <*> pure staticRoutes + <*> pure postfirstrun + <*> pure noannex + <*> pure listenhost + setUrlRenderer urlrenderer $ yesodRender webapp (pack "") + app <- toWaiAppPlain webapp + app' <- ifM debugEnabled + ( return $ httpDebugLogger app + , return app + ) + runWebApp listenhost app' $ \addr -> if noannex + then withTmpFile "webapp.html" $ \tmpfile _ -> + go addr webapp tmpfile Nothing + else do + let st = threadState assistantdata + htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim + urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile + go addr webapp htmlshim (Just urlfile) + where + -- 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" + getreldir + | noannex = return Nothing + | otherwise = Just <$> + (relHome =<< absPath + =<< runThreadState (threadState assistantdata) (fromRepo repoPath)) + go addr webapp htmlshim urlfile = do + let url = myUrl webapp addr + maybe noop (`writeFileProtected` url) urlfile + writeHtmlShim "Starting webapp..." url htmlshim + maybe noop (\a -> a url htmlshim) onstartup + +myUrl :: WebApp -> SockAddr -> Url +myUrl webapp addr = unpack $ yesodRender webapp urlbase DashboardR [] + where + urlbase = pack $ "http://" ++ show addr diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs new file mode 100644 index 0000000000..8eb4699390 --- /dev/null +++ b/Assistant/Threads/XMPPClient.hs @@ -0,0 +1,368 @@ +{- git-annex XMPP client + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.XMPPClient where + +import Assistant.Common +import Assistant.XMPP +import Assistant.XMPP.Client +import Assistant.NetMessager +import Assistant.Types.NetMessager +import Assistant.Types.Buddies +import Assistant.XMPP.Buddies +import Assistant.Sync +import Assistant.DaemonStatus +import qualified Remote +import Utility.ThreadScheduler +import Assistant.WebApp (UrlRenderer) +import Assistant.WebApp.Types hiding (liftAssistant) +import Assistant.Alert +import Assistant.Pairing +import Assistant.XMPP.Git +import Annex.UUID +import Logs.UUID + +import Network.Protocol.XMPP +import Control.Concurrent +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM (atomically) +import qualified Data.Text as T +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Git.Branch +import Data.Time.Clock +import Control.Concurrent.Async + +xmppClientThread :: UrlRenderer -> NamedThread +xmppClientThread urlrenderer = namedThread "XMPPClient" $ + restartableClient . xmppClient urlrenderer =<< getAssistant id + +{- Runs the client, handing restart events. -} +restartableClient :: (XMPPCreds -> IO ()) -> Assistant () +restartableClient a = forever $ go =<< liftAnnex getXMPPCreds + where + go Nothing = waitNetMessagerRestart + go (Just creds) = do + tid <- liftIO $ forkIO $ a creds + waitNetMessagerRestart + liftIO $ killThread tid + +xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO () +xmppClient urlrenderer d creds = + retry (runclient creds) =<< getCurrentTime + where + liftAssistant = runAssistant d + inAssistant = liftIO . liftAssistant + + {- When the client exits, it's restarted; + - if it keeps failing, back off to wait 5 minutes before + - trying it again. -} + retry client starttime = do + {- The buddy list starts empty each time + - the client connects, so that stale info + - is not retained. -} + liftAssistant $ + updateBuddyList (const noBuddies) <<~ buddyList + void client + liftAssistant $ modifyDaemonStatus_ $ \s -> s + { xmppClientID = Nothing } + now <- getCurrentTime + if diffUTCTime now starttime > 300 + then do + liftAssistant $ debug ["connection lost; reconnecting"] + retry client now + else do + liftAssistant $ debug ["connection failed; will retry"] + threadDelaySeconds (Seconds 300) + retry client =<< getCurrentTime + + runclient c = liftIO $ connectXMPP c $ \jid -> do + selfjid <- bindJID jid + putStanza gitAnnexSignature + + inAssistant $ do + modifyDaemonStatus_ $ \s -> s + { xmppClientID = Just $ xmppJID creds } + debug ["connected", logJid selfjid] + + lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime + + sender <- xmppSession $ sendnotifications selfjid + receiver <- xmppSession $ receivenotifications selfjid lasttraffic + pinger <- xmppSession $ sendpings selfjid lasttraffic + {- Run all 3 threads concurrently, until + - any of them throw an exception. + - Then kill all 3 threads, and rethrow the + - exception. + - + - If this thread gets an exception, the 3 threads + - will also be killed. -} + liftIO $ pinger `concurrently` sender `concurrently` receiver + + sendnotifications selfjid = forever $ + join $ inAssistant $ relayNetMessage selfjid + receivenotifications selfjid lasttraffic = forever $ do + l <- decodeStanza selfjid <$> getStanza + void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime + inAssistant $ debug + ["received:", show $ map logXMPPEvent l] + mapM_ (handle selfjid) l + sendpings selfjid lasttraffic = forever $ do + putStanza pingstanza + + startping <- liftIO getCurrentTime + liftIO $ threadDelaySeconds (Seconds 120) + t <- liftIO $ atomically $ readTMVar lasttraffic + when (t < startping) $ do + inAssistant $ debug ["ping timeout"] + error "ping timeout" + where + {- 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 + + handle 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)) = + maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) + handle _ (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 + + resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do + let c = formatJID jid + (stored, sent) <- inAssistant $ + checkImportantNetMessages (formatJID (baseJID jid), c) + forM_ (S.toList $ S.difference stored sent) $ \msg -> do + let msg' = readdressNetMessage msg c + inAssistant $ debug + [ "sending to new client:" + , logJid jid + , show $ logNetMessage msg' + ] + join $ inAssistant $ convertNetMsg msg' selfjid + inAssistant $ sentImportantNetMessage msg c + resendImportantMessages _ _ = noop + +data XMPPEvent + = GotNetMessage NetMessage + | PresenceMessage Presence + | Ignorable ReceivedStanza + | Unknown ReceivedStanza + | ProtocolError ReceivedStanza + deriving Show + +logXMPPEvent :: XMPPEvent -> String +logXMPPEvent (GotNetMessage m) = logNetMessage m +logXMPPEvent (PresenceMessage p) = logPresence p +logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p +logXMPPEvent (Ignorable _) = "Ignorable message" +logXMPPEvent (Unknown _) = "Unknown message" +logXMPPEvent (ProtocolError _) = "Protocol error message" + +logPresence :: Presence -> String +logPresence (p@Presence { presenceFrom = Just jid }) = unwords + [ "Presence from" + , logJid jid + , show $ extractGitAnnexTag p + ] +logPresence _ = "Presence from unknown" + +logJid :: JID -> String +logJid jid = + let name = T.unpack (buddyName jid) + resource = maybe "" (T.unpack . strResource) (jidResource jid) + in take 1 name ++ show (length name) ++ "/" ++ resource + +logClient :: Client -> String +logClient (Client jid) = logJid jid + +{- Decodes an XMPP stanza into one or more events. -} +decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] +decodeStanza selfjid s@(ReceivedPresence p) + | presenceType p == PresenceError = [ProtocolError s] + | isNothing (presenceFrom p) = [Ignorable s] + | presenceFrom p == Just selfjid = [Ignorable s] + | otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p) + where + decode i + | tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ + decodePushNotification (tagValue i) + | tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence + | otherwise = [Unknown s] + {- Things sent via presence imply a presence message, + - along with their real meaning. -} + impliedp v = [PresenceMessage p, v] +decodeStanza selfjid s@(ReceivedMessage m) + | isNothing (messageFrom m) = [Ignorable s] + | messageFrom m == Just selfjid = [Ignorable s] + | messageType m == MessageError = [ProtocolError s] + | otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)] +decodeStanza _ s = [Unknown s] + +{- Waits for a NetMessager message to be sent, and relays it to XMPP. + - + - Chat messages must be directed to specific clients, not a base + - account JID, due to git-annex clients using a negative presence priority. + - PairingNotification messages are always directed at specific + - clients, but Pushing messages are sometimes not, and need to be exploded + - out to specific clients. + - + - Important messages, not directed at any specific client, + - are cached to be sent later when additional clients connect. + -} +relayNetMessage :: JID -> Assistant (XMPP ()) +relayNetMessage selfjid = do + msg <- waitNetMessage + debug ["sending:", logNetMessage msg] + a1 <- handleImportant msg + a2 <- convert msg + return (a1 >> a2) + where + handleImportant msg = case parseJID =<< isImportantNetMessage msg of + Just tojid + | tojid == baseJID tojid -> do + storeImportantNetMessage msg (formatJID tojid) $ + \c -> (baseJID <$> parseJID c) == Just tojid + return $ putStanza presenceQuery + _ -> return noop + convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> + if tojid == baseJID tojid + then do + clients <- maybe [] (S.toList . buddyAssistants) + <$> getBuddy (genBuddyKey tojid) <<~ buddyList + debug ["exploded undirected message to clients", unwords $ map logClient clients] + return $ forM_ clients $ \(Client jid) -> + putStanza $ pushMessage pushstage jid selfjid + else do + debug ["to client:", logJid tojid] + return $ putStanza $ pushMessage pushstage tojid selfjid + convert msg = convertNetMsg msg selfjid + +{- Converts a NetMessage to an XMPP action. -} +convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ()) +convertNetMsg msg selfjid = convert msg + where + convert (NotifyPush us) = return $ putStanza $ pushNotification us + convert QueryPresence = return $ putStanza presenceQuery + convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do + changeBuddyPairing tojid True + return $ putStanza $ pairingNotification stage u tojid selfjid + convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> + return $ putStanza $ pushMessage pushstage tojid selfjid + +withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ()) +withOtherClient selfjid c a = case parseJID c of + Nothing -> return noop + Just tojid + | tojid == selfjid -> return noop + | otherwise -> a tojid + +withClient :: ClientID -> (JID -> XMPP ()) -> XMPP () +withClient c a = maybe noop a $ parseJID c + +{- Returns an IO action that runs a XMPP action in a separate thread, + - using a session to allow it to access the same XMPP client. -} +xmppSession :: XMPP () -> XMPP (IO ()) +xmppSession a = do + s <- getSession + return $ void $ runXMPP s a + +{- We only pull from one remote out of the set listed in the push + - notification, as an optimisation. + - + - Note that it might be possible (though very unlikely) for the push + - notification to take a while to be sent, and multiple pushes happen + - before it is sent, so it includes multiple remotes that were pushed + - to at different times. + - + - It could then be the case that the remote we choose had the earlier + - push sent to it, but then failed to get the later push, and so is not + - fully up-to-date. If that happens, the pushRetryThread will come along + - and retry the push, and we'll get another notification once it succeeds, + - and pull again. -} +pull :: [UUID] -> Assistant () +pull [] = noop +pull us = do + rs <- filter matching . syncGitRemotes <$> getDaemonStatus + debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs + pullone rs =<< liftAnnex (inRepo Git.Branch.current) + where + matching r = Remote.uuid r `S.member` s + s = S.fromList us + + pullone [] _ = noop + pullone (r:rs) branch = + unlessM (null . fst <$> manualPull branch [r]) $ + pullone rs branch + +{- PairReq from another client using our JID is automatically + - accepted. This is so pairing devices all using the same XMPP + - account works without confirmations. + - + - Also, autoaccept PairReq from the same JID of any repo we've + - already paired with, as long as the UUID in the PairReq is + - one we know about. +-} +pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant () +pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid + | baseJID selfjid == baseJID theirjid = autoaccept + | otherwise = do + knownjids <- mapMaybe (parseJID . getXMPPClientID) + . filter isXMPPRemote . syncRemotes <$> getDaemonStatus + um <- liftAnnex uuidMap + if elem (baseJID theirjid) knownjids && M.member theiruuid um + then autoaccept + else showalert + + where + autoaccept = do + selfuuid <- liftAnnex getUUID + sendNetMessage $ + PairingNotification PairAck (formatJID theirjid) selfuuid + finishXMPPPairing theirjid theiruuid + -- Show an alert to let the user decide if they want to pair. + showalert = do + button <- mkAlertButton True (T.pack "Respond") urlrenderer $ + ConfirmXMPPPairFriendR $ + PairKey theiruuid $ formatJID theirjid + void $ addAlert $ pairRequestReceivedAlert + (T.unpack $ buddyName theirjid) + button + +{- PairAck must come from one of the buddies we are pairing with; + - don't pair with just anyone. -} +pairMsgReceived _ PairAck theiruuid _selfjid theirjid = + whenM (isBuddyPairing theirjid) $ do + changeBuddyPairing theirjid False + selfuuid <- liftAnnex getUUID + sendNetMessage $ + PairingNotification PairDone (formatJID theirjid) selfuuid + finishXMPPPairing theirjid theiruuid + +pairMsgReceived _ PairDone _theiruuid _selfjid theirjid = + changeBuddyPairing theirjid False + +isBuddyPairing :: JID -> Assistant Bool +isBuddyPairing jid = maybe False buddyPairing <$> + getBuddy (genBuddyKey jid) <<~ buddyList + +changeBuddyPairing :: JID -> Bool -> Assistant () +changeBuddyPairing jid ispairing = + updateBuddyList (M.adjust set key) <<~ buddyList + where + key = genBuddyKey jid + set b = b { buddyPairing = ispairing } diff --git a/Assistant/Threads/XMPPPusher.hs b/Assistant/Threads/XMPPPusher.hs new file mode 100644 index 0000000000..30c91c7f09 --- /dev/null +++ b/Assistant/Threads/XMPPPusher.hs @@ -0,0 +1,81 @@ +{- git-annex XMPP pusher threads + - + - This is a pair of threads. One handles git send-pack, + - and the other git receive-pack. Each thread can be running at most + - one such operation at a time. + - + - Why not use a single thread? Consider two clients A and B. + - If both decide to run a receive-pack at the same time to the other, + - they would deadlock with only one thread. For larger numbers of + - clients, the two threads are also sufficient. + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.XMPPPusher where + +import Assistant.Common +import Assistant.NetMessager +import Assistant.Types.NetMessager +import Assistant.WebApp (UrlRenderer) +import Assistant.WebApp.Configurators.XMPP (checkCloudRepos) +import Assistant.XMPP.Git + +import Control.Exception as E + +xmppSendPackThread :: UrlRenderer -> NamedThread +xmppSendPackThread = pusherThread "XMPPSendPack" SendPack + +xmppReceivePackThread :: UrlRenderer -> NamedThread +xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack + +pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread +pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing + where + go lastpushedto = do + msg <- waitPushInitiation side $ selectNextPush lastpushedto + debug ["started running push", logNetMessage msg] + + runpush <- asIO $ runPush checker msg + r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID))) + let successful = case r of + Right (Just _) -> True + _ -> False + + {- Empty the inbox, because stuff may have + - been left in it if the push failed. -} + let justpushedto = getclient msg + maybe noop (`emptyInbox` side) justpushedto + + debug ["finished running push", logNetMessage msg, show successful] + go $ if successful then justpushedto else lastpushedto + + checker = checkCloudRepos urlrenderer + + getclient (Pushing cid _) = Just cid + getclient _ = Nothing + +{- Select the next push to run from the queue. + - The queue cannot be empty! + - + - We prefer to select the most recently added push, because its requestor + - is more likely to still be connected. + - + - When passed the ID of a client we just pushed to, we prefer to not + - immediately push again to that same client. This avoids one client + - drowing out others. So pushes from the client we just pushed to are + - relocated to the beginning of the list, to be processed later. + -} +selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage]) +selectNextPush _ (m:[]) = (m, []) -- common case +selectNextPush _ [] = error "selectNextPush: empty list" +selectNextPush lastpushedto l = go [] l + where + go (r:ejected) [] = (r, ejected) + go rejected (m:ms) = case m of + (Pushing clientid _) + | Just clientid /= lastpushedto -> (m, rejected ++ ms) + _ -> go (m:rejected) ms + go [] [] = undefined diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs new file mode 100644 index 0000000000..f94e73c2b2 --- /dev/null +++ b/Assistant/TransferQueue.hs @@ -0,0 +1,223 @@ +{- git-annex assistant pending transfer queue + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.TransferQueue ( + TransferQueue, + Schedule(..), + newTransferQueue, + getTransferQueue, + queueTransfers, + queueTransfersMatching, + queueDeferredDownloads, + queueTransfer, + queueTransferAt, + queueTransferWhenSmall, + getNextTransfer, + getMatchingTransfers, + dequeueTransfers, +) where + +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.Types.TransferQueue +import Logs.Transfer +import Types.Remote +import qualified Remote +import qualified Types.Remote as Remote +import Annex.Wanted +import Utility.TList + +import Control.Concurrent.STM +import qualified Data.Map as M +import qualified Data.Set as S + +type Reason = String + +{- Reads the queue's content without blocking or changing it. -} +getTransferQueue :: Assistant [(Transfer, TransferInfo)] +getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue + +stubInfo :: AssociatedFile -> Remote -> TransferInfo +stubInfo f r = stubTransferInfo + { transferRemote = Just r + , associatedFile = f + } + +{- Adds transfers to queue for some of the known remotes. + - Honors preferred content settings, only transferring wanted files. -} +queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant () +queueTransfers = queueTransfersMatching (const True) + +{- Adds transfers to queue for some of the known remotes, that match a + - condition. Honors preferred content settings. -} +queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant () +queueTransfersMatching matching reason schedule k f direction + | direction == Download = whenM (liftAnnex $ wantGet True f) go + | otherwise = go + where + go = do + + rs <- liftAnnex . selectremotes + =<< syncDataRemotes <$> getDaemonStatus + let matchingrs = filter (matching . Remote.uuid) rs + if null matchingrs + then defer + else forM_ matchingrs $ \r -> + enqueue reason schedule (gentransfer r) (stubInfo f r) + selectremotes rs + {- Queue downloads from all remotes that + - have the key. The list of remotes is ordered with + - cheapest first. More expensive ones will only be tried + - if downloading from a cheap one fails. -} + | direction == Download = do + s <- locs + return $ filter (inset s) rs + {- Upload to all remotes that want the content and don't + - already have it. -} + | otherwise = do + s <- locs + filterM (wantSend True f . Remote.uuid) $ + filter (\r -> not (inset s r || Remote.readonly r)) rs + where + locs = S.fromList <$> Remote.keyLocations k + inset s r = S.member (Remote.uuid r) s + gentransfer r = Transfer + { transferDirection = direction + , transferKey = k + , transferUUID = Remote.uuid r + } + defer + {- Defer this download, as no known remote has the key. -} + | direction == Download = do + q <- getAssistant transferQueue + void $ liftIO $ atomically $ + consTList (deferreddownloads q) (k, f) + | otherwise = noop + +{- Queues any deferred downloads that can now be accomplished, leaving + - any others in the list to try again later. -} +queueDeferredDownloads :: Reason -> Schedule -> Assistant () +queueDeferredDownloads reason schedule = do + q <- getAssistant transferQueue + l <- liftIO $ atomically $ readTList (deferreddownloads q) + rs <- syncDataRemotes <$> getDaemonStatus + left <- filterM (queue rs) l + unless (null left) $ + liftIO $ atomically $ appendTList (deferreddownloads q) left + where + queue rs (k, f) = do + uuids <- liftAnnex $ Remote.keyLocations k + let sources = filter (\r -> uuid r `elem` uuids) rs + unless (null sources) $ + forM_ sources $ \r -> + enqueue reason schedule + (gentransfer r) (stubInfo f r) + return $ null sources + where + gentransfer r = Transfer + { transferDirection = Download + , transferKey = k + , transferUUID = Remote.uuid r + } + +enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant () +enqueue reason schedule t info + | schedule == Next = go consTList + | otherwise = go snocTList + where + go modlist = whenM (add modlist) $ do + debug [ "queued", describeTransfer t info, ": " ++ reason ] + notifyTransfer + add modlist = do + q <- getAssistant transferQueue + dstatus <- getAssistant daemonStatusHandle + liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t) + ( return False + , do + l <- readTList (queuelist q) + if (t `notElem` map fst l) + then do + void $ modifyTVar' (queuesize q) succ + void $ modlist (queuelist q) (t, info) + return True + else return False + ) + +{- Adds a transfer to the queue. -} +queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant () +queueTransfer reason schedule f t remote = + enqueue reason schedule t (stubInfo f remote) + +{- Blocks until the queue is no larger than a given size, and then adds a + - transfer to the queue. -} +queueTransferAt :: Int -> Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant () +queueTransferAt wantsz reason schedule f t remote = do + q <- getAssistant transferQueue + liftIO $ atomically $ do + sz <- readTVar (queuesize q) + unless (sz <= wantsz) $ + retry -- blocks until queuesize changes + enqueue reason schedule t (stubInfo f remote) + +queueTransferWhenSmall :: Reason -> AssociatedFile -> Transfer -> Remote -> Assistant () +queueTransferWhenSmall reason = queueTransferAt 10 reason Later + +{- Blocks until a pending transfer is available in the queue, + - and removes it. + - + - Checks that it's acceptable, before adding it to the + - currentTransfers map. If it's not acceptable, it's discarded. + - + - This is done in a single STM transaction, so there is no window + - where an observer sees an inconsistent status. -} +getNextTransfer :: (TransferInfo -> Bool) -> Assistant (Maybe (Transfer, TransferInfo)) +getNextTransfer acceptable = do + q <- getAssistant transferQueue + dstatus <- getAssistant daemonStatusHandle + liftIO $ atomically $ do + sz <- readTVar (queuesize q) + if sz < 1 + then retry -- blocks until queuesize changes + else do + (r@(t,info):rest) <- readTList (queuelist q) + void $ modifyTVar' (queuesize q) pred + setTList (queuelist q) rest + if acceptable info + then do + adjustTransfersSTM dstatus $ + M.insertWith' const t info + return $ Just r + else return Nothing + +{- Moves transfers matching a condition from the queue, to the + - currentTransfers map. -} +getMatchingTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)] +getMatchingTransfers c = do + q <- getAssistant transferQueue + dstatus <- getAssistant daemonStatusHandle + liftIO $ atomically $ do + ts <- dequeueTransfersSTM q c + unless (null ts) $ + adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts + return ts + +{- Removes transfers matching a condition from the queue, and returns the + - removed transfers. -} +dequeueTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)] +dequeueTransfers c = do + q <- getAssistant transferQueue + removed <- liftIO $ atomically $ dequeueTransfersSTM q c + unless (null removed) $ + notifyTransfer + return removed + +dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] +dequeueTransfersSTM q c = do + (removed, ts) <- partition (c . fst) <$> readTList (queuelist q) + void $ writeTVar (queuesize q) (length ts) + setTList (queuelist q) ts + return removed diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs new file mode 100644 index 0000000000..36d557c3d7 --- /dev/null +++ b/Assistant/TransferSlots.hs @@ -0,0 +1,277 @@ +{- git-annex assistant transfer slots + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.TransferSlots where + +import Assistant.Common +import Utility.ThreadScheduler +import Assistant.Types.TransferSlots +import Assistant.DaemonStatus +import Assistant.TransferrerPool +import Assistant.Types.TransferrerPool +import Assistant.Types.TransferQueue +import Assistant.TransferQueue +import Assistant.Alert +import Assistant.Alert.Utility +import Assistant.Commits +import Assistant.Drop +import Logs.Transfer +import Logs.Location +import qualified Git +import qualified Remote +import qualified Types.Remote as Remote +import Annex.Content +import Annex.Wanted +import Config.Files + +import qualified Data.Map as M +import qualified Control.Exception as E +import Control.Concurrent +import qualified Control.Concurrent.MSemN as MSemN +import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +import System.Posix.Process (getProcessGroupIDOf) + +type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ())) + +{- Waits until a transfer slot becomes available, then runs a + - TransferGenerator, and then runs the transfer action in its own thread. + -} +inTransferSlot :: FilePath -> TransferGenerator -> Assistant () +inTransferSlot program gen = do + flip MSemN.wait 1 <<~ transferSlots + runTransferThread program =<< gen + +{- Runs a TransferGenerator, and its transfer action, + - without waiting for a slot to become available. -} +inImmediateTransferSlot :: FilePath -> TransferGenerator -> Assistant () +inImmediateTransferSlot program gen = do + flip MSemN.signal (-1) <<~ transferSlots + runTransferThread program =<< gen + +{- Runs a transfer action, in an already allocated transfer slot. + - Once it finishes, frees the transfer slot. + - + - Note that the action is subject to being killed when the transfer + - is canceled or paused. + - + - A PauseTransfer exception is handled by letting the action be killed, + - then pausing the thread until a ResumeTransfer exception is raised, + - then rerunning the action. + -} +runTransferThread :: FilePath -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant () +runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots +runTransferThread program (Just (t, info, a)) = do + d <- getAssistant id + aio <- asIO1 a + tid <- liftIO $ forkIO $ runTransferThread' program d aio + updateTransferInfo t $ info { transferTid = Just tid } + +runTransferThread' :: FilePath -> AssistantData -> (Transferrer -> IO ()) -> IO () +runTransferThread' program d run = go + where + go = catchPauseResume $ + withTransferrer program (transferrerPool d) + run + pause = catchPauseResume $ + runEvery (Seconds 86400) noop + {- Note: This must use E.try, rather than E.catch. + - When E.catch is used, and has called go in its exception + - handler, Control.Concurrent.throwTo will block sometimes + - when signaling. Using E.try avoids the problem. -} + catchPauseResume a' = do + r <- E.try a' :: IO (Either E.SomeException ()) + case r of + Left e -> case E.fromException e of + Just PauseTransfer -> pause + Just ResumeTransfer -> go + _ -> done + _ -> done + done = runAssistant d $ + flip MSemN.signal 1 <<~ transferSlots + +{- By the time this is called, the daemonstatus's currentTransfers map should + - already have been updated to include the transfer. -} +genTransfer :: Transfer -> TransferInfo -> TransferGenerator +genTransfer t info = case (transferRemote info, associatedFile info) of + (Just remote, Just file) + | Git.repoIsLocalUnknown (Remote.repo remote) -> do + -- optimisation for removable drives not plugged in + liftAnnex $ recordFailedTransfer t info + void $ removeTransfer t + return Nothing + | otherwise -> ifM (liftAnnex $ shouldTransfer t info) + ( do + debug [ "Transferring:" , describeTransfer t info ] + notifyTransfer + return $ Just (t, info, go remote file) + , do + debug [ "Skipping unnecessary transfer:", + describeTransfer t info ] + void $ removeTransfer t + finishedTransfer t (Just info) + return Nothing + ) + _ -> return Nothing + where + direction = transferDirection t + isdownload = direction == Download + + {- Alerts are only shown for successful transfers. + - Transfers can temporarily fail for many reasons, + - so there's no point in bothering the user about + - those. The assistant should recover. + - + - After a successful upload, handle dropping it from + - here, if desired. In this case, the remote it was + - uploaded to is known to have it. + - + - Also, after a successful transfer, the location + - log has changed. Indicate that a commit has been + - made, in order to queue a push of the git-annex + - branch out to remotes that did not participate + - in the transfer. + - + - If the process failed, it could have crashed, + - so remove the transfer from the list of current + - transfers, just in case it didn't stop + - in a way that lets the TransferWatcher do its + - usual cleanup. However, first check if something else is + - running the transfer, to avoid removing active transfers. + -} + go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info) + ( do + void $ addAlert $ makeAlertFiller True $ + transferFileAlert direction True file + unless isdownload $ + handleDrops + ("object uploaded to " ++ show remote) + True (transferKey t) + (associatedFile info) + (Just remote) + void recordCommit + , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ + void $ removeTransfer t + ) + +{- Called right before a transfer begins, this is a last chance to avoid + - unnecessary transfers. + - + - For downloads, we obviously don't need to download if the already + - have the object. + - + - Smilarly, for uploads, check if the remote is known to already have + - the object. + - + - Also, uploads get queued to all remotes, in order of cost. + - This may mean, for example, that an object is uploaded over the LAN + - to a locally paired client, and once that upload is done, a more + - expensive transfer remote no longer wants the object. (Since + - all the clients have it already.) So do one last check if this is still + - preferred content. + - + - We'll also do one last preferred content check for downloads. An + - example of a case where this could be needed is if a download is queued + - for a file that gets moved out of an archive directory -- but before + - that download can happen, the file is put back in the archive. + -} +shouldTransfer :: Transfer -> TransferInfo -> Annex Bool +shouldTransfer t info + | transferDirection t == Download = + (not <$> inAnnex key) <&&> wantGet True file + | transferDirection t == Upload = case transferRemote info of + Nothing -> return False + Just r -> notinremote r + <&&> wantSend True file (Remote.uuid r) + | otherwise = return False + where + key = transferKey t + file = associatedFile info + + {- Trust the location log to check if the remote already has + - the key. This avoids a roundtrip to the remote. -} + notinremote r = notElem (Remote.uuid r) <$> loggedLocations key + +{- Queue uploads of files downloaded to us, spreading them + - out to other reachable remotes. + - + - Downloading a file may have caused a remote to not want it; + - so check for drops from remotes. + - + - Uploading a file may cause the local repo, or some other remote to not + - want it; handle that too. + -} +finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant () +finishedTransfer t (Just info) + | transferDirection t == Download = + whenM (liftAnnex $ inAnnex $ transferKey t) $ do + dodrops False + queueTransfersMatching (/= transferUUID t) + "newly received object" + Later (transferKey t) (associatedFile info) Upload + | otherwise = dodrops True + where + dodrops fromhere = handleDrops + ("drop wanted after " ++ describeTransfer t info) + fromhere (transferKey t) (associatedFile info) Nothing +finishedTransfer _ _ = noop + +{- Pause a running transfer. -} +pauseTransfer :: Transfer -> Assistant () +pauseTransfer = cancelTransfer True + +{- Cancel a running transfer. -} +cancelTransfer :: Bool -> Transfer -> Assistant () +cancelTransfer pause t = do + m <- getCurrentTransfers + unless pause $ + {- remove queued transfer -} + void $ dequeueTransfers $ equivilantTransfer t + {- stop running transfer -} + maybe noop stop (M.lookup t m) + where + stop info = do + {- When there's a thread associated with the + - transfer, it's signaled first, to avoid it + - displaying any alert about the transfer having + - failed when the transfer process is killed. -} + liftIO $ maybe noop signalthread $ transferTid info + liftIO $ maybe noop killproc $ transferPid info + if pause + then void $ alterTransferInfo t $ + \i -> i { transferPaused = True } + else void $ removeTransfer t + signalthread tid + | pause = throwTo tid PauseTransfer + | otherwise = killThread tid + {- In order to stop helper processes like rsync, + - kill the whole process group of the process running the transfer. -} + killproc pid = void $ tryIO $ do + g <- getProcessGroupIDOf pid + void $ tryIO $ signalProcessGroup sigTERM g + threadDelay 50000 -- 0.05 second grace period + void $ tryIO $ signalProcessGroup sigKILL g + +{- Start or resume a transfer. -} +startTransfer :: Transfer -> Assistant () +startTransfer t = do + m <- getCurrentTransfers + maybe startqueued go (M.lookup t m) + where + go info = maybe (start info) resume $ transferTid info + startqueued = do + is <- map snd <$> getMatchingTransfers (== t) + maybe noop start $ headMaybe is + resume tid = do + alterTransferInfo t $ \i -> i { transferPaused = False } + liftIO $ throwTo tid ResumeTransfer + start info = do + program <- liftIO readProgramFile + inImmediateTransferSlot program $ + genTransfer t info + +getCurrentTransfers :: Assistant TransferMap +getCurrentTransfers = currentTransfers <$> getDaemonStatus diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs new file mode 100644 index 0000000000..d9104f74dd --- /dev/null +++ b/Assistant/TransferrerPool.hs @@ -0,0 +1,82 @@ +{- A pool of "git-annex transferkeys" processes + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.TransferrerPool where + +import Assistant.Common +import Assistant.Types.TransferrerPool +import Logs.Transfer +import qualified Command.TransferKeys as T + +import Control.Concurrent.STM +import System.Process (create_group) +import Control.Exception (throw) +import Control.Concurrent + +{- Runs an action with a Transferrer from the pool. -} +withTransferrer :: FilePath -> TransferrerPool -> (Transferrer -> IO a) -> IO a +withTransferrer program pool a = do + t <- maybe (mkTransferrer program) (checkTransferrer program) + =<< atomically (tryReadTChan pool) + v <- tryNonAsync $ a t + unlessM (putback t) $ + void $ forkIO $ stopTransferrer t + either throw return v + where + putback t = atomically $ ifM (isEmptyTChan pool) + ( do + writeTChan pool t + return True + , return False + ) + +{- 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) + T.readResponse (transferrerRead transferrer) + +{- Starts a new git-annex transferkeys process, setting up a pipe + - that will be used to communicate with it. -} +mkTransferrer :: FilePath -> IO Transferrer +mkTransferrer program = do + (myread, twrite) <- createPipe + (tread, mywrite) <- createPipe + mapM_ (\fd -> setFdOption fd CloseOnExec True) [myread, mywrite] + let params = + [ Param "transferkeys" + , Param "--readfd", Param $ show tread + , Param "--writefd", Param $ show twrite + ] + {- It's put into its own group so that the whole group can be + - killed to stop a transfer. -} + (_, _, _, pid) <- createProcess (proc program $ toCommand params) + { create_group = True } + closeFd twrite + closeFd tread + myreadh <- fdToHandle myread + mywriteh <- fdToHandle mywrite + fileEncoding myreadh + fileEncoding mywriteh + return $ Transferrer + { transferrerRead = myreadh + , transferrerWrite = mywriteh + , transferrerHandle = pid + } + +{- Checks if a Transferrer is still running. If not, makes a new one. -} +checkTransferrer :: FilePath -> Transferrer -> IO Transferrer +checkTransferrer program t = maybe (return t) (const $ mkTransferrer program) + =<< getProcessExitCode (transferrerHandle t) + +{- Closing the fds will stop the transferrer. -} +stopTransferrer :: Transferrer -> IO () +stopTransferrer t = do + hClose $ transferrerRead t + hClose $ transferrerWrite t + void $ waitForProcess $ transferrerHandle t diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs new file mode 100644 index 0000000000..2e52ca7efe --- /dev/null +++ b/Assistant/Types/Alert.hs @@ -0,0 +1,76 @@ +{- git-annex assistant alert types + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.Alert where + +import Utility.Tense + +import Data.Text (Text) +import qualified Data.Map as M + +{- Different classes of alerts are displayed differently. -} +data AlertClass = Success | Message | Activity | Warning | Error + deriving (Eq, Ord) + +data AlertPriority = Filler | Low | Medium | High | Pinned + deriving (Eq, Ord) + +{- An alert can have an name, which is used to combine it with other similar + - alerts. -} +data AlertName + = FileAlert TenseChunk + | SanityCheckFixAlert + | WarningAlert String + | PairAlert String + | XMPPNeededAlert + | RemoteRemovalAlert String + | CloudRepoNeededAlert + | SyncAlert + | NotFsckedAlert + deriving (Eq) + +{- The first alert is the new alert, the second is an old alert. + - Should return a modified version of the old alert. -} +type AlertCombiner = Alert -> Alert -> Maybe Alert + +data Alert = Alert + { alertClass :: AlertClass + , alertHeader :: Maybe TenseText + , alertMessageRender :: Alert -> TenseText + , alertData :: [TenseChunk] + , alertCounter :: Int + , alertBlockDisplay :: Bool + , alertClosable :: Bool + , alertPriority :: AlertPriority + , alertIcon :: Maybe AlertIcon + , alertCombiner :: Maybe AlertCombiner + , alertName :: Maybe AlertName + , alertButton :: Maybe AlertButton + } + +data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud + +type AlertMap = M.Map AlertId Alert + +{- Higher AlertId indicates a more recent alert. -} +newtype AlertId = AlertId Integer + deriving (Read, Show, Eq, Ord) + +firstAlertId :: AlertId +firstAlertId = AlertId 0 + +nextAlertId :: AlertId -> AlertId +nextAlertId (AlertId i) = AlertId $ succ i + +{- When clicked, a button always redirects to a URL + - It may also run an IO action in the background, which is useful + - to make the button close or otherwise change the alert. -} +data AlertButton = AlertButton + { buttonLabel :: Text + , buttonUrl :: Text + , buttonAction :: Maybe (AlertId -> IO ()) + } diff --git a/Assistant/Types/BranchChange.hs b/Assistant/Types/BranchChange.hs new file mode 100644 index 0000000000..399abee54d --- /dev/null +++ b/Assistant/Types/BranchChange.hs @@ -0,0 +1,19 @@ +{- git-annex assistant git-annex branch change tracking + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.BranchChange where + +import Control.Concurrent.MSampleVar +import Common.Annex + +newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ()) + +newBranchChangeHandle :: IO BranchChangeHandle +newBranchChangeHandle = BranchChangeHandle <$> newEmptySV + +fromBranchChangeHandle :: BranchChangeHandle -> MSampleVar () +fromBranchChangeHandle (BranchChangeHandle v) = v diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs new file mode 100644 index 0000000000..36d8a4fedc --- /dev/null +++ b/Assistant/Types/Buddies.hs @@ -0,0 +1,80 @@ +{- git-annex assistant buddies + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Types.Buddies where + +import Common.Annex + +import qualified Data.Map as M +import Control.Concurrent.STM +import Utility.NotificationBroadcaster +import Data.Text as T + +{- For simplicity, dummy types are defined even when XMPP is disabled. -} +#ifdef WITH_XMPP +import Network.Protocol.XMPP +import Data.Set as S +import Data.Ord + +newtype Client = Client JID + deriving (Eq, Show) + +instance Ord Client where + compare = comparing show + +data Buddy = Buddy + { buddyPresent :: S.Set Client + , buddyAway :: S.Set Client + , buddyAssistants :: S.Set Client + , buddyPairing :: Bool + } +#else +data Buddy = Buddy +#endif + deriving (Eq, Show) + +data BuddyKey = BuddyKey T.Text + deriving (Eq, Ord, Show, Read) + +data PairKey = PairKey UUID T.Text + deriving (Eq, Ord, Show, Read) + +type Buddies = M.Map BuddyKey Buddy + +{- A list of buddies, and a way to notify when it changes. -} +type BuddyList = (TMVar Buddies, NotificationBroadcaster) + +noBuddies :: Buddies +noBuddies = M.empty + +newBuddyList :: IO BuddyList +newBuddyList = (,) + <$> atomically (newTMVar noBuddies) + <*> newNotificationBroadcaster + +getBuddyList :: BuddyList -> IO [Buddy] +getBuddyList (v, _) = M.elems <$> atomically (readTMVar v) + +getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy) +getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v) + +getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster +getBuddyBroadcaster (_, h) = h + +{- Applies a function to modify the buddy list, and if it's changed, + - sends notifications to any listeners. -} +updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO () +updateBuddyList a (v, caster) = do + changed <- atomically $ do + buds <- takeTMVar v + let buds' = a buds + putTMVar v buds' + return $ buds /= buds' + when changed $ + sendNotification caster diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs new file mode 100644 index 0000000000..e8ecc6e48b --- /dev/null +++ b/Assistant/Types/Changes.hs @@ -0,0 +1,77 @@ +{- git-annex assistant change tracking + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.Changes where + +import Types.KeySource +import Types.Key +import Utility.TList + +import Control.Concurrent.STM +import Data.Time.Clock + +{- An un-ordered pool of Changes that have been noticed and should be + - staged and committed. Changes will typically be in order, but ordering + - may be lost. In any case, order should not matter, as any given Change + - may later be reverted by a later Change (ie, a file is added and then + - deleted). Code that processes the changes needs to deal with such + - scenarios. + -} +type ChangePool = TList Change + +newChangePool :: IO ChangePool +newChangePool = atomically newTList + +data Change + = Change + { changeTime :: UTCTime + , _changeFile :: FilePath + , changeInfo :: ChangeInfo + } + | PendingAddChange + { changeTime ::UTCTime + , _changeFile :: FilePath + } + | InProcessAddChange + { changeTime ::UTCTime + , keySource :: KeySource + } + deriving (Show) + +data ChangeInfo = AddKeyChange Key | AddFileChange | LinkChange (Maybe Key) | RmChange + deriving (Show, Eq, Ord) + +changeInfoKey :: ChangeInfo -> Maybe Key +changeInfoKey (AddKeyChange k) = Just k +changeInfoKey (LinkChange (Just k)) = Just k +changeInfoKey _ = Nothing + +changeFile :: Change -> FilePath +changeFile (Change _ f _) = f +changeFile (PendingAddChange _ f) = f +changeFile (InProcessAddChange _ ks) = keyFilename ks + +isPendingAddChange :: Change -> Bool +isPendingAddChange (PendingAddChange {}) = True +isPendingAddChange _ = False + +isInProcessAddChange :: Change -> Bool +isInProcessAddChange (InProcessAddChange {}) = True +isInProcessAddChange _ = False + +retryChange :: Change -> Change +retryChange (InProcessAddChange time ks) = + PendingAddChange time (keyFilename ks) +retryChange c = c + +finishedChange :: Change -> Key -> Change +finishedChange c@(InProcessAddChange { keySource = ks }) k = Change + { changeTime = changeTime c + , _changeFile = keyFilename ks + , changeInfo = AddKeyChange k + } +finishedChange c _ = c diff --git a/Assistant/Types/Commits.hs b/Assistant/Types/Commits.hs new file mode 100644 index 0000000000..500faa9011 --- /dev/null +++ b/Assistant/Types/Commits.hs @@ -0,0 +1,19 @@ +{- git-annex assistant commit tracking + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.Commits where + +import Utility.TList + +import Control.Concurrent.STM + +type CommitChan = TList Commit + +data Commit = Commit + +newCommitChan :: IO CommitChan +newCommitChan = atomically newTList diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs new file mode 100644 index 0000000000..a1a0d64dc0 --- /dev/null +++ b/Assistant/Types/DaemonStatus.hs @@ -0,0 +1,104 @@ +{- git-annex assistant daemon status + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.DaemonStatus where + +import Common.Annex +import Assistant.Pairing +import Utility.NotificationBroadcaster +import Logs.Transfer +import Assistant.Types.ThreadName +import Assistant.Types.NetMessager +import Assistant.Types.Alert + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Control.Concurrent.Async +import Data.Time.Clock.POSIX +import qualified Data.Map as M +import qualified Data.Set as S + +data DaemonStatus = DaemonStatus + -- All the named threads that comprise the daemon, + -- and actions to run to restart them. + { startedThreads :: M.Map ThreadName (Async (), IO ()) + -- False when the daemon is performing its startup scan + , scanComplete :: Bool + -- Time when a previous process of the daemon was running ok + , lastRunning :: Maybe POSIXTime + -- True when the daily sanity checker is running + , sanityCheckRunning :: Bool + -- Last time the daily sanity checker ran + , lastSanityCheck :: Maybe POSIXTime + -- True when a scan for file transfers is running + , transferScanRunning :: Bool + -- Currently running file content transfers + , currentTransfers :: TransferMap + -- Messages to display to the user. + , alertMap :: AlertMap + , lastAlertId :: AlertId + -- Ordered list of all remotes that can be synced with + , syncRemotes :: [Remote] + -- Ordered list of remotes to sync git with + , syncGitRemotes :: [Remote] + -- Ordered list of remotes to sync data with + , syncDataRemotes :: [Remote] + -- Are we syncing to any cloud remotes? + , syncingToCloudRemote :: Bool + -- List of uuids of remotes that we may have gotten out of sync with. + , desynced :: S.Set UUID + -- Pairing request that is in progress. + , pairingInProgress :: Maybe PairingInProgress + -- Broadcasts notifications about all changes to the DaemonStatus + , changeNotifier :: NotificationBroadcaster + -- Broadcasts notifications when queued or current transfers change. + , transferNotifier :: NotificationBroadcaster + -- Broadcasts notifications when there's a change to the alerts + , alertNotifier :: NotificationBroadcaster + -- Broadcasts notifications when the syncRemotes change + , syncRemotesNotifier :: NotificationBroadcaster + -- Broadcasts notifications when the scheduleLog changes + , scheduleLogNotifier :: NotificationBroadcaster + -- Broadcasts a notification once the startup sanity check has run. + , startupSanityCheckNotifier :: NotificationBroadcaster + -- When the XMPP client is connected, this will contain the XMPP + -- address. + , xmppClientID :: Maybe ClientID + -- MVars to signal when a remote gets connected. + , connectRemoteNotifiers :: M.Map UUID [MVar ()] + } + +type TransferMap = M.Map Transfer TransferInfo + +{- This TMVar is never left empty, so accessing it will never block. -} +type DaemonStatusHandle = TMVar DaemonStatus + +newDaemonStatus :: IO DaemonStatus +newDaemonStatus = DaemonStatus + <$> pure M.empty + <*> pure False + <*> pure Nothing + <*> pure False + <*> pure Nothing + <*> pure False + <*> pure M.empty + <*> pure M.empty + <*> pure firstAlertId + <*> pure [] + <*> pure [] + <*> pure [] + <*> pure False + <*> pure S.empty + <*> pure Nothing + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> pure Nothing + <*> pure M.empty diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs new file mode 100644 index 0000000000..5dd1364ad2 --- /dev/null +++ b/Assistant/Types/NamedThread.hs @@ -0,0 +1,21 @@ +{- named threads + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.NamedThread where + +import Assistant.Monad +import Assistant.Types.ThreadName + +{- Information about a named thread that can be run. -} +data NamedThread = NamedThread Bool ThreadName (Assistant ()) + +namedThread :: String -> Assistant () -> NamedThread +namedThread = NamedThread True . ThreadName + +{- A named thread that can start running before the startup sanity check. -} +namedThreadUnchecked :: String -> Assistant () -> NamedThread +namedThreadUnchecked = NamedThread False . ThreadName diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs new file mode 100644 index 0000000000..0af262e9a2 --- /dev/null +++ b/Assistant/Types/NetMessager.hs @@ -0,0 +1,155 @@ +{- git-annex assistant out of band network messager types + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.NetMessager where + +import Common.Annex +import Assistant.Pairing +import Git.Types + +import qualified Data.Text 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. -} +data NetMessage + -- indicate that pushes have been made to the repos with these uuids + = NotifyPush [UUID] + -- requests other clients to inform us of their presence + | QueryPresence + -- notification about a stage in the pairing process, + -- involving a client, and a UUID. + | PairingNotification PairStage ClientID UUID + -- used for git push over the network messager + | Pushing ClientID PushStage + deriving (Show, Eq, Ord) + +{- Something used to identify the client, or clients to send the message to. -} +type ClientID = Text + +data PushStage + -- indicates that we have data to push over the out of band network + = CanPush UUID [Sha] + -- request that a git push be sent over the out of band network + | PushRequest UUID + -- indicates that a push is starting + | StartingPush UUID + -- a chunk of output of git receive-pack + | ReceivePackOutput SequenceNum ByteString + -- a chuck of output of git send-pack + | SendPackOutput SequenceNum ByteString + -- sent when git receive-pack exits, with its exit code + | ReceivePackDone ExitCode + deriving (Show, Eq, Ord) + +{- A sequence number. Incremented by one per packet in a sequence, + - starting with 1 for the first packet. 0 means sequence numbers are + - not being used. -} +type SequenceNum = Int + +{- NetMessages that are important (and small), and should be stored to be + - resent when new clients are seen. -} +isImportantNetMessage :: NetMessage -> Maybe ClientID +isImportantNetMessage (Pushing c (CanPush _ _)) = Just c +isImportantNetMessage (Pushing c (PushRequest _)) = Just c +isImportantNetMessage _ = Nothing + +{- Checks if two important NetMessages are equivilant. + - That is to say, assuming they were sent to the same client, + - would it do the same thing for one as for the other? -} +equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool +equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True +equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True +equivilantImportantNetMessages _ _ = False + +readdressNetMessage :: NetMessage -> ClientID -> NetMessage +readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid +readdressNetMessage (Pushing _ stage) c = Pushing c stage +readdressNetMessage m _ = m + +{- Convert a NetMessage to something that can be logged. -} +logNetMessage :: NetMessage -> String +logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $ + case stage of + ReceivePackOutput n _ -> ReceivePackOutput n elided + SendPackOutput n _ -> SendPackOutput n elided + s -> s + where + elided = B8.pack "" +logNetMessage (PairingNotification stage c uuid) = + show $ PairingNotification stage (logClientID c) uuid +logNetMessage m = show m + +logClientID :: ClientID -> ClientID +logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c] + +{- Things that initiate either side of a push, but do not actually send data. -} +isPushInitiation :: PushStage -> Bool +isPushInitiation (PushRequest _) = True +isPushInitiation (StartingPush _) = True +isPushInitiation _ = False + +isPushNotice :: PushStage -> Bool +isPushNotice (CanPush _ _) = True +isPushNotice _ = False + +data PushSide = SendPack | ReceivePack + deriving (Eq, Ord, Show) + +pushDestinationSide :: PushStage -> PushSide +pushDestinationSide (CanPush _ _) = ReceivePack +pushDestinationSide (PushRequest _) = SendPack +pushDestinationSide (StartingPush _) = ReceivePack +pushDestinationSide (ReceivePackOutput _ _) = SendPack +pushDestinationSide (SendPackOutput _ _) = ReceivePack +pushDestinationSide (ReceivePackDone _) = SendPack + +type SideMap a = PushSide -> a + +mkSideMap :: STM a -> IO (SideMap a) +mkSideMap gen = do + (sp, rp) <- atomically $ (,) <$> gen <*> gen + return $ lookupside sp rp + where + lookupside sp _ SendPack = sp + lookupside _ rp ReceivePack = rp + +getSide :: PushSide -> SideMap a -> a +getSide side m = m side + +type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage)) + +data NetMessager = NetMessager + -- outgoing messages + { netMessages :: TChan NetMessage + -- important messages for each client + , importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) + -- important messages that are believed to have been sent to a client + , sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) + -- write to this to restart the net messager + , netMessagerRestart :: MSampleVar () + -- queue of incoming messages that request the initiation of pushes + , netMessagerPushInitiations :: SideMap (TMVar [NetMessage]) + -- incoming messages containing data for a running + -- (or not yet started) push + , netMessagerInboxes :: SideMap Inboxes + } + +newNetMessager :: IO NetMessager +newNetMessager = NetMessager + <$> atomically newTChan + <*> atomically (newTMVar M.empty) + <*> atomically (newTMVar M.empty) + <*> newEmptySV + <*> mkSideMap newEmptyTMVar + <*> mkSideMap (newTVar M.empty) diff --git a/Assistant/Types/Pushes.hs b/Assistant/Types/Pushes.hs new file mode 100644 index 0000000000..99e0ee1628 --- /dev/null +++ b/Assistant/Types/Pushes.hs @@ -0,0 +1,24 @@ +{- git-annex assistant push tracking + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.Pushes where + +import Common.Annex + +import Control.Concurrent.STM +import Data.Time.Clock +import qualified Data.Map as M + +{- Track the most recent push failure for each remote. -} +type PushMap = M.Map Remote UTCTime +type FailedPushMap = TMVar PushMap + +{- The TMVar starts empty, and is left empty when there are no + - failed pushes. This way we can block until there are some failed pushes. + -} +newFailedPushMap :: IO FailedPushMap +newFailedPushMap = atomically newEmptyTMVar diff --git a/Assistant/Types/RepoProblem.hs b/Assistant/Types/RepoProblem.hs new file mode 100644 index 0000000000..ece5a52868 --- /dev/null +++ b/Assistant/Types/RepoProblem.hs @@ -0,0 +1,28 @@ +{- git-annex assistant repository problem tracking + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.RepoProblem where + +import Types +import Utility.TList + +import Control.Concurrent.STM +import Data.Function + +data RepoProblem = RepoProblem + { problemUUID :: UUID + , afterFix :: IO () + } + +{- The afterFix actions are assumed to all be equivilant. -} +sameRepoProblem :: RepoProblem -> RepoProblem -> Bool +sameRepoProblem = (==) `on` problemUUID + +type RepoProblemChan = TList RepoProblem + +newRepoProblemChan :: IO RepoProblemChan +newRepoProblemChan = atomically newTList diff --git a/Assistant/Types/ScanRemotes.hs b/Assistant/Types/ScanRemotes.hs new file mode 100644 index 0000000000..8219f9baf1 --- /dev/null +++ b/Assistant/Types/ScanRemotes.hs @@ -0,0 +1,25 @@ +{- git-annex assistant remotes needing scanning + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.ScanRemotes where + +import Common.Annex + +import Control.Concurrent.STM +import qualified Data.Map as M + +data ScanInfo = ScanInfo + { scanPriority :: Float + , fullScan :: Bool + } + +type ScanRemoteMap = TMVar (M.Map Remote ScanInfo) + +{- The TMVar starts empty, and is left empty when there are no remotes + - to scan. -} +newScanRemoteMap :: IO ScanRemoteMap +newScanRemoteMap = atomically newEmptyTMVar diff --git a/Assistant/Types/ThreadName.hs b/Assistant/Types/ThreadName.hs new file mode 100644 index 0000000000..c8d264a381 --- /dev/null +++ b/Assistant/Types/ThreadName.hs @@ -0,0 +1,14 @@ +{- name of a thread + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.ThreadName where + +newtype ThreadName = ThreadName String + deriving (Eq, Read, Show, Ord) + +fromThreadName :: ThreadName -> String +fromThreadName (ThreadName n) = n diff --git a/Assistant/Types/ThreadedMonad.hs b/Assistant/Types/ThreadedMonad.hs new file mode 100644 index 0000000000..1a2aa7eb7f --- /dev/null +++ b/Assistant/Types/ThreadedMonad.hs @@ -0,0 +1,38 @@ +{- making the Annex monad available across threads + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.ThreadedMonad where + +import Common.Annex +import qualified Annex + +import Control.Concurrent +import Data.Tuple + +{- The Annex state is stored in a MVar, so that threaded actions can access + - it. -} +type ThreadState = MVar Annex.AnnexState + +{- Stores the Annex state in a MVar. + - + - Once the action is finished, retrieves the state from the MVar. + -} +withThreadState :: (ThreadState -> Annex a) -> Annex a +withThreadState a = do + state <- Annex.getState id + mvar <- liftIO $ newMVar state + r <- a mvar + newstate <- liftIO $ takeMVar mvar + Annex.changeState (const newstate) + return r + +{- Runs an Annex action, using the state from the MVar. + - + - This serializes calls by threads; only one thread can run in Annex at a + - time. -} +runThreadState :: ThreadState -> Annex a -> IO a +runThreadState mvar a = modifyMVar mvar $ \state -> swap <$> Annex.run state a diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs new file mode 100644 index 0000000000..e4bf2ae922 --- /dev/null +++ b/Assistant/Types/TransferQueue.hs @@ -0,0 +1,29 @@ +{- git-annex assistant pending transfer queue + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.TransferQueue where + +import Common.Annex +import Logs.Transfer + +import Control.Concurrent.STM +import Utility.TList + +data TransferQueue = TransferQueue + { queuesize :: TVar Int + , queuelist :: TList (Transfer, TransferInfo) + , deferreddownloads :: TList (Key, AssociatedFile) + } + +data Schedule = Next | Later + deriving (Eq) + +newTransferQueue :: IO TransferQueue +newTransferQueue = atomically $ TransferQueue + <$> newTVar 0 + <*> newTList + <*> newTList diff --git a/Assistant/Types/TransferSlots.hs b/Assistant/Types/TransferSlots.hs new file mode 100644 index 0000000000..5140995a37 --- /dev/null +++ b/Assistant/Types/TransferSlots.hs @@ -0,0 +1,34 @@ +{- git-annex assistant transfer slots + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE DeriveDataTypeable #-} + +module Assistant.Types.TransferSlots where + +import qualified Control.Exception as E +import qualified Control.Concurrent.MSemN as MSemN +import Data.Typeable + +type TransferSlots = MSemN.MSemN Int + +{- A special exception that can be thrown to pause or resume a transfer, while + - keeping its slot in use. -} +data TransferException = PauseTransfer | ResumeTransfer + deriving (Show, Eq, Typeable) + +instance E.Exception TransferException + +{- Number of concurrent transfers allowed to be run from the assistant. + - + - Transfers launched by other means, including by remote assistants, + - do not currently take up slots. + -} +numSlots :: Int +numSlots = 1 + +newTransferSlots :: IO TransferSlots +newTransferSlots = MSemN.new numSlots diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs new file mode 100644 index 0000000000..2727a69190 --- /dev/null +++ b/Assistant/Types/TransferrerPool.hs @@ -0,0 +1,23 @@ +{- A pool of "git-annex transferkeys" processes + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.TransferrerPool where + +import Common.Annex + +import Control.Concurrent.STM + +type TransferrerPool = TChan Transferrer + +data Transferrer = Transferrer + { transferrerRead :: Handle + , transferrerWrite :: Handle + , transferrerHandle :: ProcessHandle + } + +newTransferrerPool :: IO TransferrerPool +newTransferrerPool = newTChanIO diff --git a/Assistant/Types/UrlRenderer.hs b/Assistant/Types/UrlRenderer.hs new file mode 100644 index 0000000000..521905bf3c --- /dev/null +++ b/Assistant/Types/UrlRenderer.hs @@ -0,0 +1,26 @@ +{- webapp url renderer access from the assistant + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Types.UrlRenderer ( + UrlRenderer, + newUrlRenderer +) where + +#ifdef WITH_WEBAPP + +import Assistant.WebApp (UrlRenderer, newUrlRenderer) + +#else + +data UrlRenderer = UrlRenderer -- dummy type + +newUrlRenderer :: IO UrlRenderer +newUrlRenderer = return UrlRenderer + +#endif diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs new file mode 100644 index 0000000000..ece75d7ba6 --- /dev/null +++ b/Assistant/WebApp.hs @@ -0,0 +1,73 @@ +{- git-annex assistant webapp core + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-} + +module Assistant.WebApp where + +import Assistant.WebApp.Types +import Assistant.Common +import Utility.NotificationBroadcaster +import Utility.Yesod + +import Data.Text (Text) +import Control.Concurrent +import qualified Network.Wai as W +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Text as T + +waitNotifier :: Assistant NotificationBroadcaster -> NotificationId -> Handler () +waitNotifier getbroadcaster nid = liftAssistant $ do + b <- getbroadcaster + liftIO $ waitNotification $ notificationHandleFromId b nid + +newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId +newNotifier getbroadcaster = liftAssistant $ do + b <- getbroadcaster + liftIO $ notificationHandleToId <$> newNotificationHandle True b + +{- Adds the auth parameter as a hidden field on a form. Must be put into + - every form. -} +webAppFormAuthToken :: Widget +webAppFormAuthToken = do + webapp <- liftH getYesod + [whamlet||] + +{- A button with an icon, and maybe label or tooltip, that can be + - clicked to perform some action. + - With javascript, clicking it POSTs the Route, and remains on the same + - page. + - With noscript, clicking it GETs the Route. -} +actionButton :: Route WebApp -> (Maybe String) -> (Maybe String) -> String -> String -> Widget +actionButton route label tooltip buttonclass iconclass = $(widgetFile "actionbutton") + +type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text +type UrlRenderer = MVar (UrlRenderFunc) + +newUrlRenderer :: IO UrlRenderer +newUrlRenderer = newEmptyMVar + +setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO () +setUrlRenderer = putMVar + +inFirstRun :: Handler Bool +inFirstRun = isNothing . relDir <$> getYesod + +{- Blocks until the webapp is running and has called setUrlRenderer. -} +renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text +renderUrl urlrenderer route params = do + r <- readMVar urlrenderer + return $ r route params + +{- Redirects back to the referring page, or if there's none, DashboardR -} +redirectBack :: Handler () +redirectBack = do + mr <- lookup "referer" . W.requestHeaders <$> waiRequest + case mr of + Nothing -> redirect DashboardR + Just r -> redirect $ T.pack $ S8.unpack r diff --git a/Assistant/WebApp/Common.hs b/Assistant/WebApp/Common.hs new file mode 100644 index 0000000000..3bd164569f --- /dev/null +++ b/Assistant/WebApp/Common.hs @@ -0,0 +1,17 @@ +{- git-annex assistant webapp, common imports + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Assistant.WebApp.Common (module X) where + +import Assistant.Common as X +import Assistant.WebApp as X +import Assistant.WebApp.Page as X +import Assistant.WebApp.Form as X +import Assistant.WebApp.Types as X +import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option) + +import Data.Text as X (Text) diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs new file mode 100644 index 0000000000..625546dfee --- /dev/null +++ b/Assistant/WebApp/Configurators.hs @@ -0,0 +1,44 @@ +{- git-annex assistant webapp configurators + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-} + +module Assistant.WebApp.Configurators where + +import Assistant.WebApp.Common +import Assistant.WebApp.RepoList +#ifdef WITH_XMPP +import Assistant.XMPP.Client +#endif + +{- The main configuration screen. -} +getConfigurationR :: Handler Html +getConfigurationR = ifM inFirstRun + ( redirect FirstRepositoryR + , page "Configuration" (Just Configuration) $ do +#ifdef WITH_XMPP + xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds +#else + let xmppconfigured = False +#endif + $(widgetFile "configurators/main") + ) + +getAddRepositoryR :: Handler Html +getAddRepositoryR = page "Add Repository" (Just Configuration) $ do + let repolist = repoListDisplay mainRepoSelector + $(widgetFile "configurators/addrepository") + +makeMiscRepositories :: Widget +makeMiscRepositories = $(widgetFile "configurators/addrepository/misc") + +makeCloudRepositories :: Widget +makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud") + +makeArchiveRepositories :: Widget +makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive") + diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs new file mode 100644 index 0000000000..29f7907768 --- /dev/null +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -0,0 +1,230 @@ +{- git-annex assistant webapp configurators for Amazon AWS services + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} + +module Assistant.WebApp.Configurators.AWS where + +import Assistant.WebApp.Common +import Assistant.WebApp.MakeRemote +#ifdef WITH_S3 +import qualified Remote.S3 as S3 +#endif +import qualified Remote.Glacier as Glacier +import qualified Remote.Helper.AWS as AWS +import Logs.Remote +import qualified Remote +import qualified Types.Remote as Remote +import Types.Remote (RemoteConfig) +import Types.StandardGroups +import Creds +import Assistant.Gpg +import Git.Remote + +import qualified Data.Text as T +import qualified Data.Map as M +import Data.Char + +awsConfigurator :: Widget -> Handler Html +awsConfigurator = page "Add an Amazon repository" (Just Configuration) + +glacierConfigurator :: Widget -> Handler Html +glacierConfigurator a = do + ifM (liftIO $ inPath "glacier") + ( awsConfigurator a + , awsConfigurator needglaciercli + ) + where + needglaciercli = $(widgetFile "configurators/needglaciercli") + +data StorageClass = StandardRedundancy | ReducedRedundancy + deriving (Eq, Enum, Bounded) + +instance Show StorageClass where + show StandardRedundancy = "STANDARD" + show ReducedRedundancy = "REDUCED_REDUNDANCY" + +data AWSInput = AWSInput + { accessKeyID :: Text + , secretAccessKey :: Text + , datacenter :: Text + -- Only used for S3, not Glacier. + , storageClass :: StorageClass + , repoName :: Text + , enableEncryption :: EnableEncryption + } + +data AWSCreds = AWSCreds Text Text + +extractCreds :: AWSInput -> AWSCreds +extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i) + +s3InputAForm :: Maybe CredPair -> MkAForm AWSInput +s3InputAForm defcreds = AWSInput + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> secretAccessKeyField (T.pack . snd <$> defcreds) + <*> datacenterField AWS.S3 + <*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy) + <*> areq textField "Repository name" (Just "S3") + <*> enableEncryptionField + where + storageclasses :: [(Text, StorageClass)] + storageclasses = + [ ("Standard redundancy", StandardRedundancy) + , ("Reduced redundancy (costs less)", ReducedRedundancy) + ] + +glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput +glacierInputAForm defcreds = AWSInput + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> secretAccessKeyField (T.pack . snd <$> defcreds) + <*> datacenterField AWS.Glacier + <*> pure StandardRedundancy + <*> areq textField "Repository name" (Just "glacier") + <*> enableEncryptionField + +awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds +awsCredsAForm defcreds = AWSCreds + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> secretAccessKeyField (T.pack . snd <$> defcreds) + +accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text +accessKeyIDField help = areq (textField `withNote` help) "Access Key ID" + +accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text +accessKeyIDFieldWithHelp = accessKeyIDField help + where + help = [whamlet| + + Get Amazon access keys +|] + +secretAccessKeyField :: Maybe Text -> MkAForm Text +secretAccessKeyField = areq passwordField "Secret Access Key" + +datacenterField :: AWS.Service -> MkAForm Text +datacenterField service = areq (selectFieldList list) "Datacenter" defregion + where + list = M.toList $ AWS.regionMap service + defregion = Just $ AWS.defaultRegion service + +getAddS3R :: Handler Html +getAddS3R = postAddS3R + +postAddS3R :: Handler Html +#ifdef WITH_S3 +postAddS3R = awsConfigurator $ do + defcreds <- liftAnnex previouslyUsedAWSCreds + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap $ s3InputAForm defcreds + case result of + FormSuccess input -> liftH $ do + let name = T.unpack $ repoName input + makeAWSRemote initSpecialRemote S3.remote TransferGroup (extractCreds input) name $ M.fromList + [ configureEncryption $ enableEncryption input + , ("type", "S3") + , ("datacenter", T.unpack $ datacenter input) + , ("storageclass", show $ storageClass input) + ] + _ -> $(widgetFile "configurators/adds3") +#else +postAddS3R = error "S3 not supported by this build" +#endif + +getAddGlacierR :: Handler Html +getAddGlacierR = postAddGlacierR + +postAddGlacierR :: Handler Html +#ifdef WITH_S3 +postAddGlacierR = glacierConfigurator $ do + defcreds <- liftAnnex previouslyUsedAWSCreds + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap $ glacierInputAForm defcreds + case result of + FormSuccess input -> liftH $ do + let name = T.unpack $ repoName input + makeAWSRemote initSpecialRemote Glacier.remote SmallArchiveGroup (extractCreds input) name $ M.fromList + [ configureEncryption $ enableEncryption input + , ("type", "glacier") + , ("datacenter", T.unpack $ datacenter input) + ] + _ -> $(widgetFile "configurators/addglacier") +#else +postAddGlacierR = error "S3 not supported by this build" +#endif + +getEnableS3R :: UUID -> Handler Html +#ifdef WITH_S3 +getEnableS3R uuid = do + m <- liftAnnex readRemoteLog + if isIARemoteConfig $ fromJust $ M.lookup uuid m + then redirect $ EnableIAR uuid + else postEnableS3R uuid +#else +getEnableS3R = postEnableS3R +#endif + +postEnableS3R :: UUID -> Handler Html +#ifdef WITH_S3 +postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid +#else +postEnableS3R _ = error "S3 not supported by this build" +#endif + +getEnableGlacierR :: UUID -> Handler Html +getEnableGlacierR = postEnableGlacierR + +postEnableGlacierR :: UUID -> Handler Html +postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote + +enableAWSRemote :: RemoteType -> UUID -> Widget +#ifdef WITH_S3 +enableAWSRemote remotetype uuid = do + defcreds <- liftAnnex previouslyUsedAWSCreds + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap $ awsCredsAForm defcreds + case result of + FormSuccess creds -> liftH $ do + m <- liftAnnex readRemoteLog + let name = fromJust $ M.lookup "name" $ + fromJust $ M.lookup uuid m + makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty + _ -> do + description <- liftAnnex $ + T.pack <$> Remote.prettyUUID uuid + $(widgetFile "configurators/enableaws") +#else +enableAWSRemote _ _ = error "S3 not supported by this build" +#endif + +makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler () +makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do + liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk) + setupCloudRemote defaultgroup Nothing $ + maker hostname remotetype config + where + {- AWS services use the remote name as the basis for a host + - name, so filter it to contain valid characters. -} + hostname = case filter isAlphaNum name of + [] -> "aws" + n -> n + +getRepoInfo :: RemoteConfig -> Widget +getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|] + where + bucket = fromMaybe "" $ M.lookup "bucket" c + +#ifdef WITH_S3 +isIARemoteConfig :: RemoteConfig -> Bool +isIARemoteConfig = S3.isIAHost . fromMaybe "" . M.lookup "host" + +previouslyUsedAWSCreds :: Annex (Maybe CredPair) +previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote] + where + gettype t = previouslyUsedCredPair AWS.creds t $ + not . isIARemoteConfig . Remote.config +#endif diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs new file mode 100644 index 0000000000..c29e4a681a --- /dev/null +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -0,0 +1,132 @@ +{- git-annex assistant webapp repository deletion + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} + +module Assistant.WebApp.Configurators.Delete where + +import Assistant.WebApp.Common +import Assistant.DeleteRemote +import Assistant.DaemonStatus +import Assistant.ScanRemotes +import Assistant.Sync +import qualified Remote +import qualified Git +import Config.Files +import Utility.FileMode +import Logs.Trust +import Logs.Remote +import Logs.PreferredContent +import Types.StandardGroups +import Annex.UUID + +import System.IO.HVFS (SystemFS(..)) +import qualified Data.Text as T +import qualified Data.Map as M +import System.Path + +notCurrentRepo :: UUID -> Handler Html -> Handler Html +notCurrentRepo uuid a = do + u <- liftAnnex getUUID + if u == uuid + then redirect DeleteCurrentRepositoryR + else go =<< liftAnnex (Remote.remoteFromUUID uuid) + where + go Nothing = error "Unknown UUID" + go (Just _) = a + +getDisableRepositoryR :: UUID -> Handler Html +getDisableRepositoryR uuid = notCurrentRepo uuid $ do + void $ liftAssistant $ disableRemote uuid + redirect DashboardR + +getDeleteRepositoryR :: UUID -> Handler Html +getDeleteRepositoryR uuid = notCurrentRepo uuid $ + deletionPage $ do + reponame <- liftAnnex $ Remote.prettyUUID uuid + $(widgetFile "configurators/delete/start") + +getStartDeleteRepositoryR :: UUID -> Handler Html +getStartDeleteRepositoryR uuid = do + remote <- fromMaybe (error "unknown remote") + <$> liftAnnex (Remote.remoteFromUUID uuid) + liftAnnex $ do + trustSet uuid UnTrusted + setStandardGroup uuid UnwantedGroup + liftAssistant $ addScanRemotes True [remote] + redirect DashboardR + +getFinishDeleteRepositoryR :: UUID -> Handler Html +getFinishDeleteRepositoryR uuid = deletionPage $ do + void $ liftAssistant $ removeRemote uuid + + reponame <- liftAnnex $ Remote.prettyUUID uuid + {- If it's not listed in the remote log, it must be a git repo. -} + gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog + $(widgetFile "configurators/delete/finished") + +getDeleteCurrentRepositoryR :: Handler Html +getDeleteCurrentRepositoryR = deleteCurrentRepository + +postDeleteCurrentRepositoryR :: Handler Html +postDeleteCurrentRepositoryR = deleteCurrentRepository + +deleteCurrentRepository :: Handler Html +deleteCurrentRepository = dangerPage $ do + reldir <- fromJust . relDir <$> liftH getYesod + havegitremotes <- haveremotes syncGitRemotes + havedataremotes <- haveremotes syncDataRemotes + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap $ sanityVerifierAForm $ + SanityVerifier magicphrase + case result of + FormSuccess _ -> liftH $ do + dir <- liftAnnex $ fromRepo Git.repoPath + liftIO $ removeAutoStartFile dir + + {- Disable syncing to this repository, and all + - remotes. This stops all transfers, and all + - file watching. -} + liftAssistant $ do + changeSyncable Nothing False + rs <- syncRemotes <$> getDaemonStatus + mapM_ (\r -> changeSyncable (Just r) False) rs + + {- Make all directories writable, so all annexed + - content can be deleted. -} + liftIO $ do + recurseDir SystemFS dir >>= + filterM doesDirectoryExist >>= + mapM_ allowWrite + removeDirectoryRecursive dir + + redirect ShutdownConfirmedR + _ -> $(widgetFile "configurators/delete/currentrepository") + where + haveremotes selector = not . null . selector + <$> liftAssistant getDaemonStatus + +data SanityVerifier = SanityVerifier T.Text + deriving (Eq) + +sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier +sanityVerifierAForm template = SanityVerifier + <$> areq checksanity "Confirm deletion?" Nothing + where + checksanity = checkBool (\input -> SanityVerifier input == template) + insane textField + + insane = "Maybe this is not a good idea..." :: Text + +deletionPage :: Widget -> Handler Html +deletionPage = page "Delete repository" (Just Configuration) + +dangerPage :: Widget -> Handler Html +dangerPage = page "Danger danger danger" (Just Configuration) + +magicphrase :: Text +magicphrase = "Yes, please do as I say!" diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs new file mode 100644 index 0000000000..dc25c44550 --- /dev/null +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -0,0 +1,247 @@ +{- git-annex assistant webapp configurator for editing existing repos + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} + +module Assistant.WebApp.Configurators.Edit where + +import Assistant.WebApp.Common +import Assistant.WebApp.Gpg +import Assistant.DaemonStatus +import Assistant.WebApp.MakeRemote (uniqueRemoteName) +import Assistant.WebApp.Configurators.XMPP (xmppNeeded) +import Assistant.ScanRemotes +import Assistant.Sync +import qualified Assistant.WebApp.Configurators.AWS as AWS +import qualified Assistant.WebApp.Configurators.IA as IA +#ifdef WITH_S3 +import qualified Remote.S3 as S3 +#endif +import qualified Remote +import qualified Types.Remote as Remote +import qualified Remote.List as Remote +import Logs.UUID +import Logs.Group +import Logs.PreferredContent +import Logs.Remote +import Types.StandardGroups +import qualified Git +import qualified Git.Command +import qualified Git.Config +import qualified Annex +import Git.Remote +import Remote.Helper.Encryptable (extractCipher) +import Types.Crypto +import Utility.Gpg +import Annex.UUID + +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.Set as S + +data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup + deriving (Show, Eq) + +data RepoConfig = RepoConfig + { repoName :: Text + , repoDescription :: Maybe Text + , repoGroup :: RepoGroup + , repoAssociatedDirectory :: Maybe Text + , repoSyncable :: Bool + } + deriving (Show) + +getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig +getRepoConfig uuid mremote = do + groups <- lookupGroups uuid + remoteconfig <- M.lookup uuid <$> readRemoteLog + let (repogroup, associateddirectory) = case getStandardGroup groups of + Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing) + Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g) + + description <- fmap T.pack . M.lookup uuid <$> uuidMap + + syncable <- case mremote of + Just r -> return $ remoteAnnexSync $ Remote.gitconfig r + Nothing -> annexAutoCommit <$> Annex.getGitConfig + + return $ RepoConfig + (T.pack $ maybe "here" Remote.name mremote) + description + repogroup + (T.pack <$> associateddirectory) + syncable + +setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler () +setRepoConfig uuid mremote oldc newc = do + when descriptionChanged $ liftAnnex $ do + maybe noop (describeUUID uuid . T.unpack) (repoDescription newc) + void uuidMapLoad + when nameChanged $ do + liftAnnex $ do + name <- fromRepo $ uniqueRemoteName (legalName newc) 0 + {- git remote rename expects there to be a + - remote..fetch, and exits nonzero if + - there's not. Special remotes don't normally + - have that, and don't use it. Temporarily add + - it if it's missing. -} + let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch" + needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch) + when needfetch $ + inRepo $ Git.Command.run + [Param "config", Param remotefetch, Param ""] + inRepo $ Git.Command.run + [ Param "remote" + , Param "rename" + , Param $ T.unpack $ repoName oldc + , Param name + ] + void Remote.remoteListRefresh + liftAssistant updateSyncRemotes + when associatedDirectoryChanged $ case repoAssociatedDirectory newc of + Nothing -> noop + Just t + | T.null t -> noop + | otherwise -> liftAnnex $ do + let dir = takeBaseName $ T.unpack t + m <- readRemoteLog + case M.lookup uuid m of + Nothing -> noop + Just remoteconfig -> configSet uuid $ + M.insert "preferreddir" dir remoteconfig + when groupChanged $ do + liftAnnex $ case repoGroup newc of + RepoGroupStandard g -> setStandardGroup uuid g + RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s + {- Enabling syncing will cause a scan, + - so avoid queueing a duplicate scan. -} + when (repoSyncable newc && not syncableChanged) $ liftAssistant $ + case mremote of + Just remote -> addScanRemotes True [remote] + Nothing -> addScanRemotes True + =<< syncDataRemotes <$> getDaemonStatus + when syncableChanged $ + liftAssistant $ changeSyncable mremote (repoSyncable newc) + where + syncableChanged = repoSyncable oldc /= repoSyncable newc + associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc + groupChanged = repoGroup oldc /= repoGroup newc + nameChanged = isJust mremote && legalName oldc /= legalName newc + descriptionChanged = repoDescription oldc /= repoDescription newc + + legalName = makeLegalName . T.unpack . repoName + +editRepositoryAForm :: Bool -> RepoConfig -> MkAForm RepoConfig +editRepositoryAForm ishere def = RepoConfig + <$> areq (if ishere then readonlyTextField else textField) + "Name" (Just $ repoName def) + <*> aopt textField "Description" (Just $ repoDescription def) + <*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def) + <*> associateddirectory + <*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def) + where + groups = customgroups ++ standardgroups + standardgroups :: [(Text, RepoGroup)] + standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) + [minBound :: StandardGroup .. maxBound :: StandardGroup] + customgroups :: [(Text, RepoGroup)] + customgroups = case repoGroup def of + RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)] + _ -> [] + help = [whamlet|What's this?|] + + associateddirectory = case repoAssociatedDirectory def of + Nothing -> aopt hiddenField "" Nothing + Just d -> aopt textField "Associated directory" (Just $ Just d) + +getEditRepositoryR :: UUID -> Handler Html +getEditRepositoryR = postEditRepositoryR + +postEditRepositoryR :: UUID -> Handler Html +postEditRepositoryR = editForm False + +getEditNewRepositoryR :: UUID -> Handler Html +getEditNewRepositoryR = postEditNewRepositoryR + +postEditNewRepositoryR :: UUID -> Handler Html +postEditNewRepositoryR = editForm True + +getEditNewCloudRepositoryR :: UUID -> Handler Html +getEditNewCloudRepositoryR = postEditNewCloudRepositoryR + +postEditNewCloudRepositoryR :: UUID -> Handler Html +postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid + +editForm :: Bool -> UUID -> Handler Html +editForm new uuid = page "Edit repository" (Just Configuration) $ do + mremote <- liftAnnex $ Remote.remoteFromUUID uuid + when (mremote == Nothing) $ + whenM ((/=) uuid <$> liftAnnex getUUID) $ + error "unknown remote" + curr <- liftAnnex $ getRepoConfig uuid mremote + liftAnnex $ checkAssociatedDirectory curr mremote + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap $ editRepositoryAForm (isNothing mremote) curr + case result of + FormSuccess input -> liftH $ do + setRepoConfig uuid mremote curr input + liftAnnex $ checkAssociatedDirectory input mremote + redirect DashboardR + _ -> do + let istransfer = repoGroup curr == RepoGroupStandard TransferGroup + config <- liftAnnex $ M.lookup uuid <$> readRemoteLog + let repoInfo = getRepoInfo mremote config + let repoEncryption = getRepoEncryption mremote config + $(widgetFile "configurators/editrepository") + +{- Makes any directory associated with the repository. -} +checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex () +checkAssociatedDirectory _ Nothing = noop +checkAssociatedDirectory cfg (Just r) = do + repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog + case repoGroup cfg of + RepoGroupStandard gr -> case associatedDirectory repoconfig gr of + Just d -> inRepo $ \g -> + createDirectoryIfMissing True $ + Git.repoPath g d + Nothing -> noop + _ -> noop + +getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget +getRepoInfo (Just r) (Just c) = case M.lookup "type" c of + Just "S3" +#ifdef WITH_S3 + | S3.isIA c -> IA.getRepoInfo c +#endif + | otherwise -> AWS.getRepoInfo c + Just t + | t /= "git" -> [whamlet|#{t} remote|] + _ -> getGitRepoInfo $ Remote.repo r +getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r) +getRepoInfo _ _ = [whamlet|git repository|] + +getGitRepoInfo :: Git.Repo -> Widget +getGitRepoInfo r = do + let loc = Git.repoLocation r + [whamlet|git repository located at #{loc}|] + +getRepoEncryption :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget +getRepoEncryption (Just _) (Just c) = case extractCipher c of + Nothing -> + [whamlet|not encrypted|] + (Just (SharedCipher _)) -> + [whamlet|encrypted: encryption key stored in git repository|] + (Just (EncryptedCipher _ _ (KeyIds { keyIds = ks }))) -> do + knownkeys <- liftIO secretKeys + [whamlet| +encrypted using gpg key: +