diff --git a/.forgejo/patches/ghc-9.8.patch b/.forgejo/patches/ghc-9.8.patch deleted file mode 100644 index 85796d787d..0000000000 --- a/.forgejo/patches/ghc-9.8.patch +++ /dev/null @@ -1,18 +0,0 @@ -Support ghc-9.8 by widening a lot of constraints. - -This patch can be removed once upstream supports ghc 9.8 offically. - -diff -uprN git-annex-10.20240227.orig/cabal.project git-annex-10.20240227/cabal.project ---- git-annex-10.20240227.orig/cabal.project 1970-01-01 01:00:00.000000000 +0100 -+++ git-annex-10.20240227/cabal.project 2024-04-28 13:30:14.061706299 +0200 -@@ -0,0 +1,10 @@ -+packages: *.cabal -+ -+allow-newer: dav -+allow-newer: haskeline:filepath -+allow-newer: haskeline:directory -+allow-newer: xml-hamlet -+allow-newer: aws:filepath -+allow-newer: dbus:network -+allow-newer: dbus:filepath -+allow-newer: microstache:filepath diff --git a/.forgejo/workflows/generate-lockfile.yml b/.forgejo/workflows/generate-lockfile.yml deleted file mode 100644 index 8dbb579e67..0000000000 --- a/.forgejo/workflows/generate-lockfile.yml +++ /dev/null @@ -1,89 +0,0 @@ -on: - workflow_dispatch: - inputs: - ref_name: - description: 'Tag or commit' - required: true - type: string - - push: - tags: - - '*' - -jobs: - cabal-config-edge: - name: Generate cabal config for edge - runs-on: x86_64 - container: - image: alpine:edge - env: - CI_ALPINE_TARGET_RELEASE: edge - steps: - - name: Environment setup - run: | - apk upgrade -a - apk add nodejs git cabal patch - - name: Repo pull - uses: actions/checkout@v4 - with: - fetch-depth: 1 - ref: ${{ inputs.ref_name }} - - name: Config generation - run: | - patch -p1 -i .forgejo/patches/ghc-9.8.patch - HOME="${{ github.workspace}}"/cabal_cache cabal update - HOME="${{ github.workspace}}"/cabal_cache cabal v2-freeze --shadow-installed-packages --strong-flags --flags="+assistant +webapp +pairing +production +torrentparser +magicmime +benchmark -debuglocks +dbus +networkbsd +gitlfs +httpclientrestricted" - mv cabal.project.freeze git-annex.config - - name: Package upload - uses: forgejo/upload-artifact@v3 - with: - name: cabalconfigedge - path: git-annex*.config - cabal-config-v322: - name: Generate cabal config for v3.22 - runs-on: x86_64 - container: - image: alpine:3.22 - env: - CI_ALPINE_TARGET_RELEASE: v3.22 - steps: - - name: Environment setup - run: | - apk upgrade -a - apk add nodejs git cabal patch - - name: Repo pull - uses: actions/checkout@v4 - with: - fetch-depth: 1 - ref: ${{ inputs.ref_name }} - - name: Config generation - run: | - patch -p1 -i .forgejo/patches/ghc-9.8.patch - HOME="${{ github.workspace }}"/cabal_cache cabal update - HOME="${{ github.workspace }}"/cabal_cache cabal v2-freeze --shadow-installed-packages --strong-flags --flags="+assistant +webapp +pairing +production +torrentparser +magicmime +benchmark -debuglocks +dbus +networkbsd +gitlfs +httpclientrestricted" - mv cabal.project.freeze git-annex.config - - name: Package upload - uses: forgejo/upload-artifact@v3 - with: - name: cabalconfig322 - path: git-annex*.config - upload-tarball: - name: Upload to generic repo - runs-on: x86_64 - needs: [cabal-config-edge,cabal-config-v322] - container: - image: alpine:latest - steps: - - name: Environment setup - run: apk add nodejs curl findutils - - name: Package download - uses: forgejo/download-artifact@v3 - - name: Package deployment - run: | - if test $GITHUB_REF_NAME == "ci" ; then - CI_REF_NAME=${{ inputs.ref_name }} - else - CI_REF_NAME=$GITHUB_REF_NAME - fi - curl --user ${{ vars.CODE_FORGEJO_USER }}:${{ secrets.CODE_FORGEJO_TOKEN }} --upload-file ./cabalconfigedge/git-annex.config ${{ github.server_url }}/api/packages/mirrors/generic/git-annex/$CI_REF_NAME/git-annex-$CI_REF_NAME-edge.cabal - curl --user ${{ vars.CODE_FORGEJO_USER }}:${{ secrets.CODE_FORGEJO_TOKEN }} --upload-file ./cabalconfig322/git-annex.config ${{ github.server_url }}/api/packages/mirrors/generic/git-annex/$CI_REF_NAME/git-annex-$CI_REF_NAME-v322.cabal diff --git a/.forgejo/workflows/mirror-repository.yml b/.forgejo/workflows/mirror-repository.yml deleted file mode 100644 index f44c4668cf..0000000000 --- a/.forgejo/workflows/mirror-repository.yml +++ /dev/null @@ -1,50 +0,0 @@ -on: - workflow_dispatch: - - schedule: - - cron: '@hourly' - -jobs: - mirror: - name: Pull from upstream - runs-on: x86_64 - container: - image: alpine:latest - env: - upstream: https://git.joeyh.name/git/git-annex.git - tags: '10.2025*' - steps: - - name: Environment setup - run: apk add grep git sed coreutils bash nodejs - - name: Fetch destination - uses: actions/checkout@v4 - with: - fetch_depth: 1 - ref: ci - token: ${{ secrets.CODE_FORGEJO_TOKEN }} - - name: Missing tag detecting - run: | - git ls-remote $upstream "refs/tags/$tags" | grep -v '{' | sed 's|.*/||' | sort > upstream_tags - git ls-remote ${{ github.server_url}}/${{ github.repository }} "refs/tags/$tags" | grep -v '{' | sed 's|.*/||' | sort > destination_tags - comm -23 upstream_tags destination_tags > missing_tags - echo "Missing tags:" - cat missing_tags - - name: Missing tag fetch - run: | - git remote add upstream $upstream - while read tag; do - git fetch upstream tag $tag --no-tags - done < missing_tags - - name: Packaging workflow injection - run: | - while read tag; do - git checkout $tag - git tag -d $tag - git checkout ci -- ./.forgejo - git config user.name "forgejo-actions[bot]" - git config user.email "dev@ayakael.net" - git commit -m 'Inject custom workflow' - git tag -a $tag -m $tag - done < missing_tags - - name: Push to destination - run: git push --force origin refs/tags/*:refs/tags/* --tags 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/.gitattributes b/.gitattributes new file mode 100644 index 0000000000..5d425843f2 --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +debian/changelog merge=dpkg-mergechangelogs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..0e90a5f801 --- /dev/null +++ b/.gitignore @@ -0,0 +1,35 @@ +tags +Setup +*.hi +*.o +tmp +test +build-stamp +Build/SysConfig.hs +Build/InstallDesktopFile +Build/EvilSplicer +Build/Standalone +Build/OSXMkLibs +Build/LinuxMkLibs +Build/BuildVersion +git-annex +git-annex.1 +git-annex-shell.1 +git-union-merge +git-union-merge.1 +doc/.ikiwiki +html +*.tix +.hpc +dist +# Sandboxed builds +cabal-dev +.cabal-sandbox +cabal.sandbox.config +cabal.config +# Project-local emacs configuration +.dir-locals.el +# OSX related +.DS_Store +.virthualenv +.tasty-rerun-log diff --git a/.mailmap b/.mailmap new file mode 100644 index 0000000000..275b236df9 --- /dev/null +++ b/.mailmap @@ -0,0 +1,7 @@ +Joey Hess http://joey.kitenet.net/ +Joey Hess http://joeyh.name/ +Joey Hess http://joeyh.name/ +Yaroslav Halchenko +Yaroslav Halchenko http://yarikoptic.myopenid.com/ +Yaroslav Halchenko https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY +Richard Hartmann https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U diff --git a/Annex.hs b/Annex.hs new file mode 100644 index 0000000000..f85c7e0f22 --- /dev/null +++ b/Annex.hs @@ -0,0 +1,312 @@ +{- git-annex monad + - + - Copyright 2010-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-} + +module Annex ( + Annex, + AnnexState(..), + new, + run, + eval, + getState, + changeState, + withState, + setFlag, + setField, + setOutput, + getFlag, + getField, + addCleanup, + gitRepo, + inRepo, + fromRepo, + calcRepo, + getGitConfig, + changeGitConfig, + changeGitRepo, + getRemoteGitConfig, + withCurrentState, + changeDirectory, +) where + +import Common +import qualified Git +import qualified Git.Config +import Annex.Direct.Fixup +import Git.CatFile +import Git.CheckAttr +import Git.CheckIgnore +import Git.SharedRepository +import qualified Git.Hook +import qualified Git.Queue +import Types.Key +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 Types.NumCopies +import Types.LockPool +import Types.MetaData +import Types.DesktopNotify +import Types.CleanupActions +#ifdef WITH_QUVI +import Utility.Quvi (QuviVersion) +#endif +import Utility.InodeCache +import Utility.Url + +import "mtl" Control.Monad.Reader +import Control.Concurrent +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. + - The MVar is not exposed outside this module. + - + - Note that when an Annex action fails and the exception is caught, + - ny changes the action has made to the AnnexState are retained, + - due to the use of the MVar to store the state. + -} +newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a } + deriving ( + Monad, + MonadIO, + MonadReader (MVar AnnexState), + MonadCatch, + MonadThrow, + MonadMask, + Functor, + Applicative + ) + +-- internal state storage +data AnnexState = AnnexState + { repo :: Git.Repo + , gitconfig :: GitConfig + , backends :: [BackendA Annex] + , remotes :: [Types.Remote.RemoteA Annex] + , remoteannexstate :: M.Map UUID AnnexState + , 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 + , globalnumcopies :: Maybe NumCopies + , forcenumcopies :: Maybe NumCopies + , limit :: ExpandableMatcher Annex + , uuidmap :: Maybe UUIDMap + , preferredcontentmap :: Maybe (FileMatcherMap Annex) + , requiredcontentmap :: Maybe (FileMatcherMap Annex) + , shared :: Maybe SharedRepository + , forcetrust :: TrustMap + , trustmap :: Maybe TrustMap + , groupmap :: Maybe GroupMap + , ciphers :: M.Map StorableCipher Cipher + , lockpool :: LockPool + , flags :: M.Map String Bool + , fields :: M.Map String String + , modmeta :: [ModMeta] + , cleanup :: M.Map CleanupAction (Annex ()) + , sentinalstatus :: Maybe SentinalStatus + , useragent :: Maybe String + , errcounter :: Integer + , unusedkeys :: Maybe (S.Set Key) + , tempurls :: M.Map Key URLString +#ifdef WITH_QUVI + , quviversion :: Maybe QuviVersion +#endif + , existinghooks :: M.Map Git.Hook.Hook Bool + , desktopnotify :: DesktopNotify + } + +newState :: GitConfig -> Git.Repo -> AnnexState +newState c r = AnnexState + { repo = r + , gitconfig = c + , backends = [] + , remotes = [] + , remoteannexstate = M.empty + , output = defaultMessageState + , force = False + , fast = False + , auto = False + , daemon = False + , branchstate = startBranchState + , repoqueue = Nothing + , catfilehandles = M.empty + , checkattrhandle = Nothing + , checkignorehandle = Nothing + , forcebackend = Nothing + , globalnumcopies = Nothing + , forcenumcopies = Nothing + , limit = BuildingMatcher [] + , uuidmap = Nothing + , preferredcontentmap = Nothing + , requiredcontentmap = Nothing + , shared = Nothing + , forcetrust = M.empty + , trustmap = Nothing + , groupmap = Nothing + , ciphers = M.empty + , lockpool = M.empty + , flags = M.empty + , fields = M.empty + , modmeta = [] + , cleanup = M.empty + , sentinalstatus = Nothing + , useragent = Nothing + , errcounter = 0 + , unusedkeys = Nothing + , tempurls = M.empty +#ifdef WITH_QUVI + , quviversion = Nothing +#endif + , existinghooks = M.empty + , desktopnotify = mempty + } + +{- 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 r = do + r' <- Git.Config.read =<< Git.relPath r + let c = extractGitConfig r' + newState c <$> if annexDirect c then fixupDirect r' else return r' + +{- 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 + +withState :: (AnnexState -> (AnnexState, b)) -> Annex b +withState 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 :: CleanupAction -> Annex () -> Annex () +addCleanup k a = changeState $ \s -> + s { cleanup = M.insertWith' const k 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 + } + +{- Gets the RemoteGitConfig from a remote, given the Git.Repo for that + - remote. -} +getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig +getRemoteGitConfig r = do + g <- gitRepo + return $ extractRemoteGitConfig g (Git.repoDescribe 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 + +{- It's not safe to use setCurrentDirectory in the Annex monad, + - because the git repo paths are stored relative. + - Instead, use this. + -} +changeDirectory :: FilePath -> Annex () +changeDirectory d = do + r <- liftIO . Git.adjustPath absPath =<< gitRepo + liftIO $ setCurrentDirectory d + r' <- liftIO $ Git.relPath r + changeState $ \s -> s { repo = r' } diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs new file mode 100644 index 0000000000..f0f183dfb5 --- /dev/null +++ b/Annex/AutoMerge.hs @@ -0,0 +1,206 @@ +{- git-annex automatic merge conflict resolution + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.AutoMerge + ( autoMergeFrom + , resolveMerge + , commitResolvedMerge + ) where + +import Common.Annex +import qualified Annex.Queue +import Annex.Direct +import Annex.CatFile +import Annex.Link +import qualified Git.LsFiles as LsFiles +import qualified Git.UpdateIndex as UpdateIndex +import qualified Git.Merge +import qualified Git.Ref +import qualified Git +import qualified Git.Branch +import Git.Types (BlobType(..)) +import Config +import Annex.ReplaceFile +import Git.FileMode +import Annex.VariantFile + +import qualified Data.Set as S + +{- Merges from a branch into the current branch + - (which may not exist yet), + - with automatic merge conflict resolution. + - + - Callers should use Git.Branch.changed first, to make sure that + - there are changed from the current branch to the branch being merged in. + -} +autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Git.Branch.CommitMode -> Annex Bool +autoMergeFrom branch currbranch commitmode = do + showOutput + case currbranch of + Nothing -> go Nothing + Just b -> go =<< inRepo (Git.Ref.sha b) + where + go old = ifM isDirect + ( mergeDirect currbranch old branch (resolveMerge old branch) commitmode + , inRepo (Git.Merge.mergeNonInteractive branch commitmode) + <||> (resolveMerge old branch <&&> commitResolvedMerge commitmode) + ) + +{- Resolves a conflicted merge. It's important that any conflicts be + - resolved in a way that itself avoids later merge conflicts, since + - multiple repositories may be doing this concurrently. + - + - Only merge conflicts where at least one side is an annexed file + - is resolved. + - + - This uses the Keys pointed to by the files to construct new + - filenames. So when both sides modified annexed file foo, + - it will be deleted, and replaced with files foo.variant-A and + - foo.variant-B. + - + - On the other hand, when one side deleted foo, and the other modified it, + - it will be deleted, and the modified version stored as file + - foo.variant-A (or B). + - + - It's also possible that one side has foo as an annexed file, and + - the other as a directory or non-annexed file. The annexed file + - is renamed to resolve the merge, and the other object is preserved as-is. + - + - In indirect mode, the merge is resolved in the work tree and files + - staged, to clean up from a conflicted merge that was run in the work + - tree. + - + - In direct mode, the work tree is not touched here; files are staged to + - the index, and written to the gitAnnexMergeDir, for later handling by + - the direct mode merge code. + -} +resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool +resolveMerge us them = do + top <- fromRepo Git.repoPath + (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) + mergedfs <- catMaybes <$> mapM (resolveMerge' us them) fs + let merged = not (null mergedfs) + void $ liftIO cleanup + + unlessM isDirect $ do + (deleted, cleanup2) <- inRepo (LsFiles.deleted [top]) + unless (null deleted) $ + Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted + void $ liftIO cleanup2 + + when merged $ do + unlessM isDirect $ + cleanConflictCruft mergedfs top + Annex.Queue.flush + showLongNote "Merge conflict was automatically resolved; you may want to examine the result." + return merged + +resolveMerge' :: Maybe Git.Ref -> Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath) +resolveMerge' Nothing _ _ = return Nothing +resolveMerge' (Just us) them u = do + kus <- getkey LsFiles.valUs LsFiles.valUs + kthem <- getkey LsFiles.valThem LsFiles.valThem + case (kus, kthem) of + -- Both sides of conflict are annexed files + (Just keyUs, Just keyThem) + | keyUs /= keyThem -> resolveby $ do + makelink keyUs + makelink keyThem + | otherwise -> resolveby $ + makelink keyUs + -- Our side is annexed file, other side is not. + (Just keyUs, Nothing) -> resolveby $ do + graftin them file LsFiles.valThem LsFiles.valThem + makelink keyUs + -- Our side is not annexed file, other side is. + (Nothing, Just keyThem) -> resolveby $ do + graftin us file LsFiles.valUs LsFiles.valUs + makelink keyThem + -- Neither side is annexed file; cannot resolve. + (Nothing, Nothing) -> return Nothing + where + file = LsFiles.unmergedFile u + + getkey select select' + | select (LsFiles.unmergedBlobType u) == Just SymlinkBlob = + case select' (LsFiles.unmergedSha u) of + Nothing -> return Nothing + Just sha -> catKey sha symLinkMode + | otherwise = return Nothing + + makelink key = do + let dest = variantFile file key + l <- calcRepo $ gitAnnexLink dest key + replacewithlink dest l + stageSymlink dest =<< hashSymlink l + + replacewithlink dest link = ifM isDirect + ( do + d <- fromRepo gitAnnexMergeDir + replaceFile (d dest) $ makeGitLink link + , replaceFile dest $ makeGitLink link + ) + + {- Stage a graft of a directory or file from a branch. + - + - When there is a conflicted merge where one side is a directory + - or file, and the other side is a symlink, git merge always + - updates the work tree to contain the non-symlink. So, the + - directory or file will already be in the work tree correctly, + - and they just need to be staged into place. Do so by copying the + - index. (Note that this is also better than calling git-add + - because on a crippled filesystem, it preserves any symlink + - bits.) + - + - It's also possible for the branch to have a symlink in it, + - which is not a git-annex symlink. In this special case, + - git merge does not update the work tree to contain the symlink + - from the branch, so we have to do so manually. + -} + graftin b item select select' = do + Annex.Queue.addUpdateIndex + =<< fromRepo (UpdateIndex.lsSubTree b item) + when (select (LsFiles.unmergedBlobType u) == Just SymlinkBlob) $ + case select' (LsFiles.unmergedSha u) of + Nothing -> noop + Just sha -> do + link <- catLink True sha + replacewithlink item link + + resolveby a = do + {- Remove conflicted file from index so merge can be resolved. -} + Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file] + void a + return (Just file) + +{- git-merge moves conflicting files away to files + - named something like f~HEAD or f~branch or just f, but the + - exact name chosen can vary. Once the conflict is resolved, + - this cruft can be deleted. To avoid deleting legitimate + - files that look like this, only delete files that are + - A) not staged in git and B) look like git-annex symlinks. + -} +cleanConflictCruft :: [FilePath] -> FilePath -> Annex () +cleanConflictCruft resolvedfs top = do + (fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top] + mapM_ clean fs + void $ liftIO cleanup + where + clean f + | matchesresolved f = whenM (isJust <$> isAnnexLink f) $ + liftIO $ nukeFile f + | otherwise = noop + s = S.fromList resolvedfs + matchesresolved f = S.member f s || S.member (base f) s + base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f + +commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool +commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode + [ Param "--no-verify" + , Param "-m" + , Param "git-annex automatic merge conflict fix" + ] diff --git a/Annex/Branch.hs b/Annex/Branch.hs new file mode 100644 index 0000000000..6ce711996e --- /dev/null +++ b/Annex/Branch.hs @@ -0,0 +1,559 @@ +{- management of the git-annex branch + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Branch ( + fullname, + name, + hasOrigin, + hasSibling, + siblingBranches, + create, + update, + forceUpdate, + updateTo, + get, + getHistorical, + change, + commit, + forceCommit, + files, + withIndex, + performTransitions, +) where + +import qualified Data.ByteString.Lazy as L +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Bits.Utils +import Control.Concurrent (threadDelay) + +import Common.Annex +import Annex.BranchState +import Annex.Journal +import Annex.Index +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 Logs +import Logs.Transitions +import Logs.Trust.Pure +import Logs.Difference.Pure +import Annex.ReplaceFile +import qualified Annex.Queue +import Annex.Branch.Transitions +import qualified Annex + +{- 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/" ++ fromRef name + +{- Branch's name in origin. -} +originname :: Git.Ref +originname = Git.Ref $ "origin/" ++ fromRef 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 $ fromRef name, Param $ fromRef originname] + fromMaybe (error $ "failed to create " ++ fromRef name) + <$> branchsha + go False = withIndex' True $ + inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "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 " ++ fromRef name + localtransitions <- parseTransitionsStrictly "local" + <$> getLocal transitionsLog + unless (null branches) $ do + showSideAction merge_desc + mapM_ checkBranchDifferences refs + 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 = getRef fullname + +getHistorical :: RefDate -> FilePath -> Annex String +getHistorical date = getRef (Git.Ref.dateRef fullname date) + +getRef :: Ref -> FilePath -> Annex String +getRef ref file = withIndex $ decodeBS <$> catFile ref 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 journalled + - 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 merge 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. + - + - 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. + - + - Note that changes may be pushed to the branch at any point in time! + - So, there's a race. If the commit is made using the newly pushed tip of + - the branch as its parent, and that ref has not yet been merged into the + - index, then the result is that the commit will revert the pushed + - changes, since they have not been merged into the index. This race + - is detected and another commit made to fix it. + - + - (It's also possible for the branch to be overwritten, + - losing the commit made here. But that's ok; the data is still in the + - index and will get committed again later.) + -} +commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex () +commitIndex jl branchref message parents = do + showStoringStateAction + commitIndex' jl branchref message message 0 parents +commitIndex' :: JournalLocked -> Git.Ref -> String -> String -> Integer -> [Git.Ref] -> Annex () +commitIndex' jl branchref message basemessage retrynum parents = do + updateIndex jl branchref + committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname parents + setIndexSha committedref + parentrefs <- commitparents <$> catObject committedref + when (racedetected branchref parentrefs) $ + fixrace committedref parentrefs + where + -- look for "parent ref" lines and return the refs + commitparents = map (Git.Ref . snd) . filter isparent . + map (toassoc . decodeBS) . L.split newline + newline = c2w8 '\n' + 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. -} + fixrace committedref lostrefs = do + showSideAction "recovering from race" + let retrynum' = retrynum+1 + -- small sleep to let any activity that caused + -- the race settle down + liftIO $ threadDelay (100000 + fromInteger retrynum') + mergeIndex jl lostrefs + let racemessage = basemessage ++ " (recovery from race #" ++ show retrynum' ++ "; expected commit parent " ++ show branchref ++ " but found " ++ show lostrefs ++ " )" + commitIndex' jl committedref racemessage basemessage retrynum' [committedref] + +{- 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 $ fromRef 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 <- liftIO . absPath =<< fromRepo gitAnnexIndex + withIndexFile f $ do + checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do + unless bootstrapping create + createAnnexDirectory $ takeDirectory f + unless bootstrapping $ inRepo genIndex + a + +{- 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 $ fromRef ref ++ "\n" + setAnnexFilePerm 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 + (jlogf, jlogh) <- openjlog + withJournalHandle $ \jh -> do + h <- hashObjectStart g + Git.UpdateIndex.streamUpdateIndex g + [genstream dir h jh jlogh] + hashObjectStop h + return $ cleanup dir jlogh jlogf + where + genstream dir h jh jlogh streamer = do + v <- readDirectory jh + case v of + Nothing -> return () + Just file -> do + unless (dirCruft file) $ do + let path = dir file + sha <- hashFile h path + hPutStrLn jlogh file + streamer $ Git.UpdateIndex.updateIndexLine + sha FileBlob (asTopFilePath $ fileJournal file) + genstream dir h jh jlogh streamer + -- Clean up the staged files, as listed in the temp log file. + -- The temp file is used to avoid needing to buffer all the + -- filenames in memory. + cleanup dir jlogh jlogf = do + hFlush jlogh + hSeek jlogh AbsoluteSeek 0 + stagedfs <- lines <$> hGetContents jlogh + mapM_ (removeFile . (dir )) stagedfs + hClose jlogh + nukeFile jlogf + openjlog = do + tmpdir <- fromRepo gitAnnexTmpMiscDir + createAnnexDirectory tmpdir + liftIO $ openTempFile tmpdir "jlog" + +{- 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" . decodeBS + <$> 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 fromRef $ 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.commitAlways Git.Branch.AutomaticCommit 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 + +checkBranchDifferences :: Git.Ref -> Annex () +checkBranchDifferences ref = do + theirdiffs <- allDifferences . parseDifferencesLog . decodeBS + <$> catFile ref differenceLog + mydiffs <- annexDifferences <$> Annex.getGitConfig + when (theirdiffs /= mydiffs) $ + error "Remote repository is tuned in incompatable way; cannot be merged with local repository." diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs new file mode 100644 index 0000000000..a9c7daa209 --- /dev/null +++ b/Annex/Branch/Transitions.hs @@ -0,0 +1,64 @@ +{- 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 qualified Logs.UUIDBased as UUIDBased +import qualified Logs.Presence.Pure as Presence +import qualified Logs.Chunk.Pure as Chunk +import Types.TrustLevel +import Types.UUID + +import qualified Data.Map as M +import Data.Default + +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 + -- Don't remove the dead repo from the trust log, + -- because git remotes may still exist, and they need + -- to still know it's dead. + | f == trustLog -> PreserveFile + | otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just content + Just NewUUIDBasedLog -> ChangeFile $ + UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content + Just (ChunkLog _) -> ChangeFile $ + Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content + Just (PresenceLog _) -> + let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content + in if null newlog + then RemoveFile + else ChangeFile $ Presence.showLog newlog + Just OtherLog -> PreserveFile + Nothing -> PreserveFile + +dropDeadFromMapLog :: Ord k => TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v +dropDeadFromMapLog trustmap getuuid = M.filterWithKey $ \k _v -> notDead trustmap getuuid k + +{- 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 def (a v) trustmap /= DeadTrusted diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs new file mode 100644 index 0000000000..889a936b98 --- /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..1791498446 --- /dev/null +++ b/Annex/CatFile.hs @@ -0,0 +1,158 @@ +{- 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, + catFileDetails, + catObject, + catTree, + catObjectDetails, + catFileHandle, + catFileStop, + catKey, + catKeyFile, + catKeyFileHEAD, + catLink, +) 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 +import qualified Git.Ref + +catFile :: Git.Branch -> FilePath -> Annex L.ByteString +catFile branch file = do + h <- catFileHandle + liftIO $ Git.CatFile.catFile h branch file + +catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails branch file = do + h <- catFileHandle + liftIO $ Git.CatFile.catFileDetails 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 + +{- Stops all running cat-files. Should only be run when it's known that + - nothing is using the handles, eg at shutdown. -} +catFileStop :: Annex () +catFileStop = do + m <- Annex.withState $ \s -> + (s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s) + liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m) + +{- 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 -> Sha -> FileMode -> Annex (Maybe Key) +catKey' modeguaranteed sha mode + | isSymLink mode = do + l <- catLink modeguaranteed sha + return $ if isLinkToAnnex l + then fileKey $ takeFileName l + else Nothing + | otherwise = return Nothing + +{- Gets a symlink target. -} +catLink :: Bool -> Sha -> Annex String +catLink modeguaranteed sha = fromInternalGitPath . decodeBS <$> get + 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 sha + | otherwise = L.take 8192 <$> catObject sha + +{- Looks up the key 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. + - + - 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 $ Git.Ref.fileRef f + ) + +catKeyFileHEAD :: FilePath -> Annex (Maybe Key) +catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs new file mode 100644 index 0000000000..46c71fe72f --- /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..8d7df1e2c6 --- /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..f91c1e72ae --- /dev/null +++ b/Annex/Content.hs @@ -0,0 +1,637 @@ +{- git-annex file content managing + - + - Copyright 2010-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content ( + inAnnex, + inAnnexSafe, + inAnnexCheck, + lockContent, + getViaTmp, + getViaTmpChecked, + getViaTmpUnchecked, + prepGetViaTmpChecked, + prepTmp, + withTmp, + checkDiskSpace, + moveAnnex, + sendAnnex, + prepSendAnnex, + removeAnnex, + fromAnnex, + moveBad, + KeyLocation(..), + getKeysPresent, + saveState, + downloadUrl, + preseedTmp, + freezeContent, + thawContent, + dirKeys, + withObjectLoc, +) where + +import System.IO.Unsafe (unsafeInterleaveIO) + +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 +import Utility.LockFile + +{- 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 key = inAnnex' (fromMaybe False) (Just False) go key + where + is_locked = Nothing + is_unlocked = Just True + is_missing = Just False + + go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile) + =<< contentLockFile key + +#ifndef mingw32_HOST_OS + checkindirect contentfile = liftIO $ checkOr is_missing contentfile + {- In direct mode, the content file must exist, but + - the lock file generally won't exist unless a removal is in + - process. -} + checkdirect contentfile lockfile = liftIO $ + ifM (doesFileExist contentfile) + ( checkOr is_unlocked lockfile + , return is_missing + ) + checkOr d lockfile = do + v <- checkLocked lockfile + return $ case v of + Nothing -> d + Just True -> is_locked + Just False -> is_unlocked +#else + checkindirect f = liftIO $ ifM (doesFileExist f) + ( do + v <- lockShared f + case v of + Nothing -> return is_locked + Just lockhandle -> do + dropLock lockhandle + return is_unlocked + , return is_missing + ) + {- In Windows, see if we can take a shared lock. If so, + - remove the lock file to clean up after ourselves. -} + checkdirect contentfile lockfile = + ifM (liftIO $ doesFileExist contentfile) + ( modifyContent lockfile $ liftIO $ do + v <- lockShared lockfile + case v of + Nothing -> return is_locked + Just lockhandle -> do + dropLock lockhandle + void $ tryIO $ nukeFile lockfile + return is_unlocked + , return is_missing + ) +#endif + +{- Direct mode and especially Windows has to use a separate lock + - file from the content, since locking the actual content file + - would interfere with the user's use of it. -} +contentLockFile :: Key -> Annex (Maybe FilePath) +contentLockFile key = ifM isDirect + ( Just <$> calcRepo (gitAnnexContentLock key) + , return Nothing + ) + +newtype ContentLock = ContentLock Key + +{- Content is exclusively locked while running an action that might remove + - it. (If the content is not present, no locking is done.) + -} +lockContent :: Key -> (ContentLock -> Annex a) -> Annex a +lockContent key a = do + contentfile <- calcRepo $ gitAnnexLocation key + lockfile <- contentLockFile key + maybe noop setuplockfile lockfile + bracket + (lock contentfile lockfile) + (unlock lockfile) + (const $ a $ ContentLock key) + where + alreadylocked = error "content is locked" + setuplockfile lockfile = modifyContent lockfile $ + void $ liftIO $ tryIO $ + writeFile lockfile "" + cleanuplockfile lockfile = modifyContent lockfile $ + void $ liftIO $ tryIO $ + nukeFile lockfile +#ifndef mingw32_HOST_OS + lock contentfile Nothing = liftIO $ + opencontentforlock contentfile >>= dolock + lock _ (Just lockfile) = do + mode <- annexFileMode + liftIO $ createLockFile mode lockfile >>= dolock . Just + {- Since content files are stored with the write bit disabled, have + - to fiddle with permissions to open for an exclusive lock. -} + opencontentforlock f = catchDefaultIO Nothing $ + withModifiedFileMode f + (`unionFileModes` ownerWriteMode) + (openExistingLockFile f) + dolock Nothing = return Nothing + dolock (Just fd) = do + v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> alreadylocked + Right _ -> return $ Just fd + unlock mlockfile mfd = do + maybe noop cleanuplockfile mlockfile + liftIO $ maybe noop closeFd mfd +#else + lock _ (Just lockfile) = liftIO $ + maybe alreadylocked (return . Just) =<< lockExclusive lockfile + lock _ Nothing = return Nothing + unlock mlockfile mlockhandle = do + liftIO $ maybe noop dropLock mlockhandle + maybe noop cleanuplockfile mlockfile +#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 = + prepGetViaTmpChecked key False $ + finishGetViaTmp check key action + +{- Prepares to download a key via a tmp file, and checks that there is + - enough free disk space. + - + - When the temp file already exists, count the space it is using as + - free, since the download will overwrite it or resume. + - + - Wen there's enough free space, runs the download action. + -} +prepGetViaTmpChecked :: Key -> a -> Annex a -> Annex a +prepGetViaTmpChecked key unabletoget getkey = do + tmp <- fromRepo $ gitAnnexTmpObjectLocation key + + e <- liftIO $ doesFileExist tmp + alreadythere <- liftIO $ if e + then getFileSize tmp + else return 0 + ifM (checkDiskSpace Nothing key alreadythere) + ( do + -- The tmp file may not have been left writable + when e $ thawContent tmp + getkey + , return unabletoget + ) + +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 + -- 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 $ gitAnnexTmpObjectLocation key + createAnnexDirectory (parentDir tmp) + return tmp + +{- Creates a temp file for a key, runs an action on it, and cleans up + - the temp file. If the action throws an exception, the temp file is + - left behind, which allows for resuming. + -} +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 + , modifyContent dest $ do + liftIO $ moveFile src dest + freezeContent 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 + 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 a 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 () -> Annex () +cleanObjectLoc key cleaner = do + file <- calcRepo $ gitAnnexLocation key + void $ tryIO $ thawContentDir file + cleaner + 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 :: ContentLock -> Annex () +removeAnnex (ContentLock key) = withObjectLoc key remove removedirect + where + remove file = cleanObjectLoc key $ do + secureErase file + liftIO $ nukeFile file + removeInodeCache key + removedirect fs = do + cache <- recordedInodeCache key + removeInodeCache key + mapM_ (resetfile cache) fs + resetfile cache f = whenM (sameInodeCache f cache) $ do + l <- calcRepo $ gitAnnexLink f key + secureErase f + replaceFile f $ makeAnnexLink l + +{- Runs the secure erase command if set, otherwise does nothing. + - File may or may not be deleted at the end; caller is responsible for + - making sure it's deleted. -} +secureErase :: FilePath -> Annex () +secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig + where + go basecmd = void $ liftIO $ + boolSystem "sh" [Param "-c", Param $ gencmd basecmd] + gencmd = massReplace [ ("%file", shellEscape file) ] + +{- Moves a key's file out of .git/annex/objects/ -} +fromAnnex :: Key -> FilePath -> Annex () +fromAnnex key dest = cleanObjectLoc key $ do + file <- calcRepo $ gitAnnexLocation key + thawContent file + liftIO $ moveFile file dest + +{- 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) + cleanObjectLoc key $ + liftIO $ moveFile src dest + logStatus key InfoMissing + return dest + +data KeyLocation = InAnnex | InRepository + +{- List of keys whose content exists in the specified location. + + - InAnnex only lists keys under .git/annex/objects, + - while InRepository, in direct mode, also finds keys located in the + - work tree. + - + - Note that InRepository has to check whether direct mode files + - have goodContent. + -} +getKeysPresent :: KeyLocation -> Annex [Key] +getKeysPresent keyloc = do + direct <- isDirect + dir <- fromRepo gitAnnexObjectDir + s <- getstate direct + liftIO $ traverse s direct (2 :: Int) dir + where + traverse s direct depth dir = do + contents <- catchDefaultIO [] (dirContents dir) + if depth == 0 + then do + contents' <- filterM (present s direct) contents + let keys = mapMaybe (fileKey . takeFileName) contents' + continue keys [] + else do + let deeper = traverse s 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 + + present _ False d = presentInAnnex d + present s True d = presentDirect s d <||> presentInAnnex d + + presentInAnnex = doesFileExist . contentfile + contentfile d = d takeFileName d + + presentDirect s d = case keyloc of + InAnnex -> return False + InRepository -> case fileKey (takeFileName d) of + Nothing -> return False + Just k -> Annex.eval s $ + anyM (goodContent k) =<< associatedFiles k + + {- In order to run Annex monad actions within unsafeInterleaveIO, + - the current state is taken and reused. No changes made to this + - state will be preserved. + - + - As an optimsation, call inodesChanged to prime the state with + - a cached value that will be used in the call to goodContent. + -} + getstate direct = do + when direct $ + void $ inodesChanged + Annex.getState id + +{- 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 = Url.withUrlOptions $ \uo -> + anyM (\u -> Url.download u file uo) 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 CopyTimeStamps 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..e6a9b5eda3 --- /dev/null +++ b/Annex/Content/Direct.hs @@ -0,0 +1,263 @@ +{- git-annex file content managing for direct mode + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content.Direct ( + associatedFiles, + associatedFilesRelative, + removeAssociatedFile, + removeAssociatedFileUnchecked, + removeAssociatedFiles, + addAssociatedFile, + goodContent, + recordedInodeCache, + updateInodeCache, + addInodeCache, + writeInodeCache, + compareInodeCaches, + compareInodeCachesWith, + sameInodeCache, + elemInodeCaches, + sameFileStatus, + removeInodeCache, + toInodeCache, + inodesChanged, + createInodeSentinalFile, + addContentWhenNotPresent, + withTSDelta, + getTSDelta, +) 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 [] $ withFile mapping ReadMode $ \h -> do + fileEncoding h + -- Read strictly to ensure the file is closed + -- before changeAssociatedFiles tries to write to it. + -- (Especially needed on Windows.) + lines <$> hGetContentsStrict 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') $ + modifyContent mapping $ + liftIO $ viaTmp writeFileAnyEncoding mapping $ + unlines files' + top <- fromRepo Git.repoPath + return $ map (top ) files' + +{- Removes the list of associated files. -} +removeAssociatedFiles :: Key -> Annex () +removeAssociatedFiles key = do + mapping <- calcRepo $ gitAnnexMapping key + modifyContent mapping $ + liftIO $ nukeFile mapping + +{- 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 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) + =<< withTSDelta (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 -> + modifyContent f $ + liftIO $ writeFile f $ + unlines $ map showInodeCache caches + +{- Removes an inode cache. -} +removeInodeCache :: Key -> Annex () +removeInodeCache key = withInodeCacheFile key $ \f -> + modifyContent f $ + 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 =<< withTSDelta (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 -> FilePath -> FileStatus -> Annex Bool +sameFileStatus key f status = do + old <- recordedInodeCache key + curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta f 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 CopyAllMetaData 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 = sentinalInodesChanged <$> sentinalStatus + +withTSDelta :: (TSDelta -> Annex a) -> Annex a +withTSDelta a = a =<< getTSDelta + +getTSDelta :: Annex TSDelta +#ifdef mingw32_HOST_OS +getTSDelta = sentinalTSDelta <$> sentinalStatus +#else +getTSDelta = pure noTSDelta -- optimisation +#endif + +sentinalStatus :: Annex SentinalStatus +sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus + where + check = do + sc <- liftIO . checkSentinalFile =<< annexSentinalFile + Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc } + return sc + +{- 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) $ do + s <- annexSentinalFile + createAnnexDirectory (parentDir (sentinalFile s)) + liftIO $ writeSentinalFile s + where + alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile + hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir + +annexSentinalFile :: Annex SentinalFile +annexSentinalFile = do + sentinalfile <- fromRepo gitAnnexInodeSentinal + sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache + return $ SentinalFile + { sentinalFile = sentinalfile + , sentinalCacheFile = sentinalcachefile + } diff --git a/Annex/Difference.hs b/Annex/Difference.hs new file mode 100644 index 0000000000..66dc03a329 --- /dev/null +++ b/Annex/Difference.hs @@ -0,0 +1,58 @@ +{- git-annex repository differences + - + - Copyright 2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Difference ( + module Types.Difference, + setDifferences, +) where + +import Common.Annex +import Types.Difference +import Logs.Difference +import Config +import Annex.UUID +import Logs.UUID +import Annex.Version +import qualified Annex + +import qualified Data.Map as M + +-- Differences are only allowed to be tweaked when initializing a +-- repository for the first time, and then only if there is not another +-- known uuid. If the repository was cloned from elsewhere, it inherits +-- the existing settings. +-- +-- Must be called before setVersion, so it can check if this is the first +-- time the repository is being initialized. +setDifferences :: Annex () +setDifferences = do + u <- getUUID + otherds <- allDifferences <$> recordedDifferences + ds <- mappend otherds . annexDifferences <$> Annex.getGitConfig + when (ds /= mempty) $ do + ds' <- ifM (isJust <$> getVersion) + ( do + oldds <- recordedDifferencesFor u + when (ds /= oldds) $ + warning $ "Cannot change tunable parameters in already initialized repository." + return oldds + , if otherds == mempty + then ifM (not . null . filter (/= u) . M.keys <$> uuidMap) + ( do + warning "Cannot change tunable parameters in a clone of an existing repository." + return mempty + , return ds + ) + else if otherds /= ds + then do + warning "The specified tunable parameters differ from values being used in other clones of this repository." + return otherds + else return ds + ) + forM_ (listDifferences ds') $ \d -> + setConfig (ConfigKey $ differenceConfigKey d) (differenceConfigVal d) + recordDifferences ds' u diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs new file mode 100644 index 0000000000..03769350d3 --- /dev/null +++ b/Annex/DirHashes.hs @@ -0,0 +1,86 @@ +{- git-annex file locations + - + - Copyright 2010-2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.DirHashes ( + Hasher, + HashLevels(..), + objectHashLevels, + branchHashLevels, + branchHashDir, + dirHashes, + hashDirMixed, + hashDirLower, +) where + +import Data.Bits +import Data.Word +import Data.Hash.MD5 +import Data.Default + +import Common +import Types.Key +import Types.GitConfig +import Types.Difference + +type Hasher = Key -> FilePath + +-- Number of hash levels to use. 2 is the default. +newtype HashLevels = HashLevels Int + +instance Default HashLevels where + def = HashLevels 2 + +objectHashLevels :: GitConfig -> HashLevels +objectHashLevels = configHashLevels OneLevelObjectHash + +branchHashLevels :: GitConfig -> HashLevels +branchHashLevels = configHashLevels OneLevelBranchHash + +configHashLevels :: Difference -> GitConfig -> HashLevels +configHashLevels d config + | hasDifference d (annexDifferences config) = HashLevels 1 + | otherwise = def + +branchHashDir :: GitConfig -> Key -> String +branchHashDir config key = hashDirLower (branchHashLevels config) key + +{- Two different directory hashes may be used. The mixed case hash + - came first, and is fine, except for the problem of case-strict + - filesystems such as Linux VFAT (mounted with shortname=mixed), + - which do not allow using a directory "XX" when "xx" already exists. + - To support that, most repositories use the lower case hash for new data. -} +dirHashes :: [HashLevels -> Hasher] +dirHashes = [hashDirLower, hashDirMixed] + +hashDirs :: HashLevels -> Int -> String -> FilePath +hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s +hashDirs _ sz s = addTrailingPathSeparator $ take sz s drop sz s + +hashDirMixed :: HashLevels -> Hasher +hashDirMixed n k = hashDirs n 2 $ take 4 $ display_32bits_as_dir =<< [a,b,c,d] + where + ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file $ nonChunkKey k + +hashDirLower :: HashLevels -> Hasher +hashDirLower n k = hashDirs n 3 $ take 6 $ md5s $ md5FilePath $ key2file $ nonChunkKey k + +{- modified version of display_32bits_as_hex from Data.Hash.MD5 + - Copyright (C) 2001 Ian Lynagh + - License: Either BSD or GPL + -} +display_32bits_as_dir :: Word32 -> String +display_32bits_as_dir w = trim $ swap_pairs cs + where + -- Need 32 characters to use. To avoid inaverdently making + -- a real word, use letters that appear less frequently. + chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" + cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7] + getc n = chars !! fromIntegral n + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + -- Last 2 will always be 00, so omit. + trim = take 6 diff --git a/Annex/Direct.hs b/Annex/Direct.hs new file mode 100644 index 0000000000..1c733cb551 --- /dev/null +++ b/Annex/Direct.hs @@ -0,0 +1,456 @@ +{- git-annex direct mode + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Direct where + +import Common.Annex +import qualified Annex +import qualified Git +import qualified Git.LsFiles +import qualified Git.Merge +import qualified Git.DiffTree as DiffTree +import qualified Git.Config +import qualified Git.Ref +import qualified Git.Branch +import Git.Sha +import Git.FilePath +import Git.Types +import Config +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.VariantFile +import Git.Index +import Annex.Index +import Annex.LockFile + +{- 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) = withTSDelta $ \delta -> do + shakey <- catKey sha mode + mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + mcache <- liftIO $ maybe (pure Nothing) (toInodeCache delta file) mstat + filekey <- isAnnexLink file + case (shakey, filekey, mstat, mcache) 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 <- calcRepo $ 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 "-qf"] [file] + +{- Run before a commit to update direct mode bookeeping to reflect the + - staged changes being committed. -} +preCommitDirect :: Annex Bool +preCommitDirect = do + (diffs, clean) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef + makeabs <- flip fromTopFilePath <$> gitRepo + forM_ diffs (go makeabs) + liftIO clean + where + go makeabs diff = do + withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile + withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile + where + withkey sha mode a = when (sha /= nullSha) $ do + k <- catKey sha mode + case k of + Nothing -> noop + Just key -> void $ a key $ + makeabs $ DiffTree.file diff + +{- 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 <- calcRepo $ 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. + - + - So, to handle a merge, it's run with the work tree set to a temp + - directory, and the merge is staged into a copy of the index. + - Then the work tree is updated to reflect the merge, and + - finally, the merge is committed and the real index updated. + - + - A lock file is used to avoid races with any other caller of mergeDirect. + - + - To avoid other git processes from making change to the index while our + - merge is in progress, the index lock file is used as the temp index + - file. This is the same as what git does when updating the index + - normally. + -} +mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool +mergeDirect startbranch oldref branch resolvemerge commitmode = exclusively $ do + reali <- liftIO . absPath =<< fromRepo indexFile + tmpi <- liftIO . absPath =<< fromRepo indexFileLock + liftIO $ copyFile reali tmpi + + d <- fromRepo gitAnnexMergeDir + liftIO $ do + whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d + createDirectoryIfMissing True d + + withIndexFile tmpi $ do + merged <- stageMerge d branch commitmode + r <- if merged + then return True + else resolvemerge + mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref) + mergeDirectCommit merged startbranch branch commitmode + + liftIO $ rename tmpi reali + + return r + where + exclusively = withExclusiveLock gitAnnexMergeLock + +{- Stage a merge into the index, avoiding changing HEAD or the current + - branch. -} +stageMerge :: FilePath -> Git.Branch -> Git.Branch.CommitMode -> Annex Bool +stageMerge d branch commitmode = do + -- XXX A bug in git makes stageMerge unsafe to use if the git repo + -- is configured with core.symlinks=false + -- Using mergeNonInteractive is not ideal though, since it will + -- update the current branch immediately, before the work tree + -- has been updated, which would leave things in an inconsistent + -- state if mergeDirectCleanup is interrupted. + -- + merger <- ifM (coreSymlinks <$> Annex.getGitConfig) + ( return Git.Merge.stageMerge + , return $ \ref -> Git.Merge.mergeNonInteractive ref commitmode + ) + inRepo $ \g -> do + wd <- liftIO $ absPath d + gd <- liftIO $ absPath $ Git.localGitDir g + merger branch $ + g { location = Local { gitdir = gd, worktree = Just (addTrailingPathSeparator wd) } } + +{- Commits after a direct mode merge is complete, and after the work + - tree has been updated by mergeDirectCleanup. + -} +mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Git.Branch.CommitMode -> Annex () +mergeDirectCommit allowff old branch commitmode = do + void preCommitDirect + d <- fromRepo Git.localGitDir + let merge_head = d "MERGE_HEAD" + let merge_msg = d "MERGE_MSG" + let merge_mode = d "MERGE_MODE" + ifM (pure allowff <&&> canff) + ( inRepo $ Git.Branch.update Git.Ref.headRef branch -- fast forward + , do + msg <- liftIO $ + catchDefaultIO ("merge " ++ fromRef branch) $ + readFile merge_msg + void $ inRepo $ Git.Branch.commit commitmode False msg + Git.Ref.headRef [Git.Ref.headRef, branch] + ) + liftIO $ mapM_ nukeFile [merge_head, merge_msg, merge_mode] + where + canff = maybe (return False) (\o -> inRepo $ Git.Branch.fastForwardable o branch) old + +mergeDirectCleanup :: FilePath -> Git.Ref -> Annex () +mergeDirectCleanup d oldref = do + updateWorkTree d oldref + liftIO $ removeDirectoryRecursive d + +{- Updates the direct mode work tree to reflect the changes staged in the + - index by a git command, that was run in a temporary work tree. + - + - Uses diff-index to compare the staged changes with provided ref + - which should be the tree before the merge, and applies those + - changes to the work tree. + - + - There are really only two types of changes: An old item can be deleted, + - or a new item added. Two passes are made, first deleting and then + - adding. This is to handle cases where eg, a file is deleted and a + - directory is added. (The diff-tree output may list these in the opposite + - order, but we cannot add the directory until the file with the + - same name is removed.) + -} +updateWorkTree :: FilePath -> Git.Ref -> Annex () +updateWorkTree d oldref = do + (items, cleanup) <- inRepo $ DiffTree.diffIndex oldref + makeabs <- flip fromTopFilePath <$> gitRepo + let fsitems = zip (map (makeabs . DiffTree.file) items) items + forM_ fsitems $ + go makeabs DiffTree.srcsha DiffTree.srcmode moveout moveout_raw + forM_ fsitems $ + go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw + void $ liftIO cleanup + where + go makeabs getsha getmode a araw (f, item) + | getsha item == nullSha = noop + | otherwise = void $ + tryNonAsync . maybe (araw item makeabs f) (\k -> void $ a item makeabs 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. + - + - If the file is already present, and does not exist in the + - oldref, preserve this local file. + - + - Otherwise, create the symlink and then if possible, replace it + - with the content. -} + movein item makeabs k f = unlessM (goodContent k f) $ do + preserveUnannexed item makeabs f oldref + l <- calcRepo $ 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 item makeabs f = do + preserveUnannexed item makeabs f oldref + liftIO $ do + createDirectoryIfMissing True $ parentDir f + void $ tryIO $ rename (d getTopFilePath (DiffTree.file item)) f + +{- If the file that's being moved in is already present in the work + - tree, but did not exist in the oldref, preserve this + - local, unannexed file (or directory), as "variant-local". + - + - It's also possible that the file that's being moved in + - is in a directory that collides with an exsting, non-annexed + - file (not a directory), which should be preserved. + -} +preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex () +preserveUnannexed item makeabs absf oldref = do + whenM (liftIO (collidingitem absf) <&&> unannexed absf) $ + liftIO $ findnewname absf 0 + checkdirs (DiffTree.file item) + where + checkdirs from = case upFrom (getTopFilePath from) of + Nothing -> noop + Just p -> do + let d = asTopFilePath p + let absd = makeabs d + whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $ + liftIO $ findnewname absd 0 + checkdirs d + + collidingitem f = isJust + <$> catchMaybeIO (getSymbolicLinkStatus f) + colliding_nondir f = maybe False (not . isDirectory) + <$> catchMaybeIO (getSymbolicLinkStatus f) + + unannexed f = (isNothing <$> isAnnexLink f) + <&&> (isNothing <$> catFileDetails oldref f) + + findnewname :: FilePath -> Int -> IO () + findnewname f n = do + let localf = mkVariant f + ("local" ++ if n > 0 then show n else "") + ifM (collidingitem localf) + ( findnewname f (n+1) + , rename f localf + `catchIO` const (findnewname f (n+1)) + ) + +{- 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. -} + updateInodeCache k loc + void $ addAssociatedFile k f + modifyContent loc $ do + thawContent loc + liftIO (replaceFileFrom loc f) + `catchIO` (\_ -> freezeContent loc) + fromdirect loc = do + replaceFile f $ + liftIO . void . copyFileExternal CopyAllMetaData 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 + +{- Enable/disable direct mode. -} +setDirect :: Bool -> Annex () +setDirect wantdirect = do + if wantdirect + then do + switchHEAD + setbare + else do + setbare + switchHEADBack + setConfig (annexConfig "direct") val + Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect } + where + val = Git.Config.boolConfig wantdirect + setbare = setConfig (ConfigKey Git.Config.coreBare) val + +{- Since direct mode sets core.bare=true, incoming pushes could change + - the currently checked out branch. To avoid this problem, HEAD + - is changed to a internal ref that nothing is going to push to. + - + - For refs/heads/master, use refs/heads/annex/direct/master; + - this way things that show HEAD (eg shell prompts) will + - hopefully show just "master". -} +directBranch :: Ref -> Ref +directBranch orighead = case split "/" $ fromRef orighead of + ("refs":"heads":"annex":"direct":_) -> orighead + ("refs":"heads":rest) -> + Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest + _ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead) + +{- Converts a directBranch back to the original branch. + - + - Any other ref is left unchanged. + -} +fromDirectBranch :: Ref -> Ref +fromDirectBranch directhead = case split "/" $ fromRef directhead of + ("refs":"heads":"annex":"direct":rest) -> + Ref $ "refs/heads/" ++ intercalate "/" rest + _ -> directhead + +switchHEAD :: Annex () +switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe + where + switch orighead = do + let newhead = directBranch orighead + maybe noop (inRepo . Git.Branch.update newhead) + =<< inRepo (Git.Ref.sha orighead) + inRepo $ Git.Branch.checkout newhead + +switchHEADBack :: Annex () +switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe + where + switch currhead = do + let orighead = fromDirectBranch currhead + v <- inRepo $ Git.Ref.sha currhead + case v of + Just headsha + | orighead /= currhead -> do + inRepo $ Git.Branch.update orighead headsha + inRepo $ Git.Branch.checkout orighead + inRepo $ Git.Branch.delete currhead + _ -> inRepo $ Git.Branch.checkout orighead diff --git a/Annex/Direct/Fixup.hs b/Annex/Direct/Fixup.hs new file mode 100644 index 0000000000..793f92eafe --- /dev/null +++ b/Annex/Direct/Fixup.hs @@ -0,0 +1,31 @@ +{- git-annex direct mode guard fixup + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Direct.Fixup where + +import Git.Types +import Git.Config +import qualified Git.Construct as Construct +import Utility.Path +import Utility.SafeCommand + +{- Direct mode repos have core.bare=true, but are not really bare. + - Fix up the Repo to be a non-bare repo, and arrange for git commands + - run by git-annex to be passed parameters that override this setting. -} +fixupDirect :: Repo -> IO Repo +fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do + let r' = r + { location = l { worktree = Just (parentDir d) } + , gitGlobalOpts = gitGlobalOpts r ++ + [ Param "-c" + , Param $ coreBare ++ "=" ++ boolConfig False + ] + } + -- Recalc now that the worktree is correct. + rs' <- Construct.fromRemotes r' + return $ r' { remotes = rs' } +fixupDirect r = return r diff --git a/Annex/Drop.hs b/Annex/Drop.hs new file mode 100644 index 0000000000..6f3b95615e --- /dev/null +++ b/Annex/Drop.hs @@ -0,0 +1,123 @@ +{- dropping of unwanted content + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Drop where + +import Common.Annex +import Logs.Trust +import Config.NumCopies +import Types.Remote (uuid) +import Types.Key (key2file) +import qualified Remote +import qualified Command.Drop +import Command +import Annex.Wanted +import Config +import Annex.Content.Direct + +import qualified Data.Set as S +import System.Log.Logger (debugM) + +type Reason = String + +{- Drop a key from local and/or remote when allowed by the preferred content + - and numcopies settings. + - + - 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. + - + - A remote can be specified that is known to have the key. This can be + - used an an optimisation when eg, a key has just been uploaded to a + - remote. + - + - In direct mode, all associated files are checked, and only if all + - of them are unwanted are they dropped. + - + - The runner is used to run commands, and so can be either callCommand + - or commandAction. + -} +handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex () +handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do + fs <- ifM isDirect + ( do + l <- associatedFilesRelative key + return $ if null l + then maybeToList afile + else l + , return $ maybeToList afile + ) + n <- getcopies fs + if fromhere && checkcopies n Nothing + then go fs rs =<< dropl fs n + else go fs rs n + where + getcopies fs = do + (untrusted, have) <- trustPartition UnTrusted locs + numcopies <- if null fs + then getNumCopies + else maximum <$> mapM getFileNumCopies fs + return (NumCopies (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 = + (NumCopies (fromNumCopies 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 u a + | null fs = check $ -- no associated files; unused content + wantDrop True u (Just key) Nothing + | otherwise = check $ + allM (wantDrop True u (Just key) . Just) fs + where + check c = ifM c + ( dodrop n u a + , return n + ) + + dodrop n@(have, numcopies, _untrusted) u a = + ifM (safely $ runner $ a numcopies) + ( do + liftIO $ debugM "drop" $ unwords + [ "dropped" + , fromMaybe (key2file key) afile + , "(from " ++ maybe "here" show u ++ ")" + , "(copies now " ++ show (fromNumCopies have - 1) ++ ")" + , ": " ++ reason + ] + return $ decrcopies n u + , 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 + + slocs = S.fromList locs + + safely a = either (const False) id <$> tryNonAsync a + diff --git a/Annex/Environment.hs b/Annex/Environment.hs new file mode 100644 index 0000000000..13b52aa75c --- /dev/null +++ b/Annex/Environment.hs @@ -0,0 +1,58 @@ +{- 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 Utility.Env + +{- 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 = whenM (isNothing <$> 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 = setEnv var val False +#else + -- Environment setting is broken on Android, so this is dealt with + -- in runshell instead. + ensureEnv _ _ = noop +#endif + +{- Runs an action that commits to the repository, and if it fails, + - sets user.email and user.name to a dummy value and tries the action again. -} +ensureCommit :: Annex a -> Annex a +ensureCommit a = either retry return =<< tryNonAsync a + where + retry _ = do + name <- liftIO myUserName + setConfig (ConfigKey "user.name") name + setConfig (ConfigKey "user.email") name + a diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs new file mode 100644 index 0000000000..0de4d83d19 --- /dev/null +++ b/Annex/FileMatcher.hs @@ -0,0 +1,116 @@ +{- git-annex file matching + - + - Copyright 2012-2014 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 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 + +checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool +checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True + +checkMatcher :: (FileMatcher Annex) -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool +checkMatcher matcher mkey afile notpresent d + | isEmpty matcher = return d + | otherwise = case (mkey, afile) of + (_, Just file) -> go =<< fileMatchInfo file + (Just key, _) -> go (MatchingKey key) + _ -> return d + where + go mi = matchMrun matcher $ \a -> a notpresent mi + +fileMatchInfo :: FilePath -> Annex MatchInfo +fileMatchInfo file = do + matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) + return $ MatchingFile FileInfo + { matchFile = matchfile + , currFile = file + } + +matchAll :: FileMatcher Annex +matchAll = generate [] + +parsedToMatcher :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex) +parsedToMatcher parsed = case partitionEithers parsed of + ([], vs) -> Right $ generate vs + (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es + +exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))] +exprParser matchstandard matchgroupwanted groupmap configmap mu expr = + map parse $ tokenizeMatcher expr + where + parse = parseToken + matchstandard + matchgroupwanted + (limitPresent mu) + (limitInDir preferreddir) + groupmap + preferreddir = fromMaybe "public" $ + M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu + +parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex)) +parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t + | t `elem` tokens = Right $ token t + | t == "standard" = call matchstandard + | t == "groupwanted" = call matchgroupwanted + | t == "present" = use checkpresent + | t == "inpreferreddir" = use checkpreferreddir + | t == "unused" = Right $ Operation limitUnused + | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $ + M.fromList + [ ("include", limitInclude) + , ("exclude", limitExclude) + , ("copies", limitCopies) + , ("lackingcopies", limitLackingCopies False) + , ("approxlackingcopies", limitLackingCopies True) + , ("inbackend", limitInBackend) + , ("largerthan", limitSize (>)) + , ("smallerthan", limitSize (<)) + , ("metadata", limitMetaData) + , ("inallgroup", limitInAllGroup groupmap) + ] + where + (k, v) = separate (== '=') t + use a = Operation <$> a v + call sub = Right $ Operation $ \notpresent mi -> + matchMrun sub $ \a -> a notpresent mi + +{- 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 Annex) +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 matchAll matchAll gm rc (Just u) expr + badexpr e = error $ "bad annex.largefiles configuration: " ++ e diff --git a/Annex/Hook.hs b/Annex/Hook.hs new file mode 100644 index 0000000000..253c77a603 --- /dev/null +++ b/Annex/Hook.hs @@ -0,0 +1,67 @@ +{- git-annex git hooks + - + - Note that it's important that the scripts installed by git-annex + - not change, otherwise removing old hooks using an old version of + - the script would fail. + - + - Copyright 2013-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Hook where + +import Common.Annex +import qualified Git.Hook as Git +import Config +import qualified Annex +import Utility.Shell + +import qualified Data.Map as M + +preCommitHook :: Git.Hook +preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") + +preCommitAnnexHook :: Git.Hook +preCommitAnnexHook = Git.Hook "pre-commit-annex" "" + +mkHookScript :: String -> String +mkHookScript s = unlines + [ shebang_local + , "# automatically configured by git-annex" + , s + ] + +hookWrite :: Git.Hook -> Annex () +hookWrite h = + -- cannot have git hooks in a crippled filesystem (no execute bit) + unlessM crippledFileSystem $ + unlessM (inRepo $ Git.hookWrite h) $ + hookWarning h "already exists, not configuring" + +hookUnWrite :: Git.Hook -> Annex () +hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $ + hookWarning h "contents modified; not deleting. Edit it to remove call to git annex." + +hookWarning :: Git.Hook -> String -> Annex () +hookWarning h msg = do + r <- gitRepo + warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg + +{- Runs a hook. To avoid checking if the hook exists every time, + - the existing hooks are cached. -} +runAnnexHook :: Git.Hook -> Annex () +runAnnexHook hook = do + m <- Annex.getState Annex.existinghooks + case M.lookup hook m of + Just True -> run + Just False -> noop + Nothing -> do + exists <- inRepo $ Git.hookExists hook + Annex.changeState $ \s -> s + { Annex.existinghooks = M.insert hook exists m } + when exists run + where + run = unlessM (inRepo $ Git.runHook hook) $ do + h <- fromRepo $ Git.hookFile hook + warning $ h ++ " failed" diff --git a/Annex/Index.hs b/Annex/Index.hs new file mode 100644 index 0000000000..60340c50b6 --- /dev/null +++ b/Annex/Index.hs @@ -0,0 +1,52 @@ +{- Using other git index files + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Index ( + withIndexFile, + addGitEnv, +) where + +import qualified Control.Exception as E + +import Common.Annex +import Git.Types +import qualified Annex +import Utility.Env + +{- Runs an action using a different git index file. -} +withIndexFile :: FilePath -> Annex a -> Annex a +withIndexFile f a = do + g <- gitRepo + g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f + + r <- tryNonAsync $ do + Annex.changeState $ \s -> s { Annex.repo = g' } + a + Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} } + either E.throw return r + +addGitEnv :: Repo -> String -> String -> IO Repo +addGitEnv g var val = do + e <- maybe copyenv return (gitEnv g) + let e' = addEntry var val e + return $ g { gitEnv = Just e' } + where + copyenv = do +#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 + liftIO $ catMaybes <$> forM keyenv getEnvPair +#else + liftIO getEnvironment +#endif diff --git a/Annex/Init.hs b/Annex/Init.hs new file mode 100644 index 0000000000..3f27a1172d --- /dev/null +++ b/Annex/Init.hs @@ -0,0 +1,195 @@ +{- git-annex repository initialization + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Init ( + ensureInitialized, + isInitialized, + initialize, + initialize', + uninitialize, + probeCrippledFileSystem, +) where + +import Common.Annex +import qualified Annex +import qualified Git +import qualified Git.LsFiles +import qualified Git.Config +import qualified Git.Objects +import qualified Annex.Branch +import Logs.UUID +import Logs.Trust.Basic +import Types.TrustLevel +import Annex.Version +import Annex.Difference +import Annex.UUID +import Config +import Annex.Direct +import Annex.Content.Direct +import Annex.Environment +import Backend +import Annex.Hook +import Upgrade +#ifndef mingw32_HOST_OS +import Utility.UserInfo +import Utility.FileMode +import Annex.Perms +#endif + +genDescription :: Maybe String -> Annex String +genDescription (Just d) = return d +genDescription Nothing = do + reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath + hostname <- fromMaybe "" <$> liftIO getHostname +#ifndef mingw32_HOST_OS + let at = if null hostname then "" else "@" + username <- liftIO myUserName + return $ concat [username, at, hostname, ":", reldir] +#else + return $ concat [hostname, ":", reldir] +#endif + +initialize :: Maybe String -> Annex () +initialize mdescription = do + prepUUID + initialize' + + u <- getUUID + {- This will make the first commit to git, so ensure git is set up + - properly to allow commits when running it. -} + ensureCommit $ do + Annex.Branch.create + describeUUID u =<< genDescription mdescription + +-- Everything except for uuid setup. +initialize' :: Annex () +initialize' = do + checkFifoSupport + checkCrippledFileSystem + unlessM isBare $ + hookWrite preCommitHook + setDifferences + setVersion supportedVersion + ifM (crippledFileSystem <&&> not <$> isBare) + ( do + enableDirectMode + setDirect True + -- Handle case where this repo was cloned from a + -- direct mode repo + , unlessM isBare + switchHEADBack + ) + createInodeSentinalFile + checkSharedClone + +uninitialize :: Annex () +uninitialize = do + hookUnWrite preCommitHook + removeRepoUUID + removeVersion + +{- Will automatically initialize if there is already a git-annex + - branch from somewhere. Otherwise, require a manual init + - to avoid git-annex accidentially being run in git + - repos that did not intend to use it. + - + - Checks repository version and handles upgrades too. + -} +ensureInitialized :: Annex () +ensureInitialized = getVersion >>= maybe needsinit checkUpgrade + where + needsinit = ifM Annex.Branch.hasSibling + ( initialize Nothing + , error "First run: git-annex init" + ) + +{- Checks if a repository is initialized. Does not check version for ugrade. -} +isInitialized :: Annex Bool +isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion + +isBare :: Annex Bool +isBare = fromRepo Git.repoIsLocalBare + +{- A crippled filesystem is one that does not allow making symlinks, + - or removing write access from files. -} +probeCrippledFileSystem :: Annex Bool +probeCrippledFileSystem = do +#ifdef mingw32_HOST_OS + return True +#else + tmp <- fromRepo gitAnnexTmpMiscDir + let f = tmp "gaprobe" + createAnnexDirectory tmp + liftIO $ writeFile f "" + uncrippled <- liftIO $ probe f + liftIO $ removeFile f + return $ not uncrippled + where + probe f = catchBoolIO $ do + let f2 = f ++ "2" + nukeFile f2 + createSymbolicLink f f2 + nukeFile f2 + preventWrite f + allowWrite f + return True +#endif + +checkCrippledFileSystem :: Annex () +checkCrippledFileSystem = whenM probeCrippledFileSystem $ do + warning "Detected a crippled filesystem." + setCrippledFileSystem True + + {- Normally git disables core.symlinks itself when the + - filesystem does not support them, but in Cygwin, git + - does support symlinks, while git-annex, not linking + - with Cygwin, does not. -} + whenM (coreSymlinks <$> Annex.getGitConfig) $ do + warning "Disabling core.symlinks." + setConfig (ConfigKey "core.symlinks") + (Git.Config.boolConfig False) + +probeFifoSupport :: Annex Bool +probeFifoSupport = do +#ifdef mingw32_HOST_OS + return False +#else + tmp <- fromRepo gitAnnexTmpMiscDir + let f = tmp "gaprobe" + createAnnexDirectory tmp + liftIO $ do + nukeFile f + ms <- tryIO $ do + createNamedPipe f ownerReadMode + getFileStatus f + nukeFile f + return $ either (const False) isNamedPipe ms +#endif + +checkFifoSupport :: Annex () +checkFifoSupport = unlessM probeFifoSupport $ do + warning "Detected a filesystem without fifo support." + warning "Disabling ssh connection caching." + setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False) + +enableDirectMode :: Annex () +enableDirectMode = unlessM isDirect $ do + warning "Enabling direct mode." + top <- fromRepo Git.repoPath + (l, clean) <- inRepo $ Git.LsFiles.inRepo [top] + forM_ l $ \f -> + maybe noop (`toDirect` f) =<< isAnnexLink f + void $ liftIO clean + +checkSharedClone :: Annex () +checkSharedClone = whenM (inRepo Git.Objects.isSharedClone) $ do + showSideAction "Repository was cloned with --shared; setting annex.hardlink=true and making repository untrusted." + u <- getUUID + trustSet u UnTrusted + setConfig (annexConfig "hardlink") (Git.Config.boolConfig True) diff --git a/Annex/Journal.hs b/Annex/Journal.hs new file mode 100644 index 0000000000..148cefbbc1 --- /dev/null +++ b/Annex/Journal.hs @@ -0,0 +1,120 @@ +{- 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 Common.Annex +import qualified Git +import Annex.Perms +import Annex.LockFile + +{- 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 + tmp <- fromRepo gitAnnexTmpMiscDir + createAnnexDirectory =<< fromRepo gitAnnexJournalDir + createAnnexDirectory tmp + -- journal file is written atomically + jfile <- fromRepo $ journalFile file + let tmpfile = tmp takeFileName jfile + liftIO $ do + withFile tmpfile WriteMode $ \h -> do + fileEncoding h +#ifdef mingw32_HOST_OS + hSetNewlineMode h noNewlineTranslation +#endif + hPutStr h 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 $ + readFileStrictAnyEncoding $ 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 + +withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a +withJournalHandle a = do + d <- fromRepo gitAnnexJournalDir + bracketIO (openDirectory d) closeDirectory (liftIO . a) + +{- Checks if there are changes in the journal. -} +journalDirty :: Annex Bool +journalDirty = do + d <- fromRepo gitAnnexJournalDir + liftIO $ + (not <$> isDirectoryEmpty d) + `catchIO` (const $ doesDirectoryExist d) + +{- 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 = withExclusiveLock gitAnnexJournalLock $ a ProduceJournalLocked diff --git a/Annex/Link.hs b/Annex/Link.hs new file mode 100644 index 0000000000..98b200f0a0 --- /dev/null +++ b/Annex/Link.hs @@ -0,0 +1,112 @@ +{- 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 f = getAnnexLinkTarget' f + =<< (coreSymlinks <$> Annex.getGitConfig) + +{- Pass False to force looking inside file. -} +getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe LinkTarget) +getAnnexLinkTarget' file coresymlinks = if coresymlinks + then check readSymbolicLink $ + return Nothing + else 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 = withFile f ReadMode $ \h -> do + 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 return "" + else + -- 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 + +makeAnnexLink :: LinkTarget -> FilePath -> Annex () +makeAnnexLink = makeGitLink + +{- 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. + -} +makeGitLink :: LinkTarget -> FilePath -> Annex () +makeGitLink 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 + +hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha +hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $ + 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/LockFile.hs b/Annex/LockFile.hs new file mode 100644 index 0000000000..18e876c75d --- /dev/null +++ b/Annex/LockFile.hs @@ -0,0 +1,72 @@ +{- git-annex lock files. + - + - Copyright 2012, 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.LockFile ( + lockFileShared, + unlockFile, + getLockPool, + withExclusiveLock, +) where + +import Common.Annex +import Annex +import Types.LockPool +import qualified Git +import Annex.Perms +import Utility.LockFile + +import qualified Data.Map as M + +{- Create a specified lock file, and takes a shared lock, which is retained + - in the pool. -} +lockFileShared :: FilePath -> Annex () +lockFileShared file = go =<< fromLockPool file + where + go (Just _) = noop -- already locked + go Nothing = do +#ifndef mingw32_HOST_OS + mode <- annexFileMode + lockhandle <- liftIO $ noUmask mode $ lockShared (Just mode) file +#else + lockhandle <- liftIO $ waitToLock $ lockShared file +#endif + changeLockPool $ M.insert file lockhandle + +unlockFile :: FilePath -> Annex () +unlockFile file = maybe noop go =<< fromLockPool file + where + go lockhandle = do + liftIO $ dropLock lockhandle + changeLockPool $ M.delete file + +getLockPool :: Annex LockPool +getLockPool = getState lockpool + +fromLockPool :: FilePath -> Annex (Maybe LockHandle) +fromLockPool file = M.lookup file <$> getLockPool + +changeLockPool :: (LockPool -> LockPool) -> Annex () +changeLockPool a = do + m <- getLockPool + changeState $ \s -> s { lockpool = a m } + +{- Runs an action with an exclusive lock held. If the lock is already + - held, blocks until it becomes free. -} +withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a +withExclusiveLock getlockfile a = do + lockfile <- fromRepo getlockfile + createAnnexDirectory $ takeDirectory lockfile + mode <- annexFileMode + bracketIO (lock mode lockfile) dropLock (const a) + where +#ifndef mingw32_HOST_OS + lock mode = noUmask mode . lockExclusive (Just mode) +#else + lock _mode = waitToLock . lockExclusive +#endif diff --git a/Annex/MakeRepo.hs b/Annex/MakeRepo.hs new file mode 100644 index 0000000000..73443c43d9 --- /dev/null +++ b/Annex/MakeRepo.hs @@ -0,0 +1,88 @@ +{- making local repositories (used by webapp mostly) + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.MakeRepo where + +import Assistant.WebApp.Common +import Annex.Init +import qualified Git.Construct +import qualified Git.Config +import qualified Git.Command +import qualified Git.Branch +import qualified Annex +import Annex.UUID +import Annex.Direct +import Types.StandardGroups +import Logs.PreferredContent +import qualified Annex.Branch + +{- Makes a new git repository. Or, if a git repository already + - exists, returns False. -} +makeRepo :: FilePath -> Bool -> IO Bool +makeRepo path bare = ifM (probeRepoExists path) + ( return False + , do + (transcript, ok) <- + processTranscript "git" (toCommand params) Nothing + unless ok $ + error $ "git init failed!\nOutput:\n" ++ transcript + return True + ) + where + baseparams = [Param "init", Param "--quiet"] + params + | bare = baseparams ++ [Param "--bare", File path] + | otherwise = baseparams ++ [File path] + +{- Runs an action in the git repository in the specified directory. -} +inDir :: FilePath -> Annex a -> IO a +inDir dir a = do + state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir + Annex.eval state a + +{- Creates a new repository, and returns its UUID. -} +initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID +initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do + initRepo' desc mgroup + {- Initialize the master branch, so things that expect + - to have it will work, before any files are added. -} + unlessM (Git.Config.isBare <$> gitRepo) $ + void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit + [ Param "--quiet" + , Param "--allow-empty" + , Param "-m" + , Param "created repository" + ] + {- Repositories directly managed by the assistant use direct mode. + - + - Automatic gc is disabled, as it can be slow. Insted, gc is done + - once a day. + -} + when primary_assistant_repo $ do + setDirect True + inRepo $ Git.Command.run + [Param "config", Param "gc.auto", Param "0"] + getUUID +{- Repo already exists, could be a non-git-annex repo though so + - still initialize it. -} +initRepo False _ dir desc mgroup = inDir dir $ do + initRepo' desc mgroup + getUUID + +initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () +initRepo' desc mgroup = unlessM isInitialized $ do + initialize desc + u <- getUUID + maybe noop (defaultStandardGroup u) mgroup + {- Ensure branch gets committed right away so it is + - available for merging immediately. -} + Annex.Branch.commit "update" + +{- Checks if a git repo exists at a location. -} +probeRepoExists :: FilePath -> IO Bool +probeRepoExists dir = isJust <$> + catchDefaultIO Nothing (Git.Construct.checkForRepo dir) diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs new file mode 100644 index 0000000000..3b776a6d75 --- /dev/null +++ b/Annex/MetaData.hs @@ -0,0 +1,55 @@ +{- git-annex metadata + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.MetaData ( + genMetaData, + dateMetaData, + module X +) where + +import Common.Annex +import qualified Annex +import Types.MetaData as X +import Annex.MetaData.StandardFields as X +import Logs.MetaData +import Annex.CatFile + +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Clock.POSIX + +{- Adds metadata for a file that has just been ingested into the + - annex, but has not yet been committed to git. + - + - When the file has been modified, the metadata is copied over + - from the old key to the new key. Note that it looks at the old key as + - committed to HEAD -- the new key may or may not have already been staged + - in th annex. + - + - Also, can generate new metadata, if configured to do so. + -} +genMetaData :: Key -> FilePath -> FileStatus -> Annex () +genMetaData key file status = do + maybe noop (flip copyMetaData key) =<< catKeyFileHEAD file + whenM (annexGenMetaData <$> Annex.getGitConfig) $ do + curr <- getCurrentMetaData key + addMetaData key (dateMetaData mtime curr) + where + mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status + +{- Generates metadata for a file's date stamp. + - Does not overwrite any existing metadata values. -} +dateMetaData :: UTCTime -> MetaData -> MetaData +dateMetaData mtime old = MetaData $ M.fromList $ filter isnew + [ (yearMetaField, S.singleton $ toMetaValue $ show y) + , (monthMetaField, S.singleton $ toMetaValue $ show m) + ] + where + isnew (f, _) = S.null (currentMetaDataValues f old) + (y, m, _d) = toGregorian $ utctDay $ mtime diff --git a/Annex/MetaData/StandardFields.hs b/Annex/MetaData/StandardFields.hs new file mode 100644 index 0000000000..c91b539302 --- /dev/null +++ b/Annex/MetaData/StandardFields.hs @@ -0,0 +1,47 @@ +{- git-annex metadata, standard fields + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.MetaData.StandardFields ( + tagMetaField, + yearMetaField, + monthMetaField, + lastChangedField, + mkLastChangedField, + isLastChangedField +) where + +import Types.MetaData + +import Data.List + +tagMetaField :: MetaField +tagMetaField = mkMetaFieldUnchecked "tag" + +yearMetaField :: MetaField +yearMetaField = mkMetaFieldUnchecked "year" + +monthMetaField :: MetaField +monthMetaField = mkMetaFieldUnchecked "month" + +lastChangedField :: MetaField +lastChangedField = mkMetaFieldUnchecked lastchanged + +mkLastChangedField :: MetaField -> MetaField +mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f ++ lastchangedSuffix) + +isLastChangedField :: MetaField -> Bool +isLastChangedField f + | f == lastChangedField = True + | otherwise = lastchanged `isSuffixOf` s && s /= lastchangedSuffix + where + s = fromMetaField f + +lastchanged :: String +lastchanged = "lastchanged" + +lastchangedSuffix :: String +lastchangedSuffix = "-lastchanged" diff --git a/Annex/Notification.hs b/Annex/Notification.hs new file mode 100644 index 0000000000..25f1ee6781 --- /dev/null +++ b/Annex/Notification.hs @@ -0,0 +1,101 @@ +{- git-annex desktop notifications + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where + +import Common.Annex +import Logs.Transfer +#ifdef WITH_DBUS_NOTIFICATIONS +import qualified Annex +import Types.DesktopNotify +import qualified DBus.Notify as Notify +import qualified DBus.Client +#endif + +-- Witness that notification has happened. +data NotifyWitness = NotifyWitness + +{- Wrap around an action that performs a transfer, which may run multiple + - attempts. Displays notification when supported and when the user asked + - for it. -} +notifyTransfer :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool +notifyTransfer _ Nothing a = a NotifyWitness +#ifdef WITH_DBUS_NOTIFICATIONS +notifyTransfer direction (Just f) a = do + wanted <- Annex.getState Annex.desktopnotify + if (notifyStart wanted || notifyFinish wanted) + then do + client <- liftIO DBus.Client.connectSession + startnotification <- liftIO $ if notifyStart wanted + then Just <$> Notify.notify client (startedTransferNote direction f) + else pure Nothing + ok <- a NotifyWitness + when (notifyFinish wanted) $ liftIO $ void $ maybe + (Notify.notify client $ finishedTransferNote ok direction f) + (\n -> Notify.replace client n $ finishedTransferNote ok direction f) + startnotification + return ok + else a NotifyWitness +#else +notifyTransfer _ (Just _) a = do a NotifyWitness +#endif + +notifyDrop :: Maybe FilePath -> Bool -> Annex () +notifyDrop Nothing _ = noop +#ifdef WITH_DBUS_NOTIFICATIONS +notifyDrop (Just f) ok = do + wanted <- Annex.getState Annex.desktopnotify + when (notifyFinish wanted) $ liftIO $ do + client <- DBus.Client.connectSession + void $ Notify.notify client (droppedNote ok f) +#else +notifyDrop (Just _) _ = noop +#endif + +#ifdef WITH_DBUS_NOTIFICATIONS +startedTransferNote :: Direction -> FilePath -> Notify.Note +startedTransferNote Upload = mkNote Notify.Transfer Notify.Low iconUpload + "Uploading" +startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload + "Downloading" + +finishedTransferNote :: Bool -> Direction -> FilePath -> Notify.Note +finishedTransferNote False Upload = mkNote Notify.TransferError Notify.Normal iconFailure + "Failed to upload" +finishedTransferNote False Download = mkNote Notify.TransferError Notify.Normal iconFailure + "Failed to download" +finishedTransferNote True Upload = mkNote Notify.TransferComplete Notify.Low iconSuccess + "Finished uploading" +finishedTransferNote True Download = mkNote Notify.TransferComplete Notify.Low iconSuccess + "Finished downloading" + +droppedNote :: Bool -> FilePath -> Notify.Note +droppedNote False = mkNote Notify.TransferError Notify.Normal iconFailure + "Failed to drop" +droppedNote True = mkNote Notify.TransferComplete Notify.Low iconSuccess + "Dropped" + +iconUpload, iconDownload, iconFailure, iconSuccess :: String +iconUpload = "network-transmit" +iconDownload = "network-receive" +iconFailure = "dialog-error" +iconSuccess = "git-annex" -- Is there a standard icon for success/completion? + +mkNote :: Notify.Category -> Notify.UrgencyLevel -> String -> String -> FilePath -> Notify.Note +mkNote category urgency icon desc path = Notify.blankNote + { Notify.appName = "git-annex" + , Notify.appImage = Just (Notify.Icon icon) + , Notify.summary = desc ++ " " ++ path + , Notify.hints = + [ Notify.Category category + , Notify.Urgency urgency + , Notify.SuppressSound True + ] + } +#endif diff --git a/Annex/Path.hs b/Annex/Path.hs new file mode 100644 index 0000000000..6186a887b1 --- /dev/null +++ b/Annex/Path.hs @@ -0,0 +1,34 @@ +{- git-annex program path + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Path where + +import Common +import Config.Files +import System.Environment + +{- A fully qualified path to the currently running git-annex program. + - + - getExecutablePath is available since ghc 7.4.2. On OSs it supports + - well, it returns the complete path to the program. But, on other OSs, + - it might return just the basename. + -} +programPath :: IO (Maybe FilePath) +programPath = do +#if MIN_VERSION_base(4,6,0) + exe <- getExecutablePath + p <- if isAbsolute exe + then return exe + else readProgramFile +#else + p <- readProgramFile +#endif + -- In case readProgramFile returned just the command name, + -- fall back to finding it in PATH. + searchPath p diff --git a/Annex/Perms.hs b/Annex/Perms.hs new file mode 100644 index 0000000000..3ae351d8c8 --- /dev/null +++ b/Annex/Perms.hs @@ -0,0 +1,124 @@ +{- git-annex file permissions + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Perms ( + setAnnexFilePerm, + setAnnexDirPerm, + annexFileMode, + createAnnexDirectory, + noUmask, + createContentDir, + freezeContentDir, + thawContentDir, + modifyContent, +) 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 + +setAnnexFilePerm :: FilePath -> Annex () +setAnnexFilePerm = setAnnexPerm False + +setAnnexDirPerm :: FilePath -> Annex () +setAnnexDirPerm = setAnnexPerm True + +{- 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 :: Bool -> FilePath -> Annex () +setAnnexPerm isdir file = unlessM crippledFileSystem $ + withShared $ liftIO . go + where + go GroupShared = modifyFileMode file $ addModes $ + groupSharedModes ++ + if isdir then [ ownerExecuteMode, groupExecuteMode ] else [] + go AllShared = modifyFileMode file $ addModes $ + readModes ++ + [ ownerWriteMode, groupWriteMode ] ++ + if isdir then executeModes else [] + 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 groupSharedModes + +{- 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 + setAnnexDirPerm 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 + +{- Creates the content directory for a file if it doesn't already exist, + - or thaws it if it does, then runs an action to modify the file, and + - finally, freezes the content directory. -} +modifyContent :: FilePath -> Annex a -> Annex a +modifyContent f a = do + createContentDir f -- also thaws it + v <- tryNonAsync a + freezeContentDir f + either throwM return v diff --git a/Annex/Queue.hs b/Annex/Queue.hs new file mode 100644 index 0000000000..47837e2d9e --- /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..8d4591b48f --- /dev/null +++ b/Annex/Quvi.hs @@ -0,0 +1,33 @@ +{- 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 -> [QuviParam] -> URLString -> Annex a +withQuviOptions a ps url = do + v <- quviVersion + opts <- map Param . annexQuviOptions <$> Annex.getGitConfig + liftIO $ a v (map (\mkp -> mkp v) ps++opts) url + +quviSupported :: URLString -> Annex Bool +quviSupported u = liftIO . flip supported u =<< quviVersion + +quviVersion :: Annex QuviVersion +quviVersion = go =<< Annex.getState Annex.quviversion + where + go (Just v) = return v + go Nothing = do + v <- liftIO probeVersion + Annex.changeState $ \s -> s { Annex.quviversion = Just v } + return v diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs new file mode 100644 index 0000000000..1144ba0839 --- /dev/null +++ b/Annex/ReplaceFile.hs @@ -0,0 +1,50 @@ +{- 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 + +{- 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 action = replaceFileOr file action (liftIO . nukeFile) + +{- If unable to replace the file with the temp file, runs the + - rollback action, which is responsible for cleaning up the temp file. -} +replaceFileOr :: FilePath -> (FilePath -> Annex ()) -> (FilePath -> Annex ()) -> Annex () +replaceFileOr file action rollback = do + tmpdir <- fromRepo gitAnnexTmpMiscDir + void $ createAnnexDirectory tmpdir + tmpfile <- liftIO $ setup tmpdir + go tmpfile `catchNonAsync` (const $ rollback tmpfile) + where + setup tmpdir = do + (tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp" + hClose h + return tmpfile + go tmpfile = do + action tmpfile + liftIO $ replaceFileFrom tmpfile file + +replaceFileFrom :: FilePath -> FilePath -> IO () +replaceFileFrom src dest = go `catchIO` fallback + where + go = moveFile src dest + fallback _ = do + createDirectoryIfMissing True $ parentDir dest + go diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs new file mode 100644 index 0000000000..54c54d79f4 --- /dev/null +++ b/Annex/Ssh.hs @@ -0,0 +1,301 @@ +{- git-annex ssh interface, with connection caching + - + - Copyright 2012-2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Ssh ( + sshOptions, + sshCacheDir, + sshReadPort, + forceSshCleanup, + sshOptionsEnv, + sshOptionsTo, + inRepoWithSshOptionsTo, + runSshOptions, + sshAskPassEnv, + runSshAskPass +) where + +import qualified Data.Map as M +import Data.Hash.MD5 +import System.Exit + +import Common.Annex +import Annex.LockFile +import qualified Build.SysConfig as SysConfig +import qualified Annex +import qualified Git +import qualified Git.Url +import Config +import Config.Files +import Utility.Env +import Types.CleanupActions +import Annex.Index (addGitEnv) +#ifndef mingw32_HOST_OS +import Annex.Perms +import Utility.LockFile +#endif + +{- Generates parameters to ssh to a given host (or user@host) on a given + - port. This includes connection caching parameters, and any ssh-options. -} +sshOptions :: (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] +sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port) + where + go (Nothing, params) = ret params + go (Just socketfile, params) = do + prepSocket socketfile + ret params + ret ps = return $ concat + [ ps + , map Param (remoteAnnexSshOptions gc) + , opts + , portParams port + , [Param "-T"] + ] + +{- Returns a filename to use for a ssh connection caching socket, and + - parameters to enable ssh connection caching. -} +sshCachingInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) +sshCachingInfo (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 = replicate (1+16) '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 + let socktmp = tmpdir "ssh" + createDirectoryIfMissing True socktmp + return socktmp + +portParams :: Maybe Integer -> [CommandParam] +portParams Nothing = [] +portParams (Just port) = [Param "-p", Param $ show port] + +{- Prepare to use a socket file. Locks a lock file to prevent + - other git-annex processes from stopping the ssh on this socket. -} +prepSocket :: FilePath -> Annex () +prepSocket socketfile = do + -- 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. + whenM (not . any isLock . M.keys <$> getLockPool) + sshCleanup + -- Cleanup at end of this run. + Annex.addCleanup SshCachingCleanup sshCleanup + + liftIO $ createDirectoryIfMissing True $ parentDir socketfile + lockFileShared $ socket2lock socketfile + +enumSocketFiles :: Annex [FilePath] +enumSocketFiles = go =<< sshCacheDir + where + go Nothing = return [] + go (Just dir) = liftIO $ filter (not . isLock) + <$> catchDefaultIO [] (dirContents dir) + +{- Stop any unused ssh connection caching processes. -} +sshCleanup :: Annex () +sshCleanup = mapM_ cleanup =<< enumSocketFiles + where + 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. + -- + -- After ssh is stopped cannot remove the lock file; + -- other processes may be waiting on our exclusive + -- lock to use it. + let lockfile = socket2lock socketfile + unlockFile lockfile + mode <- annexFileMode + v <- liftIO $ noUmask mode $ tryLockExclusive (Just mode) lockfile + case v of + Nothing -> noop + Just lck -> do + forceStopSsh socketfile + liftIO $ dropLock lck +#else + forceStopSsh socketfile +#endif + +{- Stop all ssh connection caching processes, even when they're in use. -} +forceSshCleanup :: Annex () +forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles + +forceStopSsh :: FilePath -> Annex () +forceStopSsh 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 "localhost"]) + { cwd = Just dir } + liftIO $ nukeFile socketfile + +{- 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 + +{- When this env var is set, git-annex runs ssh with the specified + - options. (The options are separated by newlines.) + - + - This is a workaround for GIT_SSH not being able to contain + - additional parameters to pass to ssh. -} +sshOptionsEnv :: String +sshOptionsEnv = "GIT_ANNEX_SSHOPTION" + +toSshOptionsEnv :: [CommandParam] -> String +toSshOptionsEnv = unlines . toCommand + +fromSshOptionsEnv :: String -> [CommandParam] +fromSshOptionsEnv = map Param . lines + +{- Enables ssh caching for git push/pull to a particular + - remote git repo. (Can safely be used on non-ssh remotes.) + - + - Also propigates any configured ssh-options. + - + - Like inRepo, the action is run with the local git repo. + - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex, + - and sshOptionsEnv set so that git-annex will know what socket + - file to use. -} +inRepoWithSshOptionsTo :: Git.Repo -> RemoteGitConfig -> (Git.Repo -> IO a) -> Annex a +inRepoWithSshOptionsTo remote gc a = + liftIO . a =<< sshOptionsTo remote gc =<< gitRepo + +{- To make any git commands be run with ssh caching enabled, + - and configured ssh-options alters the local Git.Repo's gitEnv + - to set GIT_SSH=git-annex, and sets sshOptionsEnv. -} +sshOptionsTo :: Git.Repo -> RemoteGitConfig -> Git.Repo -> Annex Git.Repo +sshOptionsTo remote gc g + | not (Git.repoIsUrl remote) || Git.repoIsHttp remote = uncached + | otherwise = case Git.Url.hostuser remote of + Nothing -> uncached + Just host -> do + (msockfile, _) <- sshCachingInfo (host, Git.Url.port remote) + case msockfile of + Nothing -> return g + Just sockfile -> do + command <- liftIO readProgramFile + prepSocket sockfile + let val = toSshOptionsEnv $ concat + [ sshConnectionCachingParams sockfile + , map Param (remoteAnnexSshOptions gc) + ] + liftIO $ do + g' <- addGitEnv g sshOptionsEnv val + addGitEnv g' "GIT_SSH" command + where + uncached = return g + +runSshOptions :: [String] -> String -> IO () +runSshOptions args s = do + let args' = toCommand (fromSshOptionsEnv s) ++ args + let p = proc "ssh" args' + exitWith =<< waitForProcess . processHandle =<< createProcess p + +{- When this env var is set, git-annex is being used as a ssh-askpass + - program, and should read the password from the specified location, + - and output it for ssh to read. -} +sshAskPassEnv :: String +sshAskPassEnv = "GIT_ANNEX_SSHASKPASS" + +runSshAskPass :: FilePath -> IO () +runSshAskPass passfile = putStrLn =<< readFile passfile diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs new file mode 100644 index 0000000000..642d4db0bb --- /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 $ Git.fromRef $ Git.Ref.base b + ] + +fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String) +fromTaggedBranch b = case split "/" $ Git.fromRef 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 = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b) diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs new file mode 100644 index 0000000000..2723b2351b --- /dev/null +++ b/Annex/Transfer.hs @@ -0,0 +1,145 @@ +{- git-annex transfers + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Transfer ( + module X, + upload, + download, + runTransfer, + alwaysRunTransfer, + noRetry, + forwardRetry, +) where + +import Common.Annex +import Logs.Transfer as X +import Annex.Notification as X +import Annex.Perms +import Utility.Metered +#ifdef mingw32_HOST_OS +import Utility.LockFile +#endif + +import Control.Concurrent + +upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool +upload u key f d a _witness = runTransfer (Transfer Upload u key) f d a + +download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool +download u key f d a _witness = runTransfer (Transfer Download u key) f d a + +{- Runs a transfer action. Creates and locks the lock file while the + - action is running, and stores info in the transfer information + - file. + - + - If the transfer action returns False, the transfer info is + - left in the failedTransferDir. + - + - If the transfer is already in progress, returns False. + - + - An upload can be run from a read-only filesystem, and in this case + - no transfer information or lock file is used. + -} +runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool +runTransfer = runTransfer' False + +{- Like runTransfer, but ignores any existing transfer lock file for the + - transfer, allowing re-running a transfer that is already in progress. + - + - Note that this may result in confusing progress meter display in the + - webapp, if multiple processes are writing to the transfer info file. -} +alwaysRunTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool +alwaysRunTransfer = runTransfer' True + +runTransfer' :: Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool +runTransfer' ignorelock t file shouldretry a = do + info <- liftIO $ startTransferInfo file + (meter, tfile, metervar) <- mkProgressUpdater t info + mode <- annexFileMode + (fd, inprogress) <- liftIO $ prep tfile mode info + if inprogress && not ignorelock + then do + showNote "transfer already in progress" + return False + else do + ok <- retry info metervar $ + bracketIO (return fd) (cleanup tfile) (const $ a meter) + unless ok $ recordFailedTransfer t info + return ok + where +#ifndef mingw32_HOST_OS + prep tfile mode info = do + mfd <- catchMaybeIO $ + openFd (transferLockFile tfile) ReadWrite (Just mode) + defaultFileFlags { trunc = True } + case mfd of + Nothing -> return (Nothing, False) + Just fd -> do + setFdOption fd CloseOnExec True + locked <- catchMaybeIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + if isNothing locked + then do + closeFd fd + return (Nothing, True) + else do + void $ tryIO $ writeTransferInfoFile info tfile + return (mfd, False) +#else + prep tfile _mode info = do + v <- catchMaybeIO $ lockExclusive (transferLockFile tfile) + case v of + Nothing -> return (Nothing, False) + Just Nothing -> return (Nothing, True) + Just (Just lockhandle) -> do + void $ tryIO $ writeTransferInfoFile info tfile + return (Just lockhandle, False) +#endif + cleanup _ Nothing = noop + cleanup tfile (Just lockhandle) = do + void $ tryIO $ removeFile tfile +#ifndef mingw32_HOST_OS + void $ tryIO $ removeFile $ transferLockFile tfile + closeFd lockhandle +#else + {- Windows cannot delete the lockfile until the lock + - is closed. So it's possible to race with another + - process that takes the lock before it's removed, + - so ignore failure to remove. + -} + dropLock lockhandle + void $ tryIO $ removeFile $ transferLockFile tfile +#endif + retry oldinfo metervar run = do + v <- tryNonAsync run + case v of + Right b -> return b + Left e -> do + warning (show e) + b <- getbytescomplete metervar + let newinfo = oldinfo { bytesComplete = Just b } + if shouldretry oldinfo newinfo + then retry newinfo metervar run + else return False + getbytescomplete metervar + | transferDirection t == Upload = + liftIO $ readMVar metervar + | otherwise = do + f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) + liftIO $ catchDefaultIO 0 $ getFileSize f + +type RetryDecider = TransferInfo -> TransferInfo -> Bool + +noRetry :: RetryDecider +noRetry _ _ = False + +{- Retries a transfer when it fails, as long as the failed transfer managed + - to send some data. -} +forwardRetry :: RetryDecider +forwardRetry old new = bytesComplete old < bytesComplete new diff --git a/Annex/UUID.hs b/Annex/UUID.hs new file mode 100644 index 0000000000..7776b778a3 --- /dev/null +++ b/Annex/UUID.hs @@ -0,0 +1,110 @@ +{- 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, + storeUUIDIn, + setUUID, + webUUID, + bitTorrentUUID, +) 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) $ storeUUIDIn 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 =<< liftIO genUUID + +storeUUID :: UUID -> Annex () +storeUUID = storeUUIDIn configkey + +storeUUIDIn :: ConfigKey -> UUID -> Annex () +storeUUIDIn 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 + +-- Dummy uuid for the whole web. Do not alter. +webUUID :: UUID +webUUID = UUID "00000000-0000-0000-0000-000000000001" + +-- Dummy uuid for bittorrent. Do not alter. +bitTorrentUUID :: UUID +bitTorrentUUID = UUID "00000000-0000-0000-0000-000000000002" diff --git a/Annex/Url.hs b/Annex/Url.hs new file mode 100644 index 0000000000..b1a932e629 --- /dev/null +++ b/Annex/Url.hs @@ -0,0 +1,42 @@ +{- Url downloading, with git-annex user agent and configured http + - headers and wget/curl options. + - + - Copyright 2013-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Url ( + module U, + withUrlOptions, + getUrlOptions, + 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 + +getUrlOptions :: Annex U.UrlOptions +getUrlOptions = mkUrlOptions + <$> getUserAgent + <*> headers + <*> options + where + headers = do + v <- annexHttpHeadersCommand <$> Annex.getGitConfig + case v of + Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) + Nothing -> annexHttpHeaders <$> Annex.getGitConfig + options = map Param . annexWebOptions <$> Annex.getGitConfig + +withUrlOptions :: (U.UrlOptions -> IO a) -> Annex a +withUrlOptions a = liftIO . a =<< getUrlOptions diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs new file mode 100644 index 0000000000..89cfbc16af --- /dev/null +++ b/Annex/VariantFile.hs @@ -0,0 +1,45 @@ +{- git-annex .variant files for automatic merge conflict resolution + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.VariantFile where + +import Common.Annex +import Types.Key + +import Data.Hash.MD5 + +variantMarker :: String +variantMarker = ".variant-" + +mkVariant :: FilePath -> String -> FilePath +mkVariant file variant = takeDirectory file + dropExtension (takeFileName file) + ++ variantMarker ++ variant + ++ takeExtension file + +{- The filename to use when resolving a conflicted merge of a file, + - that points to a key. + - + - Something derived from the key needs to be included in the filename, + - but rather than exposing the whole key to the user, a very weak hash + - is used. There is a very real, although still unlikely, chance of + - conflicts using this hash. + - + - In the event that there is a conflict with the filename generated + - for some other key, that conflict will itself be handled by the + - conflicted merge resolution code. That case is detected, and the full + - key is used in the filename. + -} +variantFile :: FilePath -> Key -> FilePath +variantFile file key + | doubleconflict = mkVariant file (key2file key) + | otherwise = mkVariant file (shortHash $ key2file key) + where + doubleconflict = variantMarker `isInfixOf` file + +shortHash :: String -> String +shortHash = take 4 . md5s . md5FilePath diff --git a/Annex/Version.hs b/Annex/Version.hs new file mode 100644 index 0000000000..d08f994e95 --- /dev/null +++ b/Annex/Version.hs @@ -0,0 +1,41 @@ +{- 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 + +supportedVersion :: Version +supportedVersion = "5" + +upgradableVersions :: [Version] +#ifndef mingw32_HOST_OS +upgradableVersions = ["0", "1", "2", "4"] +#else +upgradableVersions = ["2", "3", "4"] +#endif + +autoUpgradeableVersions :: [Version] +autoUpgradeableVersions = ["3", "4"] + +versionField :: ConfigKey +versionField = annexConfig "version" + +getVersion :: Annex (Maybe Version) +getVersion = annexVersion <$> Annex.getGitConfig + +setVersion :: Version -> Annex () +setVersion = setConfig versionField + +removeVersion :: Annex () +removeVersion = unsetConfig versionField diff --git a/Annex/View.hs b/Annex/View.hs new file mode 100644 index 0000000000..315cc7df2e --- /dev/null +++ b/Annex/View.hs @@ -0,0 +1,450 @@ +{- metadata based branch views + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.View where + +import Common.Annex +import Annex.View.ViewedFile +import Types.View +import Types.MetaData +import Annex.MetaData +import qualified Git +import qualified Git.DiffTree as DiffTree +import qualified Git.Branch +import qualified Git.LsFiles +import qualified Git.Ref +import Git.UpdateIndex +import Git.Sha +import Git.HashObject +import Git.Types +import Git.FilePath +import qualified Backend +import Annex.Index +import Annex.Link +import Annex.CatFile +import Logs.MetaData +import Logs.View +import Utility.Glob +import Utility.FileMode +import Types.Command +import Config +import CmdLine.Action + +import qualified Data.Set as S +import qualified Data.Map as M +import "mtl" Control.Monad.Writer + +{- Each visible ViewFilter in a view results in another level of + - subdirectory nesting. When a file matches multiple ways, it will appear + - in multiple subdirectories. This means there is a bit of an exponential + - blowup with a single file appearing in a crazy number of places! + - + - Capping the view size to 5 is reasonable; why wants to dig + - through 5+ levels of subdirectories to find anything? + -} +viewTooLarge :: View -> Bool +viewTooLarge view = visibleViewSize view > 5 + +visibleViewSize :: View -> Int +visibleViewSize = length . filter viewVisible . viewComponents + +{- Parses field=value, field!=value, tag, and !tag + - + - Note that the field may not be a legal metadata field name, + - but it's let through anyway. + - This is useful when matching on directory names with spaces, + - which are not legal MetaFields. + -} +parseViewParam :: String -> (MetaField, ViewFilter) +parseViewParam s = case separate (== '=') s of + ('!':tag, []) | not (null tag) -> + ( tagMetaField + , mkExcludeValues tag + ) + (tag, []) -> + ( tagMetaField + , mkFilterValues tag + ) + (field, wanted) + | end field == "!" -> + ( mkMetaFieldUnchecked (beginning field) + , mkExcludeValues wanted + ) + | otherwise -> + ( mkMetaFieldUnchecked field + , mkFilterValues wanted + ) + where + mkFilterValues v + | any (`elem` v) "*?" = FilterGlob v + | otherwise = FilterValues $ S.singleton $ toMetaValue v + mkExcludeValues = ExcludeValues . S.singleton . toMetaValue + +data ViewChange = Unchanged | Narrowing | Widening + deriving (Ord, Eq, Show) + +{- Updates a view, adding new fields to filter on (Narrowing), + - or allowing new values in an existing field (Widening). -} +refineView :: View -> [(MetaField, ViewFilter)] -> (View, ViewChange) +refineView origview = checksize . calc Unchanged origview + where + calc c v [] = (v, c) + calc c v ((f, vf):rest) = + let (v', c') = refine v f vf + in calc (max c c') v' rest + + refine view field vf + | field `elem` map viewField (viewComponents view) = + let (components', viewchanges) = runWriter $ + mapM (\c -> updateViewComponent c field vf) (viewComponents view) + viewchange = if field `elem` map viewField (viewComponents origview) + then maximum viewchanges + else Narrowing + in (view { viewComponents = components' }, viewchange) + | otherwise = + let component = mkViewComponent field vf + view' = view { viewComponents = component : viewComponents view } + in (view', Narrowing) + + checksize r@(v, _) + | viewTooLarge v = error $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)" + | otherwise = r + +updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent +updateViewComponent c field vf + | viewField c == field = do + let (newvf, viewchange) = combineViewFilter (viewFilter c) vf + tell [viewchange] + return $ mkViewComponent field newvf + | otherwise = return c + +{- Adds an additional filter to a view. This can only result in narrowing + - the view. Multivalued filters are added in non-visible form. -} +filterView :: View -> [(MetaField, ViewFilter)] -> View +filterView v vs = v { viewComponents = viewComponents f' ++ viewComponents v} + where + f = fst $ refineView (v {viewComponents = []}) vs + f' = f { viewComponents = map toinvisible (viewComponents f) } + toinvisible c = c { viewVisible = False } + +{- Combine old and new ViewFilters, yielding a result that matches + - either old+new, or only new. + - + - If we have FilterValues and change to a FilterGlob, + - it's always a widening change, because the glob could match other + - values. OTOH, going the other way, it's a Narrowing change if the old + - glob matches all the new FilterValues. + - + - With two globs, the old one is discarded, and the new one is used. + - We can tell if that's a narrowing change by checking if the old + - glob matches the new glob. For example, "*" matches "foo*", + - so that's narrowing. While "f?o" does not match "f??", so that's + - widening. + -} +combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange) +combineViewFilter old@(FilterValues olds) (FilterValues news) + | combined == old = (combined, Unchanged) + | otherwise = (combined, Widening) + where + combined = FilterValues (S.union olds news) +combineViewFilter old@(ExcludeValues olds) (ExcludeValues news) + | combined == old = (combined, Unchanged) + | otherwise = (combined, Narrowing) + where + combined = ExcludeValues (S.union olds news) +combineViewFilter (FilterValues _) newglob@(FilterGlob _) = + (newglob, Widening) +combineViewFilter (FilterGlob oldglob) new@(FilterValues s) + | all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing) + | otherwise = (new, Widening) +combineViewFilter (FilterGlob old) newglob@(FilterGlob new) + | old == new = (newglob, Unchanged) + | matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing) + | otherwise = (newglob, Widening) +combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing) +combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening) +combineViewFilter (FilterValues _) new@(ExcludeValues _) = (new, Narrowing) +combineViewFilter (ExcludeValues _) new@(FilterValues _) = (new, Widening) + +{- Generates views for a file from a branch, based on its metadata + - and the filename used in the branch. + - + - Note that a file may appear multiple times in a view, when it + - has multiple matching values for a MetaField used in the View. + - + - Of course if its MetaData does not match the View, it won't appear at + - all. + - + - Note that for efficiency, it's useful to partially + - evaluate this function with the view parameter and reuse + - the result. The globs in the view will then be compiled and memoized. + -} +viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile] +viewedFiles view = + let matchers = map viewComponentMatcher (viewComponents view) + in \mkviewedfile file metadata -> + let matches = map (\m -> m metadata) matchers + in if any isNothing matches + then [] + else + let paths = pathProduct $ + map (map toViewPath) (visible matches) + in if null paths + then [mkviewedfile file] + else map ( mkviewedfile file) paths + where + visible = map (fromJust . snd) . + filter (viewVisible . fst) . + zip (viewComponents view) + +{- Checks if metadata matches a ViewComponent filter, and if so + - returns the value, or values that match. Self-memoizing on ViewComponent. -} +viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue]) +viewComponentMatcher viewcomponent = \metadata -> + matcher (currentMetaDataValues metafield metadata) + where + metafield = viewField viewcomponent + matcher = case viewFilter viewcomponent of + FilterValues s -> \values -> setmatches $ + S.intersection s values + FilterGlob glob -> + let cglob = compileGlob glob CaseInsensative + in \values -> setmatches $ + S.filter (matchGlob cglob . fromMetaValue) values + ExcludeValues excludes -> \values -> + if S.null (S.intersection values excludes) + then Just [] + else Nothing + setmatches s + | S.null s = Nothing + | otherwise = Just (S.toList s) + +toViewPath :: MetaValue -> FilePath +toViewPath = concatMap escapeslash . fromMetaValue + where + escapeslash c + | c == '/' = [pseudoSlash] + | c == '\\' = [pseudoBackslash] + | c == pseudoSlash = [pseudoSlash, pseudoSlash] + | c == pseudoBackslash = [pseudoBackslash, pseudoBackslash] + | otherwise = [c] + +fromViewPath :: FilePath -> MetaValue +fromViewPath = toMetaValue . deescapeslash [] + where + deescapeslash s [] = reverse s + deescapeslash s (c:cs) + | c == pseudoSlash = case cs of + (c':cs') + | c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs' + _ -> deescapeslash ('/':s) cs + | c == pseudoBackslash = case cs of + (c':cs') + | c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs' + _ -> deescapeslash ('/':s) cs + | otherwise = deescapeslash (c:s) cs + +pseudoSlash :: Char +pseudoSlash = '\8725' -- '∕' /= '/' + +pseudoBackslash :: Char +pseudoBackslash = '\9586' -- '╲' /= '\' + +pathProduct :: [[FilePath]] -> [FilePath] +pathProduct [] = [] +pathProduct (l:ls) = foldl combinel l ls + where + combinel xs ys = [combine x y | x <- xs, y <- ys] + +{- Extracts the metadata from a ViewedFile, based on the view that was used + - to construct it. + - + - Derived metadata is excluded. + -} +fromView :: View -> ViewedFile -> MetaData +fromView view f = MetaData $ + M.fromList (zip fields values) `M.difference` derived + where + visible = filter viewVisible (viewComponents view) + fields = map viewField visible + paths = splitDirectories (dropFileName f) + values = map (S.singleton . fromViewPath) paths + MetaData derived = getViewedFileMetaData f + +{- Constructing a view that will match arbitrary metadata, and applying + - it to a file yields a set of ViewedFile which all contain the same + - MetaFields that were present in the input metadata + - (excluding fields that are not visible). -} +prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool +prop_view_roundtrips f metadata visible = null f || viewTooLarge view || + all hasfields (viewedFiles view viewedFileFromReference f metadata) + where + view = View (Git.Ref "master") $ + map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible) + (fromMetaData metadata) + visiblefields = sort (map viewField $ filter viewVisible (viewComponents view)) + hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields + +{- A directory foo/bar/baz/ is turned into metadata fields + - /=foo, foo/=bar, foo/bar/=baz. + - + - Note that this may generate MetaFields that legalField rejects. + - This is necessary to have a 1:1 mapping between directory names and + - fields. So this MetaData cannot safely be serialized. -} +getDirMetaData :: FilePath -> MetaData +getDirMetaData d = MetaData $ M.fromList $ zip fields values + where + dirs = splitDirectories d + fields = map (mkMetaFieldUnchecked . addTrailingPathSeparator . joinPath) + (inits dirs) + values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe) + (tails dirs) + +getWorkTreeMetaData :: FilePath -> MetaData +getWorkTreeMetaData = getDirMetaData . dropFileName + +getViewedFileMetaData :: FilePath -> MetaData +getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName + +{- Applies a view to the currently checked out branch, generating a new + - branch for the view. + -} +applyView :: View -> Annex Git.Branch +applyView view = applyView' viewedFileFromReference getWorkTreeMetaData view + +{- Generates a new branch for a View, which must be a more narrow + - version of the View originally used to generate the currently + - checked out branch. That is, it must match a subset of the files + - in view, not any others. + -} +narrowView :: View -> Annex Git.Branch +narrowView = applyView' viewedFileReuse getViewedFileMetaData + +{- Go through each file in the currently checked out branch. + - If the file is not annexed, skip it, unless it's a dotfile in the top. + - Look up the metadata of annexed files, and generate any ViewedFiles, + - and stage them. + - + - Currently only works in indirect mode. Must be run from top of + - repository. + -} +applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch +applyView' mkviewedfile getfilemetadata view = do + top <- fromRepo Git.repoPath + (l, clean) <- inRepo $ Git.LsFiles.inRepo [top] + liftIO . nukeFile =<< fromRepo gitAnnexViewIndex + genViewBranch view $ do + uh <- inRepo Git.UpdateIndex.startUpdateIndex + hasher <- inRepo hashObjectStart + forM_ l $ \f -> do + relf <- getTopFilePath <$> inRepo (toTopFilePath f) + go uh hasher relf =<< Backend.lookupFile f + liftIO $ do + hashObjectStop hasher + void $ stopUpdateIndex uh + void clean + where + genviewedfiles = viewedFiles view mkviewedfile -- enables memoization + go uh hasher f (Just k) = do + metadata <- getCurrentMetaData k + let metadata' = getfilemetadata f `unionMetaData` metadata + forM_ (genviewedfiles f metadata') $ \fv -> do + f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv + stagesymlink uh hasher f' =<< calcRepo (gitAnnexLink f' k) + go uh hasher f Nothing + | "." `isPrefixOf` f = do + s <- liftIO $ getSymbolicLinkStatus f + if isSymbolicLink s + then stagesymlink uh hasher f =<< liftIO (readSymbolicLink f) + else do + sha <- liftIO $ Git.HashObject.hashFile hasher f + let blobtype = if isExecutable (fileMode s) + then ExecutableBlob + else FileBlob + liftIO . Git.UpdateIndex.streamUpdateIndex' uh + =<< inRepo (Git.UpdateIndex.stageFile sha blobtype f) + | otherwise = noop + stagesymlink uh hasher f linktarget = do + sha <- hashSymlink' hasher linktarget + liftIO . Git.UpdateIndex.streamUpdateIndex' uh + =<< inRepo (Git.UpdateIndex.stageSymlink f sha) + +{- Applies a view to the reference branch, generating a new branch + - for the View. + - + - This needs to work incrementally, to quickly update the view branch + - when the reference branch is changed. So, it works based on an + - old version of the reference branch, uses diffTree to find the + - changes, and applies those changes to the view branch. + -} +updateView :: View -> Git.Ref -> Git.Ref -> Annex Git.Branch +updateView view ref oldref = genViewBranch view $ do + (diffs, cleanup) <- inRepo $ DiffTree.diffTree oldref ref + forM_ diffs go + void $ liftIO cleanup + where + go diff + | DiffTree.dstsha diff == nullSha = error "TODO delete file" + | otherwise = error "TODO add file" + +{- Diff between currently checked out branch and staged changes, and + - update metadata to reflect the changes that are being committed to the + - view. + - + - Adding a file to a directory adds the metadata represented by + - that directory to the file, and removing a file from a directory + - removes the metadata. + - + - Note that removes must be handled before adds. This is so + - that moving a file from x/foo/ to x/bar/ adds back the metadata for x. + -} +withViewChanges :: (ViewedFile -> Key -> CommandStart) -> (ViewedFile -> Key -> CommandStart) -> Annex () +withViewChanges addmeta removemeta = do + makeabs <- flip fromTopFilePath <$> gitRepo + (diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef + forM_ diffs handleremovals + forM_ diffs (handleadds makeabs) + void $ liftIO cleanup + where + handleremovals item + | DiffTree.srcsha item /= nullSha = + handlechange item removemeta + =<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item) + | otherwise = noop + handleadds makeabs item + | DiffTree.dstsha item /= nullSha = + handlechange item addmeta + =<< ifM isDirect + ( catKey (DiffTree.dstsha item) (DiffTree.dstmode item) + -- optimisation + , isAnnexLink $ makeabs $ DiffTree.file item + ) + | otherwise = noop + handlechange item a = maybe noop + (void . commandAction . a (getTopFilePath $ DiffTree.file item)) + +{- Generates a branch for a view. This is done using a different index + - file. An action is run to stage the files that will be in the branch. + - Then a commit is made, to the view branch. The view branch is not + - checked out, but entering it will display the view. -} +genViewBranch :: View -> Annex () -> Annex Git.Branch +genViewBranch view a = withIndex $ do + a + let branch = branchView view + void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch [] + return branch + +{- Runs an action using the view index file. + - Note that the file does not necessarily exist, or can contain + - info staged for an old view. -} +withIndex :: Annex a -> Annex a +withIndex a = do + f <- fromRepo gitAnnexViewIndex + withIndexFile f a + +withCurrentView :: (View -> Annex a) -> Annex a +withCurrentView a = maybe (error "Not in a view.") a =<< currentView diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs new file mode 100644 index 0000000000..0acba235a7 --- /dev/null +++ b/Annex/View/ViewedFile.hs @@ -0,0 +1,86 @@ +{- filenames (not paths) used in views + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.View.ViewedFile ( + ViewedFile, + MkViewedFile, + viewedFileFromReference, + viewedFileReuse, + dirFromViewedFile, + prop_viewedFile_roundtrips, +) where + +import Common.Annex + +type FileName = String +type ViewedFile = FileName + +type MkViewedFile = FilePath -> ViewedFile + +{- Converts a filepath used in a reference branch to the + - filename that will be used in the view. + - + - No two filepaths from the same branch should yeild the same result, + - so all directory structure needs to be included in the output filename + - in some way. + - + - So, from dir/subdir/file.foo, generate file_%dir%subdir%.foo + -} +viewedFileFromReference :: MkViewedFile +viewedFileFromReference f = concat + [ escape base + , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%" + , escape $ concat extensions + ] + where + (path, basefile) = splitFileName f + dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) + (base, extensions) = splitShortExtensions basefile + + {- To avoid collisions with filenames or directories that contain + - '%', and to allow the original directories to be extracted + - from the ViewedFile, '%' is escaped. ) + -} + escape :: String -> String + escape = replace "%" (escchar:'%':[]) . replace [escchar] [escchar, escchar] + +escchar :: Char +#ifndef mingw32_HOST_OS +escchar = '\\' +#else +-- \ is path separator on Windows, so instead use ! +escchar = '!' +#endif + +{- For use when operating already within a view, so whatever filepath + - is present in the work tree is already a ViewedFile. -} +viewedFileReuse :: MkViewedFile +viewedFileReuse = takeFileName + +{- Extracts from a ViewedFile the directory where the file is located on + - in the reference branch. -} +dirFromViewedFile :: ViewedFile -> FilePath +dirFromViewedFile = joinPath . drop 1 . sep [] "" + where + sep l _ [] = reverse l + sep l curr (c:cs) + | c == '%' = sep (reverse curr:l) "" cs + | c == escchar = case cs of + (c':cs') -> sep l (c':curr) cs' + [] -> sep l curr cs + | otherwise = sep l (c:curr) cs + +prop_viewedFile_roundtrips :: FilePath -> Bool +prop_viewedFile_roundtrips f + -- Relative filenames wanted, not directories. + | any (isPathSeparator) (end f ++ beginning f) = True + | isAbsolute f = True + | otherwise = dir == dirFromViewedFile (viewedFileFromReference f) + where + dir = joinPath $ beginning $ splitDirectories f diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs new file mode 100644 index 0000000000..ba7df0a9cb --- /dev/null +++ b/Annex/Wanted.hs @@ -0,0 +1,29 @@ +{- 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 -> Maybe Key -> AssociatedFile -> Annex Bool +wantGet d key file = isPreferredContent Nothing S.empty key file d + +{- Check if a file is preferred content for a remote. -} +wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool +wantSend d key file to = isPreferredContent (Just to) S.empty key file d + +{- Check if a file can be dropped, maybe from a remote. + - Don't drop files that are preferred content. -} +wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool +wantDrop d from key file = do + u <- maybe getUUID (return . id) from + not <$> isPreferredContent (Just u) (S.singleton u) key file d diff --git a/Assistant.hs b/Assistant.hs new file mode 100644 index 0000000000..eb01bb9b97 --- /dev/null +++ b/Assistant.hs @@ -0,0 +1,197 @@ +{- 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.RemoteControl +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.Upgrader +import Assistant.Threads.UpgradeWatcher +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 +import Assistant.Types.UrlRenderer +#endif +import qualified Utility.Daemon +import Utility.ThreadScheduler +import Utility.HumanTime +import qualified Build.SysConfig as SysConfig +import Annex.Perms +import Utility.LogFile +#ifdef mingw32_HOST_OS +import Utility.Env +import Config.Files +import System.Environment (getArgs) +#endif + +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 String -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () +startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do + + Annex.changeState $ \s -> s { Annex.daemon = True } + pidfile <- fromRepo gitAnnexPidFile + logfile <- fromRepo gitAnnexLogFile + liftIO $ debugM desc $ "logging to " ++ logfile +#ifndef mingw32_HOST_OS + createAnnexDirectory (parentDir logfile) + logfd <- liftIO $ handleToFd =<< openLog logfile + if foreground + then do + origout <- liftIO $ catchMaybeIO $ + fdToHandle =<< dup stdOutput + origerr <- liftIO $ catchMaybeIO $ + fdToHandle =<< dup stdError + let undaemonize = Utility.Daemon.foreground logfd (Just pidfile) + start undaemonize $ + case startbrowser of + Nothing -> Nothing + Just a -> Just $ a origout origerr + else + start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing +#else + -- Windows doesn't daemonize, but does redirect output to the + -- log file. The only way to do so is to restart the program. + when (foreground || not foreground) $ do + let flag = "GIT_ANNEX_OUTPUT_REDIR" + createAnnexDirectory (parentDir logfile) + ifM (liftIO $ isNothing <$> getEnv flag) + ( liftIO $ withFile devNull WriteMode $ \nullh -> do + loghandle <- openLog logfile + e <- getEnvironment + cmd <- readProgramFile + ps <- getArgs + (_, _, _, pid) <- createProcess (proc cmd ps) + { env = Just (addEntry flag "1" e) + , std_in = UseHandle nullh + , std_out = UseHandle loghandle + , std_err = UseHandle loghandle + } + exitWith =<< waitForProcess pid + , start (Utility.Daemon.foreground (Just pidfile)) $ + case startbrowser of + Nothing -> Nothing + Just a -> Just $ a Nothing Nothing + ) +#endif + 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 +#ifdef WITH_WEBAPP + let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ] +#else + let webappthread = [] +#endif + let threads = if isJust cannotrun + then webappthread + else webappthread ++ + [ watch commitThread +#ifdef WITH_WEBAPP +#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 remoteControlThread + , assist daemonStatusThread + , assist $ sanityCheckerDailyThread urlrenderer + , assist sanityCheckerHourlyThread + , assist $ problemFixerThread urlrenderer +#ifdef WITH_CLIBS + , assist $ mountWatcherThread urlrenderer +#endif + , assist netWatcherThread + , assist $ upgraderThread urlrenderer + , assist $ upgradeWatcherThread urlrenderer + , 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 + ] + + mapM_ (startthread urlrenderer) threads + 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..1286e4590b --- /dev/null +++ b/Assistant/Alert.hs @@ -0,0 +1,461 @@ +{- git-annex assistant alerts + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-} + +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 Types.Distribution +import Git.Types (RemoteName) + +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 + , buttonPrimary = True + } +#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 + , alertButtons = [] + } + +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 + , alertButtons = [] + } + +errorAlert :: String -> [AlertButton] -> Alert +errorAlert msg buttons = 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 + , alertButtons = buttons + } + +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 :: [RemoteName] -> TenseChunk +showRemotes = UnTensed . T.intercalate ", " . map T.pack + +syncAlert :: [Remote] -> Alert +syncAlert = syncAlert' . map Remote.name + +syncAlert' :: [RemoteName] -> 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 = syncResultAlert' + (map Remote.name succeeded) + (map Remote.name failed) + +syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert +syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $ + baseActivityAlert + { alertName = Just SyncAlert + , alertHeader = Just $ tenseWords msg + } + where + msg + | 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 (++) + , alertButtons = [] + } + 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"] + , alertButtons = [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 + , alertButtons = [button] + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just NotFsckedAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + +baseUpgradeAlert :: [AlertButton] -> TenseText -> Alert +baseUpgradeAlert buttons message = Alert + { alertHeader = Just message + , alertIcon = Just UpgradeIcon + , alertPriority = High + , alertButtons = buttons + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just UpgradeAlert + , alertCombiner = Just $ fullCombiner $ \new _old -> new + , alertData = [] + } + +canUpgradeAlert :: AlertPriority -> GitAnnexVersion -> AlertButton -> Alert +canUpgradeAlert priority version button = + (baseUpgradeAlert [button] $ fromString msg) + { alertPriority = priority + , alertData = [fromString $ " (version " ++ version ++ ")"] + } + where + msg = if priority >= High + then "An important upgrade of git-annex is available!" + else "An upgrade of git-annex is available." + +upgradeReadyAlert :: AlertButton -> Alert +upgradeReadyAlert button = baseUpgradeAlert [button] $ + fromString "A new version of git-annex has been installed." + +upgradingAlert :: Alert +upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ] + +upgradeFinishedAlert :: Maybe AlertButton -> GitAnnexVersion -> Alert +upgradeFinishedAlert button version = + baseUpgradeAlert (maybeToList button) $ fromString $ + "Finished upgrading git-annex to version " ++ version + +upgradeFailedAlert :: String -> Alert +upgradeFailedAlert msg = (errorAlert msg []) + { alertHeader = Just $ fromString "Upgrade failed." } + +unusedFilesAlert :: [AlertButton] -> String -> Alert +unusedFilesAlert buttons message = Alert + { alertHeader = Just $ fromString $ unwords + [ "Old and deleted files are piling up --" + , message + ] + , alertIcon = Just InfoIcon + , alertPriority = High + , alertButtons = buttons + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just UnusedFilesAlert + , alertCombiner = Just $ fullCombiner $ \new _old -> 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 + , alertButtons = [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 + , alertButtons = [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 + , alertButtons = maybeToList button + } + +connectionNeededAlert :: AlertButton -> Alert +connectionNeededAlert button = Alert + { alertHeader = Just "Share with friends, and keep your devices in sync across the cloud." + , alertIcon = Just ConnectionIcon + , alertPriority = High + , alertButtons = [button] + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just ConnectionNeededAlert + , 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 + , alertButtons = [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 + , alertButtons = [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..65484e0e63 --- /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 + `mappend` compare aid bid + `mappend` 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 + , alertButtons = [] + , 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..c588c910a7 --- /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..6eb9bc28e5 --- /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..c82f8f4c7f --- /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..5fab842908 --- /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/CredPairCache.hs b/Assistant/CredPairCache.hs new file mode 100644 index 0000000000..ac355b55a5 --- /dev/null +++ b/Assistant/CredPairCache.hs @@ -0,0 +1,53 @@ +{- git-annex assistant CredPair cache. + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Assistant.CredPairCache ( + cacheCred, + getCachedCred, + expireCachedCred, +) where + +import Assistant.Types.CredPairCache +import Types.Creds +import Assistant.Common +import Utility.ThreadScheduler + +import qualified Data.Map as M +import Control.Concurrent + +{- Caches a CredPair, but only for a limited time, after which it + - will expire. + - + - Note that repeatedly caching the same CredPair + - does not reset its expiry time. + -} +cacheCred :: CredPair -> Seconds -> Assistant () +cacheCred (login, password) expireafter = do + cache <- getAssistant credPairCache + liftIO $ do + changeStrict cache $ M.insert login password + void $ forkIO $ do + threadDelaySeconds expireafter + changeStrict cache $ M.delete login + +getCachedCred :: Login -> Assistant (Maybe Password) +getCachedCred login = do + cache <- getAssistant credPairCache + liftIO $ M.lookup login <$> readMVar cache + +expireCachedCred :: Login -> Assistant () +expireCachedCred login = do + cache <- getAssistant credPairCache + liftIO $ changeStrict cache $ M.delete login + +{- Update map strictly to avoid keeping references to old creds in memory. -} +changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO () +changeStrict cache a = modifyMVar_ cache $ \m -> do + let !m' = a m + return m' diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs new file mode 100644 index 0000000000..1ed40595e1 --- /dev/null +++ b/Assistant/DaemonStatus.hs @@ -0,0 +1,271 @@ +{- git-annex assistant daemon status + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +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.Set as S +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 . Remote.isXMPPRemote) syncable + + return $ \dstatus -> dstatus + { syncRemotes = syncable + , syncGitRemotes = filter Remote.gitSyncableRemote syncable + , syncDataRemotes = syncdata + , syncingToCloudRemote = any iscloud syncdata + } + where + iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable + +{- Updates the syncRemotes list from the list of all remotes in Annex state. -} +updateSyncRemotes :: Assistant () +updateSyncRemotes = do + modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes + status <- getDaemonStatus + liftIO $ sendNotification $ syncRemotesNotifier status + + when (syncingToCloudRemote status) $ + updateAlertMap $ + M.filter $ \alert -> + alertName alert /= Just CloudRepoNeededAlert + +changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant () +changeCurrentlyConnected sm = do + modifyDaemonStatus_ $ \ds -> ds + { currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds) + } + v <- currentlyConnectedRemotes <$> getDaemonStatus + debug [show v] + liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus + +updateScheduleLog :: Assistant () +updateScheduleLog = + liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus + +{- 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 + let !v = a (currentTransfers s) + putTMVar dstatus $ s { currentTransfers = v } + +{- 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 = + let !m = a (alertMap s) + in s { alertMap = m } + +{- 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 + +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..5b044fd184 --- /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.Remove +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.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..57eef8f3ae --- /dev/null +++ b/Assistant/Drop.hs @@ -0,0 +1,25 @@ +{- git-annex assistant dropping of unwanted content + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Drop ( + handleDrops, + handleDropsFrom, +) where + +import Assistant.Common +import Assistant.DaemonStatus +import Annex.Drop (handleDropsFrom, Reason) +import Logs.Location +import CmdLine.Action + +{- Drop from local and/or remote when allowed by the preferred content and + - numcopies settings. -} +handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant () +handleDrops reason fromhere key f knownpresentremote = do + syncrs <- syncDataRemotes <$> getDaemonStatus + locs <- liftAnnex $ loggedLocations key + liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction diff --git a/Assistant/Fsck.hs b/Assistant/Fsck.hs new file mode 100644 index 0000000000..067c7d1a10 --- /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..39e545978b --- /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..6da6d2389a --- /dev/null +++ b/Assistant/Install.hs @@ -0,0 +1,179 @@ +{- 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 Config.Files +import Utility.FileMode +import Utility.Shell +import Utility.Tmp +import Utility.Env +import Utility.SshConfig + +#ifdef darwin_HOST_OS +import Utility.OSX +#else +import Utility.FreeDesktop +#ifdef linux_HOST_OS +import Utility.UserInfo +#endif +import Assistant.Install.Menu +#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 the + - git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh + - + - Note that this is done every time it's started, so if the user moves + - it around, the paths this sets up won't break. + - + - File manager hook script installation is done even for + - packaged apps, since it has to go into the user's home directory. + -} +ensureInstalled :: IO () +ensureInstalled = go =<< standaloneAppBase + where + go Nothing = installFileManagerHooks "git-annex" + 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 + + sshdir <- sshDir + let runshell var = "exec " ++ base "runshell " ++ var + let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\"" + + installWrapper (sshdir "git-annex-shell") $ unlines + [ shebang_local + , "set -e" + , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" + , rungitannexshell "$SSH_ORIGINAL_COMMAND" + , "else" + , rungitannexshell "$@" + , "fi" + ] + installWrapper (sshdir "git-annex-wrapper") $ unlines + [ shebang_local + , "set -e" + , runshell "\"$@\"" + ] + + installFileManagerHooks program + +installWrapper :: FilePath -> String -> IO () +installWrapper file content = do + curr <- catchDefaultIO "" $ readFileStrict file + when (curr /= content) $ do + createDirectoryIfMissing True (parentDir file) + viaTmp writeFile file content + modifyFileMode file $ addModes [ownerExecuteMode] + +installFileManagerHooks :: FilePath -> IO () +#ifdef linux_HOST_OS +installFileManagerHooks program = do + let actions = ["get", "drop", "undo"] + + -- Gnome + nautilusScriptdir <- (\d -> d "nautilus" "scripts") <$> userDataDir + createDirectoryIfMissing True nautilusScriptdir + forM_ actions $ + genNautilusScript nautilusScriptdir + + -- KDE + home <- myHomeDir + let kdeServiceMenusdir = home ".kde" "share" "kde4" "services" "ServiceMenus" + createDirectoryIfMissing True kdeServiceMenusdir + writeFile (kdeServiceMenusdir "git-annex.desktop") + (kdeDesktopFile actions) + where + genNautilusScript scriptdir action = + installscript (scriptdir scriptname action) $ unlines + [ shebang_local + , autoaddedcomment + , "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" + ] + scriptname action = "git-annex " ++ action + installscript f c = whenM (safetoinstallscript f) $ do + writeFile f c + modifyFileMode f $ addModes [ownerExecuteMode] + safetoinstallscript f = catchDefaultIO True $ + elem autoaddedcomment . lines <$> readFileStrict f + autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)" + autoaddedmsg = "Automatically added by git-annex, do not edit." + + kdeDesktopFile actions = unlines $ concat $ + kdeDesktopHeader actions : map kdeDesktopAction actions + kdeDesktopHeader actions = + [ "# " ++ autoaddedmsg + , "[Desktop Entry]" + , "Type=Service" + , "ServiceTypes=all/allfiles" + , "MimeType=all/all;" + , "Actions=" ++ intercalate ";" (map kdeDesktopSection actions) + , "X-KDE-Priority=TopLevel" + , "X-KDE-Submenu=Git-Annex" + , "X-KDE-Icon=git-annex" + , "X-KDE-ServiceTypes=KonqPopupMenu/Plugin" + ] + kdeDesktopSection command = "GitAnnex" ++ command + kdeDesktopAction command = + [ "" + , "[Desktop Action " ++ kdeDesktopSection command ++ "]" + , "Name=" ++ command + , "Icon=git-annex" + , unwords + [ "Exec=sh -c 'cd \"$(dirname '%U')\" &&" + , program + , command + , "--notify-start --notify-finish -- %U'" + ] + ] +#else +installFileManagerHooks _ = noop +#endif + +{- Returns a cleaned up environment that lacks settings used to make the + - standalone builds use their bundled libraries and programs. + - 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 environ + | null vars = Nothing + | otherwise = Just $ catMaybes $ map (restoreorig environ) environ + | otherwise = Nothing + where + vars = words $ fromMaybe "" $ + lookup "GIT_ANNEX_STANDLONE_ENV" environ + restoreorig oldenviron p@(k, _v) + | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of + (Just v') + | not (null v') -> Just (k, v') + _ -> Nothing + | otherwise = Just p diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs new file mode 100644 index 0000000000..b27b697750 --- /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..32393abafd --- /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 () +#ifdef darwin_HOST_OS +installMenu _command _menufile _iconsrcdir _icondir = return () +#else +installMenu command menufile iconsrcdir icondir = do + writeDesktopMenuFile (fdoDesktopMenu command) menufile + installIcon (iconsrcdir "logo.svg") $ + iconFilePath (iconBaseName ++ ".svg") "scalable" icondir + installIcon (iconsrcdir "logo_16x16.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..a5eace7240 --- /dev/null +++ b/Assistant/MakeRemote.hs @@ -0,0 +1,171 @@ +{- 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 Git.Types (RemoteName) +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 + (Nothing, Command.InitRemote.newConfig name) + go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing + (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 Nothing $ M.fromList + [ ("type", "gcrypt") + , ("gitrepo", location) + , configureEncryption HybridEncryption + , ("keyid", keyid) + ] + +type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> 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 mcreds 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 mcreds + (Nothing, Command.InitRemote.newConfig fullname) + Just _ -> go (n + 1) + +{- Enables an existing special remote. -} +enableSpecialRemote :: SpecialRemoteMaker +enableSpecialRemote name remotetype mcreds config = do + r <- Command.InitRemote.findExisting name + case r of + Nothing -> error $ "Cannot find a special remote named " ++ name + Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, c) + +setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName +setupSpecialRemote = setupSpecialRemote' True + +setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName +setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do + {- Currently, only 'weak' ciphers can be generated from the + - assistant, because otherwise GnuPG may block once the entropy + - pool is drained, and as of now there's no way to tell the user + - to perform IO actions to refill the pool. -} + (c', u) <- R.setup remotetype mu mcreds $ + M.insert "highRandomQuality" "false" $ M.union config c + configSet u c' + when setdesc $ + whenM (isNothing . M.lookup u <$> uuidMap) $ + describeUUID u name + return name + +{- Returns the name of the git remote it created. If there's already a + - 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..a34264a019 --- /dev/null +++ b/Assistant/Monad.hs @@ -0,0 +1,150 @@ +{- 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 +import Assistant.Types.RemoteControl +import Assistant.Types.CredPairCache + +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 + , remoteControl :: RemoteControl + , credPairCache :: CredPairCache + } + +newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData +newAssistantData st dstatus = AssistantData + <$> pure (ThreadName "main") + <*> pure st + <*> pure dstatus + <*> newScanRemoteMap + <*> newTransferQueue + <*> newTransferSlots + <*> newTransferrerPool (checkNetworkConnections dstatus) + <*> newFailedPushMap + <*> newCommitChan + <*> newChangePool + <*> newRepoProblemChan + <*> newBranchChangeHandle + <*> newBuddyList + <*> newNetMessager + <*> newRemoteControl + <*> newCredPairCache + +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 among 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..f809530534 --- /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) + { alertButtons = [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..dd18111415 --- /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..b24e5fdb61 --- /dev/null +++ b/Assistant/Pairing.hs @@ -0,0 +1,101 @@ +{- 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) + +checkSane :: PairData -> Bool +checkSane p = all (not . any isControl) + [ fromMaybe "" (remoteHostName p) + , remoteUserName p + , remoteDirectory p + , remoteSshPubKey p + , fromUUID (pairUUID p) + ] + +type UserName = String + +{- A pairing that is in progress has a secret, a thread that is + - 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..05533e2708 --- /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 qualified Types.Remote as Remote + +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 = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of + Left err -> error err + Right pubkey -> + unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $ + error "failed setting up ssh authorized keys" + +{- When local pairing is complete, this is used to set up the remote for + - the host we paired with. -} +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 (Remote.repo 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..7a4ac3ffe5 --- /dev/null +++ b/Assistant/Pairing/Network.hs @@ -0,0 +1,129 @@ +{- 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 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..7b4de450f8 --- /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/RemoteControl.hs b/Assistant/RemoteControl.hs new file mode 100644 index 0000000000..1016f1169b --- /dev/null +++ b/Assistant/RemoteControl.hs @@ -0,0 +1,21 @@ +{- git-annex assistant RemoteDaemon control + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.RemoteControl ( + sendRemoteControl, + RemoteDaemon.Consumed(..) +) where + +import Assistant.Common +import qualified RemoteDaemon.Types as RemoteDaemon + +import Control.Concurrent + +sendRemoteControl :: RemoteDaemon.Consumed -> Assistant () +sendRemoteControl msg = do + clicker <- getAssistant remoteControl + liftIO $ writeChan clicker msg diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs new file mode 100644 index 0000000000..72f601db75 --- /dev/null +++ b/Assistant/Repair.hs @@ -0,0 +1,159 @@ +{- 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, trackingOrSyncBranch) +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 $ clearFsckResults u + 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, modifiedbranches) <- inRepo $ + runRepairOf fsckresults trackingOrSyncBranch destructiverepair referencerepo + when destructiverepair $ + repairAnnexBranch 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). Also, a few lock-file-ish + - things used by git are not kept open, particularly MERGE_HEAD. + - + - So, 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 work to detect when 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 <- liftIO $ filter islock <$> findgitfiles r + repairStaleLocks lockfiles + return $ not $ null lockfiles + where + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir + islock f + | "gc.pid" `isInfixOf` f = False + | ".lock" `isSuffixOf` f = True + | takeFileName f == "MERGE_HEAD" = True + | otherwise = False + +repairStaleLocks :: [FilePath] -> Assistant () +repairStaleLocks lockfiles = go =<< getsizes + where + getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize 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..32595916ec --- /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/Restart.hs b/Assistant/Restart.hs new file mode 100644 index 0000000000..4120a46537 --- /dev/null +++ b/Assistant/Restart.hs @@ -0,0 +1,117 @@ +{- git-annex assistant restarting + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Restart where + +import Assistant.Common +import Assistant.Threads.Watcher +import Assistant.DaemonStatus +import Assistant.NamedThread +import Utility.ThreadScheduler +import Utility.NotificationBroadcaster +import Utility.Url +import Utility.PID +import qualified Git.Construct +import qualified Git.Config +import Config.Files +import qualified Annex +import qualified Git + +import Control.Concurrent +#ifndef mingw32_HOST_OS +import System.Posix (signalProcess, sigTERM) +#else +import Utility.WinProcess +#endif +import Network.URI + +{- Before the assistant can be restarted, have to remove our + - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also + - a good idea, to avoid fighting when two assistants are running in the + - same repo. + -} +prepRestart :: Assistant () +prepRestart = do + liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread + liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) + +{- To finish a restart, send a global redirect to the new url + - to any web browsers that are displaying the webapp. + - + - Wait for browser to update before terminating this process. -} +postRestart :: URLString -> Assistant () +postRestart url = do + modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } + liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus + void $ liftIO $ forkIO $ do + threadDelaySeconds (Seconds 120) + terminateSelf + +terminateSelf :: IO () +terminateSelf = +#ifndef mingw32_HOST_OS + signalProcess sigTERM =<< getPID +#else + terminatePID =<< getPID +#endif + +runRestart :: Assistant URLString +runRestart = liftIO . newAssistantUrl + =<< liftAnnex (Git.repoLocation <$> Annex.gitRepo) + +{- Starts up the assistant in the repository, and waits for it to create + - a gitAnnexUrlFile. Waits for the assistant to be up and listening for + - connections by testing the url. -} +newAssistantUrl :: FilePath -> IO URLString +newAssistantUrl repo = do + startAssistant repo + geturl + where + geturl = do + r <- Git.Config.read =<< Git.Construct.fromPath repo + waiturl $ gitAnnexUrlFile r + waiturl urlfile = do + v <- tryIO $ readFile urlfile + case v of + Left _ -> delayed $ waiturl urlfile + Right url -> ifM (assistantListening url) + ( return url + , delayed $ waiturl urlfile + ) + delayed a = do + threadDelay 100000 -- 1/10th of a second + a + +{- Checks if the assistant is listening on an url. + - + - Always checks http, because https with self-signed cert is problimatic. + - warp-tls listens to http, in order to show an error page, so this works. + -} +assistantListening :: URLString -> IO Bool +assistantListening url = catchBoolIO $ exists url' def + where + url' = case parseURI url of + Nothing -> url + Just uri -> show $ uri + { uriScheme = "http:" + } + +{- Does not wait for assistant to be listening for web connections. + - + - On windows, the assistant does not daemonize, which is why the forkIO is + - done. + -} +startAssistant :: FilePath -> IO () +startAssistant repo = void $ forkIO $ do + program <- readProgramFile + (_, _, _, pid) <- + createProcess $ + (proc program ["assistant"]) { cwd = Just repo } + void $ checkSuccessProcess pid diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs new file mode 100644 index 0000000000..0ce7a47ccf --- /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..88afec7138 --- /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.Shell +import Utility.Rsync +import Utility.FileMode +import Utility.SshConfig +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] + +{- 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. + - + - The returned version of the key has its comment removed. + -} +validateSshPubKey :: SshPubKey -> Either String SshPubKey +validateSshPubKey pubkey + | length (lines pubkey) == 1 = check $ words pubkey + | otherwise = Left "too many lines in ssh public key" + where + check (prefix:key:_) = checkprefix prefix (unwords [prefix, key]) + check _ = err "wrong number of words in ssh public key" + + err msg = Left $ unwords [msg, pubkey] + + checkprefix prefix validpubkey + | ssh == "ssh" && all isAlphaNum keytype = Right validpubkey + | otherwise = err "bad ssh public key prefix" + where + (ssh, keytype) = separate (== '-') prefix + +addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool +addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh" + [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ] + +{- Should only be used within the same process that added the line; + - the layout of the line is not kepy stable across versions. -} +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 + viaTmp writeSshConfig 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=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " + +{- Generates a ssh key pair. -} +genSshKeyPair :: IO SshKeyPair +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. + - + - Force strict host key checking to avoid repeated prompts + - when git-annex and git try to access the remote, if its + - host key has changed. + -} +setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData +setupSshKeyPair sshkeypair sshdata = do + sshdir <- sshDir + createDirectoryIfMissing True $ parentDir $ sshdir sshprivkeyfile + + unlessM (doesFileExist $ sshdir sshprivkeyfile) $ + writeFileProtected (sshdir sshprivkeyfile) (sshPrivKey sshkeypair) + unlessM (doesFileExist $ sshdir sshpubkeyfile) $ + writeFile (sshdir sshpubkeyfile) (sshPubKey sshkeypair) + + setSshConfig sshdata + [ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) + , ("IdentitiesOnly", "yes") + , ("StrictHostKeyChecking", "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. + - + - Strategy: Search for IdentityFile lines 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. + -} +fixSshKeyPairIdentitiesOnly :: IO () +fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines + 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" + +{- Add StrictHostKeyChecking to any ssh config stanzas that were written + - by git-annex. -} +fixUpSshRemotes :: IO () +fixUpSshRemotes = modifyUserSshConfig (map go) + where + go c@(HostConfig h _) + | "git-annex-" `isPrefixOf` h = fixupconfig c + | otherwise = c + go other = other + + fixupconfig c = case findHostConfigKey c "StrictHostKeyChecking" of + Nothing -> addToHostConfig c "StrictHostKeyChecking" "yes" + Just _ -> c + +{- 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) $ do + appendFile configfile $ unlines $ + [ "" + , "# Added automatically by git-annex" + , "Host " ++ mangledhost + ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) + (settings ++ config) + setSshConfigMode configfile + + 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-port_dir". + - The only use of "-" is to separate the parts shown; this is necessary + - to allow unMangleSshHostName to work. Any unusual characters in the + - username or directory are url encoded, except using "." rather than "%" + - (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 $ T.pack $ show $ sshPort 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..d914d2246c --- /dev/null +++ b/Assistant/Sync.hs @@ -0,0 +1,278 @@ +{- 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 Assistant.RemoteControl +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 Remote.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 + +{- Pushes the local sync branch to all remotes, in + - parallel, along with the git-annex branch. This is the same + - as "git annex sync", except in parallel, and will co-exist with use of + - "git annex sync". + - + - 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 + let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes + 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 Remote.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] + (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 . Remote.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 Remote.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 + sendRemoteControl RELOAD +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..8cf6da2d2c --- /dev/null +++ b/Assistant/Threads/Committer.hs @@ -0,0 +1,479 @@ +{- 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.LsFiles +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.Content +import Annex.Link +import Annex.CatFile +import qualified Annex +import Utility.InodeCache +import Annex.Content.Direct +import qualified Command.Sync +import qualified Git.Branch + +import Data.Time.Clock +import Data.Tuple.Utils +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 + havelsof <- liftIO $ inPath "lsof" + delayadd <- liftAnnex $ + maybe delayaddDefault (return . Just . Seconds) + =<< annexDelayAdd <$> Annex.getGitConfig + msg <- liftAnnex Command.Sync.commitMsg + waitChangeTime $ \(changes, time) -> do + readychanges <- handleAdds havelsof delayadd changes + if shouldCommit False time (length readychanges) readychanges + then do + debug + [ "committing" + , show (length readychanges) + , "changes" + ] + void $ alertWhile commitAlert $ + liftAnnex $ commitStaged msg + 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 + scanning <- not . scanComplete <$> getDaemonStatus + case (lastcommitsize >= maxCommitSize, shouldCommit scanning now len changes, possiblyrename changes) of + (True, True, _) + | len > maxCommitSize -> + a (changes, now) >>= waitchanges + | otherwise -> aftermaxcommit changes + (_, True, False) -> + a (changes, now) >>= waitchanges + (_, True, True) -> do + morechanges <- getrelatedchanges changes + a (changes ++ morechanges, now) >>= waitchanges + _ -> 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 :: Bool -> UTCTime -> Int -> [Change] -> Bool +shouldCommit scanning now len changes + | scanning = len >= maxCommitSize + | 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 :: String -> Annex Bool +commitStaged msg = do + {- This could fail if there's another commit being made by + - something else. -} + v <- tryNonAsync Annex.Queue.flush + case v of + Left _ -> return False + Right _ -> do + ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg + when ok $ + Command.Sync.updateSyncBranch =<< inRepo Git.Branch.current + return ok + +{- OSX needs a short delay after a file is added before locking it down, + - when using a non-direct mode repository, as pasting a file seems to + - 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 :: Bool -> Maybe Seconds -> [Change] -> Assistant [Change] +handleAdds havelsof 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 havelsof 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 havelsof 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 + delta <- liftAnnex getTSDelta + if M.null m + then forM toadd add + else forM toadd $ \c -> do + mcache <- liftIO $ genInodeCache (changeFile c) delta + 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 + ( calcRepo $ 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 :: Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] +safeToAdd _ _ [] [] = return [] +safeToAdd havelsof 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 <- if havelsof + then S.fromList . map fst3 . filter openwrite <$> + findopenfiles (map keySource inprocess') + else pure S.empty + 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 gitAnnexTmpMiscDir + 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 + void $ 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..7ab55fb82a --- /dev/null +++ b/Assistant/Threads/ConfigMonitor.hs @@ -0,0 +1,91 @@ +{- 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 Logs.NumCopies +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) + , (numcopiesLog, void $ liftAnnex globalNumCopiesLoad) + , (scheduleLog, void updateScheduleLog) + -- Preferred and required content settings depend on most of the + -- other configs, so will be reloaded whenever any configs change. + , (preferredContentLog, noop) + , (requiredContentLog, noop) + , (groupPreferredContentLog, noop) + ] + +reloadConfigs :: Configs -> Assistant () +reloadConfigs changedconfigs = do + sequence_ as + void $ liftAnnex preferredRequiredMapsLoad + {- Changes to the remote log, or the trust log, can affect the + - syncRemotes list. Changes to the uuid log may affect its + - display so are also included. -} + 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..451fa75c60 --- /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) = dispatch =<< liftAnnex (remoteFromUUID u) + where + dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] + dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of + Nothing -> go rmt $ do + program <- readProgramFile + void $ batchCommand program $ + [ 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..d5b2cc25d6 --- /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..900e0d4238 --- /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..f1a64925da --- /dev/null +++ b/Assistant/Threads/Merger.hs @@ -0,0 +1,119 @@ +{- 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 Annex.AutoMerge +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) True 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 = + whenM (liftAnnex $ inRepo $ Git.Branch.changed current changedbranch) $ do + debug + [ "merging", Git.fromRef changedbranch + , "into", Git.fromRef current + ] + void $ liftAnnex $ autoMergeFrom changedbranch (Just current) Git.Branch.AutomaticCommit + mergecurrent _ = noop + + handleDesynced = case fromTaggedBranch changedbranch of + 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 . Git.fromRef + +isAnnexBranch :: FilePath -> Bool +isAnnexBranch f = n `isSuffixOf` f + where + n = '/' : Git.fromRef 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..023af53cba --- /dev/null +++ b/Assistant/Threads/MountWatcher.hs @@ -0,0 +1,199 @@ +{- 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 -> +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher handleevent +#else + listen client matcher handleevent +#endif + , do + liftAnnex $ + warning "No known volume monitor available through dbus; falling back to mtab polling" + 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..ad3a87a911 --- /dev/null +++ b/Assistant/Threads/NetWatcher.hs @@ -0,0 +1,184 @@ +{- 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 +import Utility.NotificationBroadcaster + +#if WITH_DBUS +import Assistant.RemoteControl +import Utility.DBus +import DBus.Client +import DBus +import Assistant.NetMessager +#else +#ifdef linux_HOST_OS +#warning Building without dbus support; will poll for network connection changes +#endif +#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, or + - signal the RemoteControl, 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 + callback <- asIO1 connchange + liftIO $ do + listenNMConnections client callback + listenWicdConnections client callback + , do + liftAnnex $ + warning "No known network monitor available through dbus; falling back to polling" + ) + connchange False = do + debug ["detected network disconnection"] + sendRemoteControl LOSTNET + connchange True = do + debug ["detected network connection"] + notifyNetMessagerRestart + handleConnection + sendRemoteControl RESUME + onerr e _ = do + liftAnnex $ + warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" + {- 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 NetworkManager connections and diconnections. + - + - Connection example (once fully connected): + - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}] + - + - Disconnection example: + - [Variant {"ActiveConnections": Variant []}] + -} +listenNMConnections :: Client -> (Bool -> IO ()) -> IO () +listenNMConnections client setconnected = +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher +#else + listen client matcher +#endif + $ \event -> mapM_ handleevent + (map dictionaryItems $ mapMaybe fromVariant $ signalBody event) + where + matcher = matchAny + { matchInterface = Just "org.freedesktop.NetworkManager" + , matchMember = Just "PropertiesChanged" + } + nm_active_connections_key = toVariant ("ActiveConnections" :: String) + nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String) + noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath]) + rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/" + handleevent m + | lookup nm_active_connections_key m == noconnections = + setconnected False + | lookup nm_activatingconnection_key m == rootconnection = + setconnected True + | otherwise = noop + +{- Listens for Wicd connections and disconnections. + - + - Connection example: + - ConnectResultsSent: + - Variant "success" + - + - Diconnection example: + - StatusChanged + - [Variant 0, Variant [Varient ""]] + -} +listenWicdConnections :: Client -> (Bool -> IO ()) -> IO () +listenWicdConnections client setconnected = do + match connmatcher $ \event -> + when (any (== wicd_success) (signalBody event)) $ + setconnected True + match statusmatcher $ \event -> handleevent (signalBody event) + where + connmatcher = matchAny + { matchInterface = Just "org.wicd.daemon" + , matchMember = Just "ConnectResultsSent" + } + statusmatcher = matchAny + { matchInterface = Just "org.wicd.daemon" + , matchMember = Just "StatusChanged" + } + wicd_success = toVariant ("success" :: String) + wicd_disconnected = toVariant [toVariant ("" :: String)] + handleevent status + | any (== wicd_disconnected) status = setconnected False + | otherwise = noop + match matcher a = +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher a +#else + listen client matcher a +#endif +#endif + +handleConnection :: Assistant () +handleConnection = do + liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus + 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..e4f87494c8 --- /dev/null +++ b/Assistant/Threads/PairListener.hs @@ -0,0 +1,151 @@ +{- 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 Git + +import Network.Multicast +import Network.Socket +import qualified Data.Text as T + +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] + (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, checkSane (pairMsgData m), pairMsgStage m) of + (_, True, _, _) -> do + debug ["ignoring message that looped back"] + go reqs cache sock + (_, _, False, _) -> do + liftAnnex $ warning + "illegal control characters in pairing message; ignoring" + go reqs cache sock + -- PairReq starts a pairing process, so a + -- new one is always heeded, even if + -- some other pairing is in process. + (_, _, _, 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) + + {- 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..86ee027f7c --- /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..35989ed48a --- /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/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs new file mode 100644 index 0000000000..ae63aff5c0 --- /dev/null +++ b/Assistant/Threads/RemoteControl.hs @@ -0,0 +1,121 @@ +{- git-annex assistant communication with remotedaemon + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.RemoteControl where + +import Assistant.Common +import RemoteDaemon.Types +import Config.Files +import Utility.Batch +import Utility.SimpleProtocol +import Assistant.Alert +import Assistant.Alert.Utility +import Assistant.DaemonStatus +import qualified Git +import qualified Git.Types as Git +import qualified Remote +import qualified Types.Remote as Remote + +import Control.Concurrent +import Control.Concurrent.Async +import Network.URI +import qualified Data.Map as M +import qualified Data.Set as S + +remoteControlThread :: NamedThread +remoteControlThread = namedThread "RemoteControl" $ do + program <- liftIO readProgramFile + (cmd, params) <- liftIO $ toBatchCommand + (program, [Param "remotedaemon"]) + let p = proc cmd (toCommand params) + (Just toh, Just fromh, _, pid) <- liftIO $ createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + + urimap <- liftIO . newMVar =<< liftAnnex getURIMap + + controller <- asIO $ remoteControllerThread toh + responder <- asIO $ remoteResponderThread fromh urimap + + -- run controller and responder until the remotedaemon dies + liftIO $ void $ tryNonAsync $ controller `concurrently` responder + debug ["remotedaemon exited"] + liftIO $ forceSuccessProcess p pid + +-- feed from the remoteControl channel into the remotedaemon +remoteControllerThread :: Handle -> Assistant () +remoteControllerThread toh = do + clicker <- getAssistant remoteControl + forever $ do + msg <- liftIO $ readChan clicker + debug [show msg] + liftIO $ do + hPutStrLn toh $ unwords $ formatMessage msg + hFlush toh + +-- read status messages emitted by the remotedaemon and handle them +remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant () +remoteResponderThread fromh urimap = go M.empty + where + go syncalerts = do + l <- liftIO $ hGetLine fromh + debug [l] + case parseMessage l of + Just (CONNECTED uri) -> changeconnected S.insert uri + Just (DISCONNECTED uri) -> changeconnected S.delete uri + Just (SYNCING uri) -> withr uri $ \r -> + if M.member (Remote.uuid r) syncalerts + then go syncalerts + else do + i <- addAlert $ syncAlert [r] + go (M.insert (Remote.uuid r) i syncalerts) + Just (DONESYNCING uri status) -> withr uri $ \r -> + case M.lookup (Remote.uuid r) syncalerts of + Nothing -> cont + Just i -> do + let (succeeded, failed) = if status + then ([r], []) + else ([], [r]) + updateAlertMap $ mergeAlert i $ + syncResultAlert succeeded failed + go (M.delete (Remote.uuid r) syncalerts) + Just (WARNING (RemoteURI uri) msg) -> do + void $ addAlert $ + warningAlert ("RemoteControl "++ show uri) msg + cont + Nothing -> do + debug ["protocol error from remotedaemon: ", l] + cont + where + cont = go syncalerts + withr uri = withRemote uri urimap cont + changeconnected sm uri = withr uri $ \r -> do + changeCurrentlyConnected $ sm $ Remote.uuid r + cont + +getURIMap :: Annex (M.Map URI Remote) +getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo) + where + mkk (Git.Url u) = Just u + mkk _ = Nothing + +withRemote + :: RemoteURI + -> MVar (M.Map URI Remote) + -> Assistant a + -> (Remote -> Assistant a) + -> Assistant a +withRemote (RemoteURI uri) remotemap noremote a = do + m <- liftIO $ readMVar remotemap + case M.lookup uri m of + Just r -> a r + Nothing -> do + {- Reload map, in case a new remote has been added. -} + m' <- liftAnnex getURIMap + void $ liftIO $ swapMVar remotemap $ m' + maybe noremote a (M.lookup uri m') diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs new file mode 100644 index 0000000000..3073cfe41f --- /dev/null +++ b/Assistant/Threads/SanityChecker.hs @@ -0,0 +1,327 @@ +{- git-annex assistant sanity checker + - + - Copyright 2012, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Threads.SanityChecker ( + sanityCheckerStartupThread, + sanityCheckerDailyThread, + sanityCheckerHourlyThread +) where + +import Assistant.Common +import Assistant.DaemonStatus +import Assistant.Alert +import Assistant.Repair +import Assistant.Drop +import Assistant.Ssh +import Assistant.TransferQueue +import Assistant.Types.UrlRenderer +import Assistant.Restart +import qualified Annex.Branch +import qualified Git +import qualified Git.LsFiles +import qualified Git.Command.Batch +import qualified Git.Config +import Utility.ThreadScheduler +import qualified Assistant.Threads.Watcher as Watcher +import Utility.Batch +import Utility.NotificationBroadcaster +import Config +import Utility.HumanTime +import Utility.Tense +import Git.Repair +import Git.Index +import Assistant.Unused +import Logs.Unused +import Logs.Transfer +import Config.Files +import Types.Key (keyBackendName) +import qualified Annex +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +#endif +#ifndef mingw32_HOST_OS +import Utility.LogFile +import Utility.DiskFree +#endif + +import Data.Time.Clock.POSIX +import qualified Data.Text as T + +{- 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 + + {- A corrupt index file can prevent the assistant from working at + - all, so detect and repair. -} + ifM (not <$> liftAnnex (inRepo checkIndexFast)) + ( do + notice ["corrupt index file found at startup; removing and restaging"] + liftAnnex $ inRepo $ nukeFile . indexFile + {- Normally the startup scan avoids re-staging files, + - but with the index deleted, everything needs to be + - restaged. -} + modifyDaemonStatus_ $ \s -> s { forceRestage = True } + , whenM (liftAnnex $ inRepo missingIndex) $ do + debug ["no index file; restaging"] + modifyDaemonStatus_ $ \s -> s { forceRestage = True } + ) + {- If the git-annex index file is corrupt, it's ok to remove it; + - the data from the git-annex branch will be used, and the index + - will be automatically regenerated. -} + unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do + notice ["corrupt annex/index file found at startup; removing"] + liftAnnex $ liftIO . nukeFile =<< fromRepo gitAnnexIndex + + {- Fix up ssh remotes set up by past versions of the assistant. -} + liftIO $ fixUpSshRemotes + + {- Clean up old temp files. -} + void $ liftAnnex $ tryNonAsync $ do + cleanOldTmpMisc + cleanReallyOldTmp + + {- If there's a startup delay, it's done here. -} + liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay + + {- 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 :: UrlRenderer -> NamedThread +sanityCheckerDailyThread urlrenderer = 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 urlrenderer + + 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 :: UrlRenderer -> Assistant Bool +dailyCheck urlrenderer = do + checkRepoExists + + g <- liftAnnex gitRepo + batchmaker <- liftIO getBatchCommandMaker + + -- 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.Batch.run batchmaker + [ Param "-c", Param "gc.auto=670000" + , Param "gc" + , Param "--auto" + ] g + + {- Check if the unused files found last time have been dealt with. -} + checkOldUnused urlrenderer + + {- Run git-annex unused once per day. This is run as a separate + - process to stay out of the annex monad and so it can run as a + - batch job. -} + program <- liftIO readProgramFile + let (program', params') = batchmaker (program, [Param "unused"]) + void $ liftIO $ boolSystem program' params' + {- Invalidate unused keys cache, and queue transfers of all unused + - keys, or if no transfers are called for, drop them. -} + unused <- liftAnnex unusedKeys' + void $ liftAnnex $ setUnusedKeys unused + forM_ unused $ \k -> do + unlessM (queueTransfers "unused" Later k Nothing Upload) $ + handleDrops "unused" True k Nothing Nothing + + 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 = do + checkRepoExists +#ifndef mingw32_HOST_OS + checkLogSize 0 +#else + noop +#endif + +#ifndef mingw32_HOST_OS +{- Rotate logs once when total log file size is > 2 mb. + - + - If total log size is larger than the amount of free disk space, + - continue rotating logs until size is < 2 mb, even if this + - results in immediately losing the just logged data. + -} +checkLogSize :: Int -> Assistant () +checkLogSize n = do + f <- liftAnnex $ fromRepo gitAnnexLogFile + logs <- liftIO $ listLogs f + totalsize <- liftIO $ sum <$> mapM getFileSize logs + when (totalsize > 2 * oneMegabyte) $ do + notice ["Rotated logs due to size:", show totalsize] + liftIO $ openLog f >>= handleToFd >>= redirLog + when (n < maxLogs + 1) $ do + df <- liftIO $ getDiskFree $ takeDirectory f + case df of + Just free + | free < fromIntegral totalsize -> + checkLogSize (n + 1) + _ -> noop + where + oneMegabyte :: Integer + oneMegabyte = 1000000 +#endif + +oneHour :: Int +oneHour = 60 * 60 + +oneDay :: Int +oneDay = 24 * oneHour + +{- If annex.expireunused is set, find any keys that have lingered unused + - for the specified duration, and remove them. + - + - Otherwise, check to see if unused keys are piling up, and let the user + - know. -} +checkOldUnused :: UrlRenderer -> Assistant () +checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig + where + go (Just Nothing) = noop + go (Just (Just expireunused)) = expireUnused (Just expireunused) + go Nothing = maybe noop prompt =<< describeUnusedWhenBig + + prompt msg = +#ifdef WITH_WEBAPP + do + button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR + void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg +#else + debug [show $ renderTense Past msg] +#endif + +{- Files may be left in misctmp by eg, an interrupted add of files + - by the assistant, which hard links files to there as part of lockdown + - checks. Delete these files if they're more than a day old. + - + - Note that this is not safe to run after the Watcher starts up, since it + - will create such files, and due to hard linking they may have old + - mtimes. So, this should only be called from the + - sanityCheckerStartupThread, which runs before the Watcher starts up. + - + - Also, if a git-annex add is being run at the same time the assistant + - starts up, its tmp files could be deleted. However, the watcher will + - come along and add everything once it starts up anyway, so at worst + - this would make the git-annex add fail unexpectedly. + -} +cleanOldTmpMisc :: Annex () +cleanOldTmpMisc = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24) + tmp <- fromRepo gitAnnexTmpMiscDir + liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp + +{- While .git/annex/tmp is now only used for storing partially transferred + - objects, older versions of git-annex used it for misctemp. Clean up any + - files that might be left from that, by looking for files whose names + - cannot be the key of an annexed object. Only delete files older than + - 1 week old. + - + - Also, some remotes such as rsync may use this temp directory for storing + - eg, encrypted objects that are being transferred. So, delete old + - objects that use a GPGHMAC backend. + -} +cleanReallyOldTmp :: Annex () +cleanReallyOldTmp = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24 * 7) + tmp <- fromRepo gitAnnexTmpObjectDir + liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp + where + cleanjunk check f = case fileKey (takeFileName f) of + Nothing -> cleanOld check f + Just k + | "GPGHMAC" `isPrefixOf` keyBackendName k -> + cleanOld check f + | otherwise -> noop + +cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO () +cleanOld check f = go =<< catchMaybeIO getmtime + where + getmtime = realToFrac . modificationTime <$> getSymbolicLinkStatus f + go (Just mtime) | check mtime = nukeFile f + go _ = noop + +checkRepoExists :: Assistant () +checkRepoExists = do + g <- liftAnnex gitRepo + liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $ + terminateSelf diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs new file mode 100644 index 0000000000..73562dbf7e --- /dev/null +++ b/Assistant/Threads/TransferPoller.hs @@ -0,0 +1,55 @@ +{- 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 = gitAnnexTmpObjectLocation (transferKey t) g + sz <- liftIO $ catchMaybeIO $ getFileSize f + newsize t info sz + {- Uploads don't need to be polled for when the TransferWatcher + - thread can track file modifications. -} + | 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..3cbaadf19f --- /dev/null +++ b/Assistant/Threads/TransferScanner.hs @@ -0,0 +1,182 @@ +{- 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 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 CmdLine.Action + +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 = 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 + 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 + liftAnnex $ handleDropsFrom locs syncrs + "expensive scan found too many copies of object" + present key (Just f) Nothing callCommandAction + liftAnnex $ do + let slocs = S.fromList locs + let use a = return $ mapMaybe (a key slocs) syncrs + ts <- if present + then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst) + =<< use (genTransfer Upload False) + else ifM (wantGet True (Just key) (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..c452d87c24 --- /dev/null +++ b/Assistant/Threads/TransferWatcher.hs @@ -0,0 +1,104 @@ +{- 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 +import qualified Data.Map as M + +{- 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) True 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 + + -- Run transfer hook. + m <- transferHook <$> getDaemonStatus + maybe noop (\hook -> void $ liftIO $ forkIO $ hook t) + (M.lookup (transferKey t) m) + + 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..073dbef3c0 --- /dev/null +++ b/Assistant/Threads/Transferrer.hs @@ -0,0 +1,27 @@ +{- 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 +import Utility.Batch + +{- Dispatches transfers from the queue. -} +transfererThread :: NamedThread +transfererThread = namedThread "Transferrer" $ do + program <- liftIO readProgramFile + batchmaker <- liftIO getBatchCommandMaker + forever $ inTransferSlot program batchmaker $ + maybe (return Nothing) (uncurry genTransfer) + =<< getNextTransfer notrunning + where + {- Skip transfers that are already running. -} + notrunning = isNothing . startedTime diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs new file mode 100644 index 0000000000..e779c8e54d --- /dev/null +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -0,0 +1,110 @@ +{- git-annex assistant thread to detect when git-annex is upgraded + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Threads.UpgradeWatcher ( + upgradeWatcherThread +) where + +import Assistant.Common +import Assistant.Upgrade +import Utility.DirWatcher +import Utility.DirWatcher.Types +import Utility.ThreadScheduler +import Assistant.Types.UrlRenderer +import Assistant.Alert +import Assistant.DaemonStatus +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import qualified Build.SysConfig +#endif + +import Control.Concurrent.MVar +import qualified Data.Text as T + +data WatcherState = InStartupScan | Started | Upgrading + deriving (Eq) + +upgradeWatcherThread :: UrlRenderer -> NamedThread +upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do + whenM (liftIO checkSuccessfulUpgrade) $ + showSuccessfulUpgrade urlrenderer + go =<< liftIO upgradeFlagFile + where + go Nothing = debug [ "cannot determine program path" ] + go (Just flagfile) = do + mvar <- liftIO $ newMVar InStartupScan + changed <- Just <$> asIO2 (changedFile urlrenderer mvar flagfile) + let hooks = mkWatchHooks + { addHook = changed + , delHook = changed + , addSymlinkHook = changed + , modifyHook = changed + , delDirHook = changed + } + let dir = parentDir flagfile + let depth = length (splitPath dir) + 1 + let nosubdirs f = length (splitPath f) == depth + void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) + -- Ignore bogus events generated during the startup scan. + -- We ask the watcher to not generate them, but just to be safe.. + startup mvar scanner = do + r <- scanner + void $ swapMVar mvar Started + return r + +changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant () +changedFile urlrenderer mvar flagfile file _status + | flagfile /= file = noop + | otherwise = do + state <- liftIO $ readMVar mvar + when (state == Started) $ do + setstate Upgrading + ifM (liftIO upgradeSanityCheck) + ( handleUpgrade urlrenderer + , do + debug ["new version failed sanity check; not using"] + setstate Started + ) + where + setstate = void . liftIO . swapMVar mvar + +handleUpgrade :: UrlRenderer -> Assistant () +handleUpgrade urlrenderer = do + -- Wait 2 minutes for any final upgrade changes to settle. + -- (For example, other associated files may be being put into + -- place.) Not needed when using a distribution bundle, because + -- in that case git-annex handles the upgrade in a non-racy way. + liftIO $ unlessM usingDistribution $ + threadDelaySeconds (Seconds 120) + ifM autoUpgradeEnabled + ( do + debug ["starting automatic upgrade"] + unattendedUpgrade +#ifdef WITH_WEBAPP + , do + button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR + void $ addAlert $ upgradeReadyAlert button +#else + , noop +#endif + ) + +showSuccessfulUpgrade :: UrlRenderer -> Assistant () +showSuccessfulUpgrade urlrenderer = do +#ifdef WITH_WEBAPP + button <- ifM autoUpgradeEnabled + ( pure Nothing + , Just <$> mkAlertButton True + (T.pack "Enable Automatic Upgrades") + urlrenderer ConfigEnableAutomaticUpgradeR + ) + void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion +#else + noop +#endif diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs new file mode 100644 index 0000000000..602d092082 --- /dev/null +++ b/Assistant/Threads/Upgrader.hs @@ -0,0 +1,85 @@ +{- git-annex assistant thread to detect when upgrade is available + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Threads.Upgrader ( + upgraderThread +) where + +import Assistant.Common +import Assistant.Upgrade + +import Assistant.Types.UrlRenderer +import Assistant.DaemonStatus +import Assistant.Alert +import Utility.NotificationBroadcaster +import qualified Annex +import qualified Build.SysConfig +import qualified Git.Version +import Types.Distribution +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +#endif + +import Data.Time.Clock +import qualified Data.Text as T + +upgraderThread :: UrlRenderer -> NamedThread +upgraderThread urlrenderer = namedThread "Upgrader" $ + when (isJust Build.SysConfig.upgradelocation) $ do + {- Check for upgrade on startup, unless it was just + - upgraded. -} + unlessM (liftIO checkSuccessfulUpgrade) $ + checkUpgrade urlrenderer + h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus + go h =<< liftIO getCurrentTime + where + {- Wait for a network connection event. Then see if it's been + - half a day since the last upgrade check. If so, proceed with + - check. -} + go h lastchecked = do + liftIO $ waitNotification h + autoupgrade <- liftAnnex $ annexAutoUpgrade <$> Annex.getGitConfig + if autoupgrade == NoAutoUpgrade + then go h lastchecked + else do + now <- liftIO getCurrentTime + if diffUTCTime now lastchecked > halfday + then do + checkUpgrade urlrenderer + go h =<< liftIO getCurrentTime + else go h lastchecked + halfday = 12 * 60 * 60 + +checkUpgrade :: UrlRenderer -> Assistant () +checkUpgrade urlrenderer = do + debug [ "Checking if an upgrade is available." ] + go =<< downloadDistributionInfo + where + go Nothing = debug [ "Failed to check if upgrade is available." ] + go (Just d) = do + let installed = Git.Version.normalize Build.SysConfig.packageversion + let avail = Git.Version.normalize $ distributionVersion d + let old = Git.Version.normalize <$> distributionUrgentUpgrade d + if Just installed <= old + then canUpgrade High urlrenderer d + else if installed < avail + then canUpgrade Low urlrenderer d + else debug [ "No new version found." ] + +canUpgrade :: AlertPriority -> UrlRenderer -> GitAnnexDistribution -> Assistant () +canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled + ( startDistributionDownload d + , do +#ifdef WITH_WEBAPP + button <- mkAlertButton True (T.pack "Upgrade") urlrenderer (ConfigStartUpgradeR d) + void $ addAlert (canUpgradeAlert urgency (distributionVersion d) button) +#else + noop +#endif + ) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs new file mode 100644 index 0000000000..6f3afa8cac --- /dev/null +++ b/Assistant/Threads/Watcher.hs @@ -0,0 +1,368 @@ +{- 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 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 Types.FileMatcher +import Annex.ReplaceFile +import Git.Types +import Config +import Utility.ThreadScheduler +#ifndef mingw32_HOST_OS +import qualified Utility.Lsof as Lsof +#endif + +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 +#ifndef mingw32_HOST_OS + liftIO Lsof.setup + unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) + needLsof +#else + noop +#endif + | 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 + } + scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig + h <- liftIO $ watchDir "." ignored scanevents hooks startup + debug [ "watching", "."] + + {- Let the DirWatcher thread run until signalled to pause it, + - then wait for a resume signal, and restart. -} + waitFor PauseWatcher $ do + liftIO $ stopWatchDir h + 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 } + + -- Ensure that the Committer sees any changes + -- that it did not process, and acts on them now that + -- the scan is complete. + refillChanges =<< getAnyChanges + + 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 $ warningIO $ show 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 Annex -> 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 Annex -> Handler +onAdd matcher file filestatus + | maybe False isRegularFile filestatus = + unlessIgnored file $ + add matcher file + | otherwise = noChange + +shouldRestage :: DaemonStatus -> Bool +shouldRestage ds = scanComplete ds || forceRestage ds + +{- In direct mode, add events are received for both new files, and + - modified existing files. + -} +onAddDirect :: Bool -> FileMatcher Annex -> Handler +onAddDirect symlinkssupported matcher file fs = do + v <- liftAnnex $ catKeyFile file + case (v, fs) of + (Just key, Just filestatus) -> + ifM (liftAnnex $ sameFileStatus key file 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 (shouldRestage <$> getDaemonStatus) + ( do + link <- liftAnnex $ calcRepo $ 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 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 $ calcRepo $ 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 + | shouldRestage 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..fd78ba8d8d --- /dev/null +++ b/Assistant/Threads/WebApp.hs @@ -0,0 +1,146 @@ +{- git-annex assistant webapp thread + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns, OverloadedStrings #-} +{-# 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.Unused +import Assistant.WebApp.Configurators.Edit +import Assistant.WebApp.Configurators.Delete +import Assistant.WebApp.Configurators.Fsck +import Assistant.WebApp.Configurators.Upgrade +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 qualified Annex + +import Yesod +import Network.Socket (SockAddr, HostName) +import Data.Text (pack, unpack) +import qualified Network.Wai.Handler.WarpTLS as TLS +import Network.Wai.Middleware.RequestLogger +import System.Log.Logger + +mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") + +type Url = String + +webAppThread + :: AssistantData + -> UrlRenderer + -> Bool + -> Maybe String + -> Maybe (IO Url) + -> Maybe HostName + -> Maybe (Url -> FilePath -> IO ()) + -> NamedThread +webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost onstartup = thread $ liftIO $ do + listenhost' <- if isJust listenhost + then pure listenhost + else getAnnex $ annexListen <$> Annex.getGitConfig + tlssettings <- getAnnex getTlsSettings +#ifdef __ANDROID__ + when (isJust listenhost') $ + -- See Utility.WebApp + error "Sorry, --listen is not currently supported on Android" +#endif + webapp <- WebApp + <$> pure assistantdata + <*> genAuthToken + <*> getreldir + <*> pure staticRoutes + <*> pure postfirstrun + <*> pure cannotrun + <*> pure noannex + <*> pure listenhost' + setUrlRenderer urlrenderer $ yesodRender webapp (pack "") + app <- toWaiAppPlain webapp + app' <- ifM debugEnabled + ( return $ logStdout app + , return app + ) + runWebApp tlssettings listenhost' app' $ \addr -> if noannex + then withTmpFile "webapp.html" $ \tmpfile h -> do + hClose h + go tlssettings addr webapp tmpfile Nothing + else do + htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim + urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile + go tlssettings 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 + =<< getAnnex' (fromRepo repoPath)) + go tlssettings addr webapp htmlshim urlfile = do + let url = myUrl tlssettings webapp addr + maybe noop (`writeFileProtected` url) urlfile + writeHtmlShim "Starting webapp..." url htmlshim + maybe noop (\a -> a url htmlshim) onstartup + + getAnnex a + | noannex = pure Nothing + | otherwise = getAnnex' a + getAnnex' = runThreadState (threadState assistantdata) + +myUrl :: Maybe TLS.TLSSettings -> WebApp -> SockAddr -> Url +myUrl tlssettings webapp addr = unpack $ yesodRender webapp urlbase DashboardR [] + where + urlbase = pack $ proto ++ "://" ++ show addr + proto + | isJust tlssettings = "https" + | otherwise = "http" + +getTlsSettings :: Annex (Maybe TLS.TLSSettings) +getTlsSettings = do +#ifdef WITH_WEBAPP_SECURE + cert <- fromRepo gitAnnexWebCertificate + privkey <- fromRepo gitAnnexWebPrivKey + ifM (liftIO $ allM doesFileExist [cert, privkey]) + ( return $ Just $ TLS.tlsSettings cert privkey + , return Nothing + ) +#else + return Nothing +#endif + +{- Checks if debugging is actually enabled. -} +debugEnabled :: IO Bool +debugEnabled = do + l <- getRootLogger + return $ getLevel l <= Just DEBUG diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs new file mode 100644 index 0000000000..78d527920d --- /dev/null +++ b/Assistant/Threads/XMPPClient.hs @@ -0,0 +1,375 @@ +{- 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 -> UUID -> IO ()) -> Assistant () +restartableClient a = forever $ go =<< liftAnnex getXMPPCreds + where + go Nothing = waitNetMessagerRestart + go (Just creds) = do + xmppuuid <- maybe NoUUID Remote.uuid . headMaybe + . filter Remote.isXMPPRemote . syncRemotes + <$> getDaemonStatus + tid <- liftIO $ forkIO $ a creds xmppuuid + waitNetMessagerRestart + liftIO $ killThread tid + +xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO () +xmppClient urlrenderer d creds xmppuuid = + 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 $ do + modifyDaemonStatus_ $ \s -> s + { xmppClientID = Nothing } + changeCurrentlyConnected $ S.delete xmppuuid + + 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 } + changeCurrentlyConnected $ S.insert xmppuuid + 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_ (handlemsg 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 + + handlemsg selfjid (PresenceMessage p) = do + void $ inAssistant $ + updateBuddyList (updateBuddies p) <<~ buddyList + resendImportantMessages selfjid p + handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature + handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us + handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) = + maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) + handlemsg _ (GotNetMessage m@(Pushing _ pushstage)) + | isPushNotice pushstage = inAssistant $ handlePushNotice m + | isPushInitiation pushstage = inAssistant $ queuePushInitiation m + | otherwise = inAssistant $ storeInbox m + handlemsg _ (Ignorable _) = noop + handlemsg _ (Unknown _) = noop + handlemsg _ (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 Remote.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..ec11b9b944 --- /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..ba13b3f048 --- /dev/null +++ b/Assistant/TransferQueue.hs @@ -0,0 +1,233 @@ +{- git-annex assistant pending transfer queue + - + - Copyright 2012-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +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 Bool +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 Bool +queueTransfersMatching matching reason schedule k f direction + | direction == Download = ifM (liftAnnex $ wantGet True (Just k) f) + ( go + , return False + ) + | otherwise = go + where + go = do + + rs <- liftAnnex . selectremotes + =<< syncDataRemotes <$> getDaemonStatus + let matchingrs = filter (matching . Remote.uuid) rs + if null matchingrs + then do + defer + return False + else do + forM_ matchingrs $ \r -> + enqueue reason schedule (gentransfer r) (stubInfo f r) + return True + 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 (Just k) 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) + let !len = length ts + void $ writeTVar (queuesize q) len + setTList (queuelist q) ts + return removed diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs new file mode 100644 index 0000000000..bbc2ec7e52 --- /dev/null +++ b/Assistant/TransferSlots.hs @@ -0,0 +1,293 @@ +{- git-annex assistant transfer slots + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +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 Utility.Batch + +import qualified Data.Map as M +import qualified Control.Exception as E +import Control.Concurrent +import qualified Control.Concurrent.MSemN as MSemN +#ifndef mingw32_HOST_OS +import System.Posix.Process (getProcessGroupIDOf) +import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +#else +import Utility.WinProcess +#endif + +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 -> BatchCommandMaker -> TransferGenerator -> Assistant () +inTransferSlot program batchmaker gen = do + flip MSemN.wait 1 <<~ transferSlots + runTransferThread program batchmaker =<< gen + +{- Runs a TransferGenerator, and its transfer action, + - without waiting for a slot to become available. -} +inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant () +inImmediateTransferSlot program batchmaker gen = do + flip MSemN.signal (-1) <<~ transferSlots + runTransferThread program batchmaker =<< 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 -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant () +runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots +runTransferThread program batchmaker (Just (t, info, a)) = do + d <- getAssistant id + aio <- asIO1 a + tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio + updateTransferInfo t $ info { transferTid = Just tid } + +runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO () +runTransferThread' program batchmaker d run = go + where + go = catchPauseResume $ + withTransferrer program batchmaker (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 of + Just remote + | 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) + , 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 transferrer = ifM (liftIO $ performTransfer transferrer t info) + ( do + maybe noop + (void . addAlert . makeAlertFiller True + . transferFileAlert direction True) + (associatedFile info) + 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 (Just key) file + | transferDirection t == Upload = case transferRemote info of + Nothing -> return False + Just r -> notinremote r + <&&> wantSend True (Just key) 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 + void $ 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 + killproc pid = void $ tryIO $ do +#ifndef mingw32_HOST_OS + {- In order to stop helper processes like rsync, + - kill the whole process group of the process + - running the transfer. -} + g <- getProcessGroupIDOf pid + let signal sig = void $ tryIO $ signalProcessGroup sig g + signal sigTERM + threadDelay 50000 -- 0.05 second grace period + signal sigKILL +#else + terminatePID pid +#endif + +{- 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 + batchmaker <- liftIO getBatchCommandMaker + inImmediateTransferSlot program batchmaker $ + 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..152625f4f1 --- /dev/null +++ b/Assistant/TransferrerPool.hs @@ -0,0 +1,96 @@ +{- 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 Utility.Batch + +import qualified Command.TransferKeys as T + +import Control.Concurrent.STM hiding (check) +import Control.Exception (throw) +import Control.Concurrent + +{- Runs an action with a Transferrer from the pool. + - + - Only one Transferrer is left running in the pool at a time. + - So if this needed to start a new Transferrer, it's stopped when done. + -} +withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a +withTransferrer program batchmaker pool a = do + (mi, leftinpool) <- atomically (popTransferrerPool pool) + i@(TransferrerPoolItem (Just t) check) <- case mi of + Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker + Just i -> checkTransferrerPoolItem program batchmaker i + v <- tryNonAsync $ a t + if leftinpool == 0 + then atomically $ pushTransferrerPool pool i + else do + void $ forkIO $ stopTransferrer t + atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check + either throw return v + +{- Check if a Transferrer from the pool is still ok to be used. + - If not, stop it and start a new one. -} +checkTransferrerPoolItem :: FilePath -> BatchCommandMaker -> TransferrerPoolItem -> IO TransferrerPoolItem +checkTransferrerPoolItem program batchmaker i = case i of + TransferrerPoolItem (Just t) check -> ifM check + ( return i + , do + stopTransferrer t + new check + ) + TransferrerPoolItem Nothing check -> new check + where + new check = do + t <- mkTransferrer program batchmaker + return $ TransferrerPoolItem (Just t) check + +{- Requests that a Transferrer perform a Transfer, and waits for it to + - finish. -} +performTransfer :: Transferrer -> Transfer -> TransferInfo -> IO Bool +performTransfer transferrer t info = catchBoolIO $ do + T.sendRequest t info (transferrerWrite transferrer) + T.readResponse (transferrerRead transferrer) + +{- Starts a new git-annex transferkeys process, setting up handles + - that will be used to communicate with it. -} +mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer +mkTransferrer program batchmaker = do + {- It runs as a batch job. -} + let (program', params') = batchmaker (program, [Param "transferkeys"]) + {- It's put into its own group so that the whole group can be + - killed to stop a transfer. -} + (Just writeh, Just readh, _, pid) <- createProcess + (proc program' $ toCommand params') + { create_group = True + , std_in = CreatePipe + , std_out = CreatePipe + } + fileEncoding readh + fileEncoding writeh + return $ Transferrer + { transferrerRead = readh + , transferrerWrite = writeh + , transferrerHandle = pid + } + +{- Checks if a Transferrer is still running. If not, makes a new one. -} +checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer +checkTransferrer program batchmaker t = + maybe (return t) (const $ mkTransferrer program batchmaker) + =<< 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..a2e5d5c822 --- /dev/null +++ b/Assistant/Types/Alert.hs @@ -0,0 +1,79 @@ +{- 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 + | ConnectionNeededAlert + | RemoteRemovalAlert String + | CloudRepoNeededAlert + | SyncAlert + | NotFsckedAlert + | UpgradeAlert + | UnusedFilesAlert + 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 + , alertButtons :: [AlertButton] + } + +data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | ConnectionIcon + +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 ()) + , buttonPrimary :: Bool + } diff --git a/Assistant/Types/BranchChange.hs b/Assistant/Types/BranchChange.hs new file mode 100644 index 0000000000..f769657d01 --- /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..2887aaef09 --- /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..1d8b517754 --- /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..bf83fc486e --- /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/CredPairCache.hs b/Assistant/Types/CredPairCache.hs new file mode 100644 index 0000000000..9777e29ee0 --- /dev/null +++ b/Assistant/Types/CredPairCache.hs @@ -0,0 +1,18 @@ +{- git-annex assistant CredPair cache. + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.CredPairCache where + +import Types.Creds + +import Control.Concurrent +import qualified Data.Map as M + +type CredPairCache = MVar (M.Map Login Password) + +newCredPairCache :: IO CredPairCache +newCredPairCache = newMVar M.empty diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs new file mode 100644 index 0000000000..e1b6c997e1 --- /dev/null +++ b/Assistant/Types/DaemonStatus.hs @@ -0,0 +1,122 @@ +{- 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 Utility.Url + +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 + -- True when all files should be restaged. + , forceRestage :: 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 + -- Set of uuids of remotes that are currently connected. + , currentlyConnectedRemotes :: S.Set UUID + -- List of uuids of remotes that we may have gotten out of sync with. + , desynced :: S.Set UUID + -- Pairing request that is in progress. + , 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 + -- Broadcasts notifications when the network is connected. + , networkConnectedNotifier :: NotificationBroadcaster + -- Broadcasts notifications when a global redirect is needed. + , globalRedirNotifier :: NotificationBroadcaster + , globalRedirUrl :: Maybe URLString + -- Actions to run after a Key is transferred. + , transferHook :: M.Map Key (Transfer -> IO ()) + -- 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 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 S.empty + <*> pure Nothing + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> newNotificationBroadcaster + <*> pure Nothing + <*> pure M.empty + <*> pure Nothing + <*> pure M.empty diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs new file mode 100644 index 0000000000..b07b322ad9 --- /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..475d810ae4 --- /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.Text.Encoding as T +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.DList as D +import Control.Concurrent.STM +import Control.Concurrent.MSampleVar +import Data.ByteString (ByteString) +import 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 (Eq, Ord, Show) + +{- 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 (Eq, Ord, Show) + +{- 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 = T.encodeUtf8 $ T.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..0da8b44b57 --- /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/RemoteControl.hs b/Assistant/Types/RemoteControl.hs new file mode 100644 index 0000000000..42cb4a5aa4 --- /dev/null +++ b/Assistant/Types/RemoteControl.hs @@ -0,0 +1,16 @@ +{- git-annex assistant RemoteDaemon control + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.RemoteControl where + +import qualified RemoteDaemon.Types as RemoteDaemon +import Control.Concurrent + +type RemoteControl = Chan RemoteDaemon.Consumed + +newRemoteControl :: IO RemoteControl +newRemoteControl = newChan diff --git a/Assistant/Types/RepoProblem.hs b/Assistant/Types/RepoProblem.hs new file mode 100644 index 0000000000..3b9c72cf81 --- /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..ac6d8fef9c --- /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..57c704dad5 --- /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..eadf325ea1 --- /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..73a7521c59 --- /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..5fa1219a7f --- /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..697bb8dd5f --- /dev/null +++ b/Assistant/Types/TransferrerPool.hs @@ -0,0 +1,67 @@ +{- A pool of "git-annex transferkeys" processes available for use + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.TransferrerPool where + +import Common.Annex +import Utility.NotificationBroadcaster +import Assistant.Types.DaemonStatus + +import Control.Concurrent.STM hiding (check) + +{- This TMVar is never left empty. -} +type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem]) + +type CheckTransferrer = IO Bool +type MkCheckTransferrer = IO (IO Bool) + +{- Each item in the pool may have a transferrer running, and has an + - IO action that can be used to check if it's still ok to use the + - transferrer. -} +data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer + +data Transferrer = Transferrer + { transferrerRead :: Handle + , transferrerWrite :: Handle + , transferrerHandle :: ProcessHandle + } + +newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool +newTransferrerPool c = newTMVarIO (c, []) + +popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int) +popTransferrerPool p = do + (c, l) <- takeTMVar p + case l of + [] -> do + putTMVar p (c, []) + return (Nothing, 0) + (i:is) -> do + putTMVar p (c, is) + return $ (Just i, length is) + +pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM () +pushTransferrerPool p i = do + (c, l) <- takeTMVar p + let l' = i:l + putTMVar p (c, l') + +{- Note that making a CheckTransferrer may allocate resources, + - such as a NotificationHandle, so it's important that the returned + - TransferrerPoolItem is pushed into the pool, and not left to be + - garbage collected. -} +mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem +mkTransferrerPoolItem p t = do + mkcheck <- atomically $ fst <$> readTMVar p + check <- mkcheck + return $ TransferrerPoolItem (Just t) check + +checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer +checkNetworkConnections dstatushandle = do + dstatus <- atomically $ readTMVar dstatushandle + h <- newNotificationHandle False (networkConnectedNotifier dstatus) + return $ not <$> checkNotification h diff --git a/Assistant/Types/UrlRenderer.hs b/Assistant/Types/UrlRenderer.hs new file mode 100644 index 0000000000..68c238d6a1 --- /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/Unused.hs b/Assistant/Unused.hs new file mode 100644 index 0000000000..194739367e --- /dev/null +++ b/Assistant/Unused.hs @@ -0,0 +1,86 @@ +{- git-annex assistant unused files + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Assistant.Unused where + +import qualified Data.Map as M + +import Assistant.Common +import qualified Git +import Types.Key +import Logs.Unused +import Logs.Location +import Annex.Content +import Utility.DataUnits +import Utility.DiskFree +import Utility.HumanTime +import Utility.Tense + +import Data.Time.Clock.POSIX +import qualified Data.Text as T + +describeUnused :: Assistant (Maybe TenseText) +describeUnused = describeUnused' False + +describeUnusedWhenBig :: Assistant (Maybe TenseText) +describeUnusedWhenBig = describeUnused' True + +{- This uses heuristics: 1000 unused keys, or more unused keys + - than the remaining free disk space, or more than 1/10th the total + - disk space being unused keys all suggest a problem. -} +describeUnused' :: Bool -> Assistant (Maybe TenseText) +describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog "" + where + go m = do + let num = M.size m + let diskused = foldl' sumkeysize 0 (M.keys m) + df <- forpath getDiskFree + disksize <- forpath getDiskSize + return $ if num == 0 + then Nothing + else if not whenbig || moreused df diskused || tenthused disksize diskused + then Just $ tenseWords + [ UnTensed $ T.pack $ roughSize storageUnits False diskused + , Tensed "are" "were" + , "taken up by unused files" + ] + else if num > 1000 + then Just $ tenseWords + [ UnTensed $ T.pack $ show num ++ " unused files" + , Tensed "exist" "existed" + ] + else Nothing + + moreused Nothing _ = False + moreused (Just df) used = df <= used + + tenthused Nothing _ = False + tenthused (Just disksize) used = used >= disksize `div` 10 + + sumkeysize s k = s + fromMaybe 0 (keySize k) + + forpath a = inRepo $ liftIO . a . Git.repoPath + +{- With a duration, expires all unused files that are older. + - With Nothing, expires *all* unused files. -} +expireUnused :: Maybe Duration -> Assistant () +expireUnused duration = do + m <- liftAnnex $ readUnusedLog "" + now <- liftIO getPOSIXTime + let oldkeys = M.keys $ M.filter (tooold now) m + forM_ oldkeys $ \k -> do + debug ["removing old unused key", key2file k] + liftAnnex $ do + lockContent k removeAnnex + logStatus k InfoMissing + where + boundry = durationToPOSIXTime <$> duration + tooold now (_, mt) = case boundry of + Nothing -> True + Just b -> maybe False (\t -> now - t >= b) mt diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs new file mode 100644 index 0000000000..35d63d27ae --- /dev/null +++ b/Assistant/Upgrade.hs @@ -0,0 +1,366 @@ +{- git-annex assistant upgrading + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Upgrade where + +import Assistant.Common +import Assistant.Restart +import qualified Annex +import Assistant.Alert +import Assistant.DaemonStatus +import Utility.Env +import Types.Distribution +import Logs.Transfer +import Logs.Web +import Logs.Presence +import Logs.Location +import Annex.Content +import Annex.UUID +import qualified Backend +import qualified Types.Backend +import qualified Types.Key +import Assistant.TransferQueue +import Assistant.TransferSlots +import Remote (remoteFromUUID) +import Annex.Path +import Config.Files +import Utility.ThreadScheduler +import Utility.Tmp +import Utility.UserInfo +import Utility.Gpg +import Utility.FileMode +import qualified Utility.Lsof as Lsof +import qualified Build.SysConfig +import qualified Utility.Url as Url +import qualified Annex.Url as Url + +import qualified Data.Map as M +import Data.Tuple.Utils + +{- Upgrade without interaction in the webapp. -} +unattendedUpgrade :: Assistant () +unattendedUpgrade = do + prepUpgrade + url <- runRestart + postUpgrade url + +prepUpgrade :: Assistant () +prepUpgrade = do + void $ addAlert upgradingAlert + liftIO $ setEnv upgradedEnv "1" True + prepRestart + +postUpgrade :: URLString -> Assistant () +postUpgrade = postRestart + +autoUpgradeEnabled :: Assistant Bool +autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig + +checkSuccessfulUpgrade :: IO Bool +checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv + +upgradedEnv :: String +upgradedEnv = "GIT_ANNEX_UPGRADED" + +{- Start downloading the distribution key from the web. + - Install a hook that will be run once the download is complete, + - and finishes the upgrade. + - + - Creates the destination directory where the upgrade will be installed + - early, in order to check if another upgrade has happened (or is + - happending). On failure, the directory is removed. + -} +startDistributionDownload :: GitAnnexDistribution -> Assistant () +startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation + where + go Nothing = debug ["Skipping redundant upgrade"] + go (Just dest) = do + liftAnnex $ setUrlPresent webUUID k u + hook <- asIO1 $ distributionDownloadComplete d dest cleanup + modifyDaemonStatus_ $ \s -> s + { transferHook = M.insert k hook (transferHook s) } + maybe noop (queueTransfer "upgrade" Next (Just f) t) + =<< liftAnnex (remoteFromUUID webUUID) + startTransfer t + k = distributionKey d + u = distributionUrl d + f = takeFileName u ++ " (for upgrade)" + t = Transfer + { transferDirection = Download + , transferUUID = webUUID + , transferKey = k + } + cleanup = liftAnnex $ do + lockContent k removeAnnex + setUrlMissing webUUID k u + logStatus k InfoMissing + +{- Called once the download is done. + - Passed an action that can be used to clean up the downloaded file. + - + - Fsck the key to verify the download. + -} +distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant () +distributionDownloadComplete d dest cleanup t + | transferDirection t == Download = do + debug ["finished downloading git-annex distribution"] + maybe (failedupgrade "bad download") go + =<< liftAnnex (withObjectLoc k fsckit (getM fsckit)) + | otherwise = cleanup + where + k = distributionKey d + fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of + Nothing -> return $ Just f + Just b -> case Types.Backend.fsckKey b of + Nothing -> return $ Just f + Just a -> ifM (a k f) + ( return $ Just f + , return Nothing + ) + go f = do + ua <- asIO $ upgradeToDistribution dest cleanup f + fa <- asIO1 failedupgrade + liftIO $ ua `catchNonAsync` (fa . show) + failedupgrade msg = do + void $ addAlert $ upgradeFailedAlert msg + cleanup + liftIO $ void $ tryIO $ removeDirectoryRecursive dest + +{- The upgrade method varies by OS. + - + - In general, find where the distribution was installed before, + - and unpack the new distribution next to it (in a versioned directory). + - Then update the programFile to point to the new version. + -} +upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant () +upgradeToDistribution newdir cleanup distributionfile = do + liftIO $ createDirectoryIfMissing True newdir + (program, deleteold) <- unpack + changeprogram program + cleanup + prepUpgrade + url <- runRestart + {- At this point, the new assistant is fully running, so + - it's safe to delete the old version. -} + liftIO $ void $ tryIO deleteold + postUpgrade url + where + changeprogram program = liftIO $ do + unlessM (boolSystem program [Param "version"]) $ + error "New git-annex program failed to run! Not using." + pf <- programFile + liftIO $ writeFile pf program + +#ifdef darwin_HOST_OS + {- OS X uses a dmg, so mount it, and copy the contents into place. -} + unpack = liftIO $ do + olddir <- oldVersionLocation + withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do + void $ boolSystem "hdiutil" + [ Param "attach", File distributionfile + , Param "-mountpoint", File tmpdir + ] + void $ boolSystem "cp" + [ Param "-R" + , File $ tmpdir installBase "Contents" + , File $ newdir + ] + void $ boolSystem "hdiutil" + [ Param "eject" + , File tmpdir + ] + sanitycheck newdir + let deleteold = do + deleteFromManifest $ olddir "Contents" "MacOS" + makeorigsymlink olddir + return (newdir "Contents" "MacOS" "git-annex", deleteold) +#else + {- Linux uses a tarball (so could other POSIX systems), so + - untar it (into a temp directory) and move the directory + - into place. -} + unpack = liftIO $ do + olddir <- oldVersionLocation + withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do + let tarball = tmpdir "tar" + -- Cannot rely on filename extension, and this also + -- avoids problems if tar doesn't support transparent + -- decompression. + void $ boolSystem "sh" + [ Param "-c" + , Param $ "zcat < " ++ shellEscape distributionfile ++ + " > " ++ shellEscape tarball + ] + tarok <- boolSystem "tar" + [ Param "xf" + , Param tarball + , Param "--directory", File tmpdir + ] + unless tarok $ + error $ "failed to untar " ++ distributionfile + sanitycheck $ tmpdir installBase + installby rename newdir (tmpdir installBase) + let deleteold = do + deleteFromManifest olddir + makeorigsymlink olddir + return (newdir "git-annex", deleteold) + installby a dstdir srcdir = + mapM_ (\x -> a x (dstdir takeFileName x)) + =<< dirContents srcdir +#endif + sanitycheck dir = + unlessM (doesDirectoryExist dir) $ + error $ "did not find " ++ dir ++ " in " ++ distributionfile + makeorigsymlink olddir = do + let origdir = parentDir olddir installBase + nukeFile origdir + createSymbolicLink newdir origdir + +{- Finds where the old version was installed. -} +oldVersionLocation :: IO FilePath +oldVersionLocation = do + pdir <- parentDir <$> readProgramFile +#ifdef darwin_HOST_OS + let dirs = splitDirectories pdir + {- It will probably be deep inside a git-annex.app directory. -} + let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of + Nothing -> pdir + Just i -> joinPath (take (i + 1) dirs) +#else + let olddir = pdir +#endif + when (null olddir) $ + error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" + return olddir + +{- Finds a place to install the new version. + - Generally, put it in the parent directory of where the old version was + - installed, and use a version number in the directory name. + - If unable to write to there, instead put it in the home directory. + - + - The directory is created. If it already exists, returns Nothing. + -} +newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath) +newVersionLocation d olddir = + trymkdir newloc $ do + home <- myHomeDir + trymkdir (home s) $ + return Nothing + where + s = installBase ++ "." ++ distributionVersion d + topdir = parentDir olddir + newloc = topdir s + trymkdir dir fallback = + (createDirectory dir >> return (Just dir)) + `catchIO` const fallback + +installBase :: String +installBase = "git-annex." ++ +#ifdef linux_HOST_OS + "linux" +#else +#ifdef darwin_HOST_OS + "app" +#else + "dir" +#endif +#endif + +deleteFromManifest :: FilePath -> IO () +deleteFromManifest dir = do + fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) + mapM_ nukeFile fs + nukeFile manifest + removeEmptyRecursive dir + where + manifest = dir "git-annex.MANIFEST" + +removeEmptyRecursive :: FilePath -> IO () +removeEmptyRecursive dir = do + mapM_ removeEmptyRecursive =<< dirContents dir + void $ tryIO $ removeDirectory dir + +{- This is a file that the UpgradeWatcher can watch for modifications to + - detect when git-annex has been upgraded. + -} +upgradeFlagFile :: IO (Maybe FilePath) +upgradeFlagFile = ifM usingDistribution + ( Just <$> programFile + , programPath + ) + +{- Sanity check to see if an upgrade is complete and the program is ready + - to be run. -} +upgradeSanityCheck :: IO Bool +upgradeSanityCheck = ifM usingDistribution + ( doesFileExist =<< programFile + , do + -- Ensure that the program is present, and has no writers, + -- and can be run. This should handle distribution + -- upgrades, manual upgrades, etc. + v <- programPath + case v of + Nothing -> return False + Just program -> do + untilM (doesFileExist program <&&> nowriter program) $ + threadDelaySeconds (Seconds 60) + boolSystem program [Param "version"] + ) + where + nowriter f = null + . filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly]) + . map snd3 + <$> Lsof.query [f] + +usingDistribution :: IO Bool +usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" + +downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) +downloadDistributionInfo = do + uo <- liftAnnex Url.getUrlOptions + liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do + let infof = tmpdir "info" + let sigf = infof ++ ".sig" + ifM (Url.downloadQuiet distributionInfoUrl infof uo + <&&> Url.downloadQuiet distributionInfoSigUrl sigf uo + <&&> verifyDistributionSig sigf) + ( readish <$> readFileStrict infof + , return Nothing + ) + +distributionInfoUrl :: String +distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info" + +distributionInfoSigUrl :: String +distributionInfoSigUrl = distributionInfoUrl ++ ".sig" + +{- Verifies that a file from the git-annex distribution has a valid + - signature. Pass the detached .sig file; the file to be verified should + - be located next to it. + - + - The gpg keyring used to verify the signature is located in + - trustedkeys.gpg, next to the git-annex program. + -} +verifyDistributionSig :: FilePath -> IO Bool +verifyDistributionSig sig = do + p <- readProgramFile + if isAbsolute p + then withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do + let trustedkeys = takeDirectory p "trustedkeys.gpg" + boolSystem gpgcmd + [ Param "--no-default-keyring" + , Param "--no-auto-check-trustdb" + , Param "--no-options" + , Param "--homedir" + , File gpgtmp + , Param "--keyring" + , File trustedkeys + , Param "--verify" + , File sig + ] + else return False diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs new file mode 100644 index 0000000000..52608e7eef --- /dev/null +++ b/Assistant/WebApp.hs @@ -0,0 +1,74 @@ +{- 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 Utility.WebApp + +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/Bootstrap3.hs b/Assistant/WebApp/Bootstrap3.hs new file mode 100644 index 0000000000..3fa20fc4dd --- /dev/null +++ b/Assistant/WebApp/Bootstrap3.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Helper functions for creating forms when using Bootstrap v3. +-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly +-- modified to be compatible with Yesod 1.0.1 +module Assistant.WebApp.Bootstrap3 + ( -- * Rendering forms + renderBootstrap3 + , BootstrapFormLayout(..) + , BootstrapGridOptions(..) + -- * Field settings + , bfs + , withPlaceholder + , withAutofocus + , withLargeInput + , withSmallInput + -- * Submit button + , bootstrapSubmit + , mbootstrapSubmit + , BootstrapSubmit(..) + ) where + +import Control.Arrow (second) +import Control.Monad (liftM) +import Data.Text (Text) +import Data.String (IsString(..)) +import Yesod.Core + +import qualified Data.Text as T + +import Yesod.Form.Types +import Yesod.Form.Functions + +-- | Create a new 'FieldSettings' with the classes that are +-- required by Bootstrap v3. +-- +-- Since: yesod-form 1.3.8 +bfs :: RenderMessage site msg => msg -> FieldSettings site +bfs msg = + FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")] + + +-- | Add a placeholder attribute to a field. If you need i18n +-- for the placeholder, currently you\'ll need to do a hack and +-- use 'getMessageRender' manually. +-- +-- Since: yesod-form 1.3.8 +withPlaceholder :: Text -> FieldSettings site -> FieldSettings site +withPlaceholder placeholder fs = fs { fsAttrs = newAttrs } + where newAttrs = ("placeholder", placeholder) : fsAttrs fs + + +-- | Add an autofocus attribute to a field. +-- +-- Since: yesod-form 1.3.8 +withAutofocus :: FieldSettings site -> FieldSettings site +withAutofocus fs = fs { fsAttrs = newAttrs } + where newAttrs = ("autofocus", "autofocus") : fsAttrs fs + + +-- | Add the @input-lg@ CSS class to a field. +-- +-- Since: yesod-form 1.3.8 +withLargeInput :: FieldSettings site -> FieldSettings site +withLargeInput fs = fs { fsAttrs = newAttrs } + where newAttrs = addClass "input-lg" (fsAttrs fs) + + +-- | Add the @input-sm@ CSS class to a field. +-- +-- Since: yesod-form 1.3.8 +withSmallInput :: FieldSettings site -> FieldSettings site +withSmallInput fs = fs { fsAttrs = newAttrs } + where newAttrs = addClass "input-sm" (fsAttrs fs) + + +addClass :: Text -> [(Text, Text)] -> [(Text, Text)] +addClass klass [] = [("class", klass)] +addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest +addClass klass (other :rest) = other : addClass klass rest + + +-- | How many bootstrap grid columns should be taken (see +-- 'BootstrapFormLayout'). +-- +-- Since: yesod-form 1.3.8 +data BootstrapGridOptions = + ColXs !Int + | ColSm !Int + | ColMd !Int + | ColLg !Int + deriving (Eq, Ord, Show) + +toColumn :: BootstrapGridOptions -> String +toColumn (ColXs 0) = "" +toColumn (ColSm 0) = "" +toColumn (ColMd 0) = "" +toColumn (ColLg 0) = "" +toColumn (ColXs columns) = "col-xs-" ++ show columns +toColumn (ColSm columns) = "col-sm-" ++ show columns +toColumn (ColMd columns) = "col-md-" ++ show columns +toColumn (ColLg columns) = "col-lg-" ++ show columns + +toOffset :: BootstrapGridOptions -> String +toOffset (ColXs 0) = "" +toOffset (ColSm 0) = "" +toOffset (ColMd 0) = "" +toOffset (ColLg 0) = "" +toOffset (ColXs columns) = "col-xs-offset-" ++ show columns +toOffset (ColSm columns) = "col-sm-offset-" ++ show columns +toOffset (ColMd columns) = "col-md-offset-" ++ show columns +toOffset (ColLg columns) = "col-lg-offset-" ++ show columns + +addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions +addGO (ColXs a) (ColXs b) = ColXs (a+b) +addGO (ColSm a) (ColSm b) = ColSm (a+b) +addGO (ColMd a) (ColMd b) = ColMd (a+b) +addGO (ColLg a) (ColLg b) = ColLg (a+b) +addGO a b | a > b = addGO b a +addGO (ColXs a) other = addGO (ColSm a) other +addGO (ColSm a) other = addGO (ColMd a) other +addGO (ColMd a) other = addGO (ColLg a) other +addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here" + + +-- | The layout used for the bootstrap form. +-- +-- Since: yesod-form 1.3.8 +data BootstrapFormLayout = + BootstrapBasicForm + | BootstrapInlineForm + | BootstrapHorizontalForm + { bflLabelOffset :: !BootstrapGridOptions + , bflLabelSize :: !BootstrapGridOptions + , bflInputOffset :: !BootstrapGridOptions + , bflInputSize :: !BootstrapGridOptions + } + deriving (Show) + + +-- | Render the given form using Bootstrap v3 conventions. +-- +-- Sample Hamlet for 'BootstrapHorizontalForm': +-- +-- >
+-- > ^{formWidget} +-- > ^{bootstrapSubmit MsgSubmit} +-- +-- Since: yesod-form 1.3.8 +renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a +renderBootstrap3 formLayout aform fragment = do + (res, views') <- aFormToForm aform + let views = views' [] + has (Just _) = True + has Nothing = False + widget = [whamlet| + #{fragment} + $forall view <- views +
+ $case formLayout + $of BootstrapBasicForm + $if nequals (fvId view) bootstrapSubmitId +