diff --git a/.forgejo/patches/ghc-9.8.patch b/.forgejo/patches/ghc-9.8.patch new file mode 100644 index 0000000000..85796d787d --- /dev/null +++ b/.forgejo/patches/ghc-9.8.patch @@ -0,0 +1,18 @@ +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 new file mode 100644 index 0000000000..8dbb579e67 --- /dev/null +++ b/.forgejo/workflows/generate-lockfile.yml @@ -0,0 +1,89 @@ +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 new file mode 100644 index 0000000000..f44c4668cf --- /dev/null +++ b/.forgejo/workflows/mirror-repository.yml @@ -0,0 +1,50 @@ +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 deleted file mode 100644 index c5550cee6e..0000000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:load Common diff --git a/.gitattributes b/.gitattributes deleted file mode 100644 index 5d425843f2..0000000000 --- a/.gitattributes +++ /dev/null @@ -1 +0,0 @@ -debian/changelog merge=dpkg-mergechangelogs diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 0e90a5f801..0000000000 --- a/.gitignore +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 index 275b236df9..0000000000 --- a/.mailmap +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 index f85c7e0f22..0000000000 --- a/Annex.hs +++ /dev/null @@ -1,312 +0,0 @@ -{- 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 deleted file mode 100644 index f0f183dfb5..0000000000 --- a/Annex/AutoMerge.hs +++ /dev/null @@ -1,206 +0,0 @@ -{- 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 deleted file mode 100644 index 6ce711996e..0000000000 --- a/Annex/Branch.hs +++ /dev/null @@ -1,559 +0,0 @@ -{- 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 deleted file mode 100644 index a9c7daa209..0000000000 --- a/Annex/Branch/Transitions.hs +++ /dev/null @@ -1,64 +0,0 @@ -{- 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 deleted file mode 100644 index 889a936b98..0000000000 --- a/Annex/BranchState.hs +++ /dev/null @@ -1,43 +0,0 @@ -{- 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 deleted file mode 100644 index 1791498446..0000000000 --- a/Annex/CatFile.hs +++ /dev/null @@ -1,158 +0,0 @@ -{- 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 deleted file mode 100644 index 46c71fe72f..0000000000 --- a/Annex/CheckAttr.hs +++ /dev/null @@ -1,35 +0,0 @@ -{- 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 deleted file mode 100644 index 8d7df1e2c6..0000000000 --- a/Annex/CheckIgnore.hs +++ /dev/null @@ -1,32 +0,0 @@ -{- 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 deleted file mode 100644 index f91c1e72ae..0000000000 --- a/Annex/Content.hs +++ /dev/null @@ -1,637 +0,0 @@ -{- 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 deleted file mode 100644 index e6a9b5eda3..0000000000 --- a/Annex/Content/Direct.hs +++ /dev/null @@ -1,263 +0,0 @@ -{- 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 deleted file mode 100644 index 66dc03a329..0000000000 --- a/Annex/Difference.hs +++ /dev/null @@ -1,58 +0,0 @@ -{- 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 deleted file mode 100644 index 03769350d3..0000000000 --- a/Annex/DirHashes.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- 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 deleted file mode 100644 index 1c733cb551..0000000000 --- a/Annex/Direct.hs +++ /dev/null @@ -1,456 +0,0 @@ -{- 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 deleted file mode 100644 index 793f92eafe..0000000000 --- a/Annex/Direct/Fixup.hs +++ /dev/null @@ -1,31 +0,0 @@ -{- 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 deleted file mode 100644 index 6f3b95615e..0000000000 --- a/Annex/Drop.hs +++ /dev/null @@ -1,123 +0,0 @@ -{- 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 deleted file mode 100644 index 13b52aa75c..0000000000 --- a/Annex/Environment.hs +++ /dev/null @@ -1,58 +0,0 @@ -{- 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 deleted file mode 100644 index 0de4d83d19..0000000000 --- a/Annex/FileMatcher.hs +++ /dev/null @@ -1,116 +0,0 @@ -{- 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 deleted file mode 100644 index 253c77a603..0000000000 --- a/Annex/Hook.hs +++ /dev/null @@ -1,67 +0,0 @@ -{- 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 deleted file mode 100644 index 60340c50b6..0000000000 --- a/Annex/Index.hs +++ /dev/null @@ -1,52 +0,0 @@ -{- 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 deleted file mode 100644 index 3f27a1172d..0000000000 --- a/Annex/Init.hs +++ /dev/null @@ -1,195 +0,0 @@ -{- 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 deleted file mode 100644 index 148cefbbc1..0000000000 --- a/Annex/Journal.hs +++ /dev/null @@ -1,120 +0,0 @@ -{- 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 deleted file mode 100644 index 98b200f0a0..0000000000 --- a/Annex/Link.hs +++ /dev/null @@ -1,112 +0,0 @@ -{- 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 deleted file mode 100644 index 18e876c75d..0000000000 --- a/Annex/LockFile.hs +++ /dev/null @@ -1,72 +0,0 @@ -{- 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 deleted file mode 100644 index 73443c43d9..0000000000 --- a/Annex/MakeRepo.hs +++ /dev/null @@ -1,88 +0,0 @@ -{- 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 deleted file mode 100644 index 3b776a6d75..0000000000 --- a/Annex/MetaData.hs +++ /dev/null @@ -1,55 +0,0 @@ -{- 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 deleted file mode 100644 index c91b539302..0000000000 --- a/Annex/MetaData/StandardFields.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- 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 deleted file mode 100644 index 25f1ee6781..0000000000 --- a/Annex/Notification.hs +++ /dev/null @@ -1,101 +0,0 @@ -{- 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 deleted file mode 100644 index 6186a887b1..0000000000 --- a/Annex/Path.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- 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 deleted file mode 100644 index 3ae351d8c8..0000000000 --- a/Annex/Perms.hs +++ /dev/null @@ -1,124 +0,0 @@ -{- 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 deleted file mode 100644 index 47837e2d9e..0000000000 --- a/Annex/Queue.hs +++ /dev/null @@ -1,62 +0,0 @@ -{- 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 deleted file mode 100644 index 8d4591b48f..0000000000 --- a/Annex/Quvi.hs +++ /dev/null @@ -1,33 +0,0 @@ -{- 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 deleted file mode 100644 index 1144ba0839..0000000000 --- a/Annex/ReplaceFile.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- 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 deleted file mode 100644 index 54c54d79f4..0000000000 --- a/Annex/Ssh.hs +++ /dev/null @@ -1,301 +0,0 @@ -{- 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 deleted file mode 100644 index 642d4db0bb..0000000000 --- a/Annex/TaggedPush.hs +++ /dev/null @@ -1,61 +0,0 @@ -{- 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 deleted file mode 100644 index 2723b2351b..0000000000 --- a/Annex/Transfer.hs +++ /dev/null @@ -1,145 +0,0 @@ -{- 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 deleted file mode 100644 index 7776b778a3..0000000000 --- a/Annex/UUID.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- 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 deleted file mode 100644 index b1a932e629..0000000000 --- a/Annex/Url.hs +++ /dev/null @@ -1,42 +0,0 @@ -{- 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 deleted file mode 100644 index 89cfbc16af..0000000000 --- a/Annex/VariantFile.hs +++ /dev/null @@ -1,45 +0,0 @@ -{- 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 deleted file mode 100644 index d08f994e95..0000000000 --- a/Annex/Version.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- 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 deleted file mode 100644 index 315cc7df2e..0000000000 --- a/Annex/View.hs +++ /dev/null @@ -1,450 +0,0 @@ -{- 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 deleted file mode 100644 index 0acba235a7..0000000000 --- a/Annex/View/ViewedFile.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- 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 deleted file mode 100644 index ba7df0a9cb..0000000000 --- a/Annex/Wanted.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- 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 deleted file mode 100644 index eb01bb9b97..0000000000 --- a/Assistant.hs +++ /dev/null @@ -1,197 +0,0 @@ -{- 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 deleted file mode 100644 index 1286e4590b..0000000000 --- a/Assistant/Alert.hs +++ /dev/null @@ -1,461 +0,0 @@ -{- 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 deleted file mode 100644 index 65484e0e63..0000000000 --- a/Assistant/Alert/Utility.hs +++ /dev/null @@ -1,130 +0,0 @@ -{- 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 deleted file mode 100644 index c588c910a7..0000000000 --- a/Assistant/BranchChange.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- 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 deleted file mode 100644 index 6eb9bc28e5..0000000000 --- a/Assistant/Changes.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- 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 deleted file mode 100644 index c82f8f4c7f..0000000000 --- a/Assistant/Commits.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- 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 deleted file mode 100644 index 5fab842908..0000000000 --- a/Assistant/Common.hs +++ /dev/null @@ -1,14 +0,0 @@ -{- 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 deleted file mode 100644 index ac355b55a5..0000000000 --- a/Assistant/CredPairCache.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- 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 deleted file mode 100644 index 1ed40595e1..0000000000 --- a/Assistant/DaemonStatus.hs +++ /dev/null @@ -1,271 +0,0 @@ -{- 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 deleted file mode 100644 index 5b044fd184..0000000000 --- a/Assistant/DeleteRemote.hs +++ /dev/null @@ -1,89 +0,0 @@ -{- 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 deleted file mode 100644 index 57eef8f3ae..0000000000 --- a/Assistant/Drop.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- 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 deleted file mode 100644 index 067c7d1a10..0000000000 --- a/Assistant/Fsck.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- 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 deleted file mode 100644 index 39e545978b..0000000000 --- a/Assistant/Gpg.hs +++ /dev/null @@ -1,36 +0,0 @@ -{- 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 deleted file mode 100644 index 6da6d2389a..0000000000 --- a/Assistant/Install.hs +++ /dev/null @@ -1,179 +0,0 @@ -{- 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 deleted file mode 100644 index b27b697750..0000000000 --- a/Assistant/Install/AutoStart.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- 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 deleted file mode 100644 index 32393abafd..0000000000 --- a/Assistant/Install/Menu.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- 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 deleted file mode 100644 index a5eace7240..0000000000 --- a/Assistant/MakeRemote.hs +++ /dev/null @@ -1,171 +0,0 @@ -{- 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 deleted file mode 100644 index a34264a019..0000000000 --- a/Assistant/Monad.hs +++ /dev/null @@ -1,150 +0,0 @@ -{- 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 deleted file mode 100644 index f809530534..0000000000 --- a/Assistant/NamedThread.hs +++ /dev/null @@ -1,102 +0,0 @@ -{- 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 deleted file mode 100644 index dd18111415..0000000000 --- a/Assistant/NetMessager.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- 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 deleted file mode 100644 index b24e5fdb61..0000000000 --- a/Assistant/Pairing.hs +++ /dev/null @@ -1,101 +0,0 @@ -{- 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 deleted file mode 100644 index 05533e2708..0000000000 --- a/Assistant/Pairing/MakeRemote.hs +++ /dev/null @@ -1,95 +0,0 @@ -{- 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 deleted file mode 100644 index 7a4ac3ffe5..0000000000 --- a/Assistant/Pairing/Network.hs +++ /dev/null @@ -1,129 +0,0 @@ -{- 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 deleted file mode 100644 index 7b4de450f8..0000000000 --- a/Assistant/Pushes.hs +++ /dev/null @@ -1,40 +0,0 @@ -{- 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 deleted file mode 100644 index 1016f1169b..0000000000 --- a/Assistant/RemoteControl.hs +++ /dev/null @@ -1,21 +0,0 @@ -{- 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 deleted file mode 100644 index 72f601db75..0000000000 --- a/Assistant/Repair.hs +++ /dev/null @@ -1,159 +0,0 @@ -{- 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 deleted file mode 100644 index 32595916ec..0000000000 --- a/Assistant/RepoProblem.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- 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 deleted file mode 100644 index 4120a46537..0000000000 --- a/Assistant/Restart.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- 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 deleted file mode 100644 index 0ce7a47ccf..0000000000 --- a/Assistant/ScanRemotes.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- 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 deleted file mode 100644 index 88afec7138..0000000000 --- a/Assistant/Ssh.hs +++ /dev/null @@ -1,345 +0,0 @@ -{- 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 deleted file mode 100644 index d914d2246c..0000000000 --- a/Assistant/Sync.hs +++ /dev/null @@ -1,278 +0,0 @@ -{- 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 deleted file mode 100644 index 8cf6da2d2c..0000000000 --- a/Assistant/Threads/Committer.hs +++ /dev/null @@ -1,479 +0,0 @@ -{- 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 deleted file mode 100644 index 7ab55fb82a..0000000000 --- a/Assistant/Threads/ConfigMonitor.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- 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 deleted file mode 100644 index 451fa75c60..0000000000 --- a/Assistant/Threads/Cronner.hs +++ /dev/null @@ -1,225 +0,0 @@ -{- 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 deleted file mode 100644 index d5b2cc25d6..0000000000 --- a/Assistant/Threads/DaemonStatus.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- 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 deleted file mode 100644 index 900e0d4238..0000000000 --- a/Assistant/Threads/Glacier.hs +++ /dev/null @@ -1,43 +0,0 @@ -{- 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 deleted file mode 100644 index f1a64925da..0000000000 --- a/Assistant/Threads/Merger.hs +++ /dev/null @@ -1,119 +0,0 @@ -{- 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 deleted file mode 100644 index 023af53cba..0000000000 --- a/Assistant/Threads/MountWatcher.hs +++ /dev/null @@ -1,199 +0,0 @@ -{- 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 deleted file mode 100644 index ad3a87a911..0000000000 --- a/Assistant/Threads/NetWatcher.hs +++ /dev/null @@ -1,184 +0,0 @@ -{- 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 deleted file mode 100644 index e4f87494c8..0000000000 --- a/Assistant/Threads/PairListener.hs +++ /dev/null @@ -1,151 +0,0 @@ -{- 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 deleted file mode 100644 index 86ee027f7c..0000000000 --- a/Assistant/Threads/ProblemFixer.hs +++ /dev/null @@ -1,70 +0,0 @@ -{- 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 deleted file mode 100644 index 35989ed48a..0000000000 --- a/Assistant/Threads/Pusher.hs +++ /dev/null @@ -1,49 +0,0 @@ -{- 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 deleted file mode 100644 index ae63aff5c0..0000000000 --- a/Assistant/Threads/RemoteControl.hs +++ /dev/null @@ -1,121 +0,0 @@ -{- 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 deleted file mode 100644 index 3073cfe41f..0000000000 --- a/Assistant/Threads/SanityChecker.hs +++ /dev/null @@ -1,327 +0,0 @@ -{- 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 deleted file mode 100644 index 73562dbf7e..0000000000 --- a/Assistant/Threads/TransferPoller.hs +++ /dev/null @@ -1,55 +0,0 @@ -{- 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 deleted file mode 100644 index 3cbaadf19f..0000000000 --- a/Assistant/Threads/TransferScanner.hs +++ /dev/null @@ -1,182 +0,0 @@ -{- 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 deleted file mode 100644 index c452d87c24..0000000000 --- a/Assistant/Threads/TransferWatcher.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- 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 deleted file mode 100644 index 073dbef3c0..0000000000 --- a/Assistant/Threads/Transferrer.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- 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 deleted file mode 100644 index e779c8e54d..0000000000 --- a/Assistant/Threads/UpgradeWatcher.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- 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 deleted file mode 100644 index 602d092082..0000000000 --- a/Assistant/Threads/Upgrader.hs +++ /dev/null @@ -1,85 +0,0 @@ -{- 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 deleted file mode 100644 index 6f3afa8cac..0000000000 --- a/Assistant/Threads/Watcher.hs +++ /dev/null @@ -1,368 +0,0 @@ -{- 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 deleted file mode 100644 index fd78ba8d8d..0000000000 --- a/Assistant/Threads/WebApp.hs +++ /dev/null @@ -1,146 +0,0 @@ -{- 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 deleted file mode 100644 index 78d527920d..0000000000 --- a/Assistant/Threads/XMPPClient.hs +++ /dev/null @@ -1,375 +0,0 @@ -{- 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 deleted file mode 100644 index ec11b9b944..0000000000 --- a/Assistant/Threads/XMPPPusher.hs +++ /dev/null @@ -1,81 +0,0 @@ -{- 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 deleted file mode 100644 index ba13b3f048..0000000000 --- a/Assistant/TransferQueue.hs +++ /dev/null @@ -1,233 +0,0 @@ -{- 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 deleted file mode 100644 index bbc2ec7e52..0000000000 --- a/Assistant/TransferSlots.hs +++ /dev/null @@ -1,293 +0,0 @@ -{- 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 deleted file mode 100644 index 152625f4f1..0000000000 --- a/Assistant/TransferrerPool.hs +++ /dev/null @@ -1,96 +0,0 @@ -{- 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 deleted file mode 100644 index a2e5d5c822..0000000000 --- a/Assistant/Types/Alert.hs +++ /dev/null @@ -1,79 +0,0 @@ -{- 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 deleted file mode 100644 index f769657d01..0000000000 --- a/Assistant/Types/BranchChange.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- 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 deleted file mode 100644 index 2887aaef09..0000000000 --- a/Assistant/Types/Buddies.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- 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 deleted file mode 100644 index 1d8b517754..0000000000 --- a/Assistant/Types/Changes.hs +++ /dev/null @@ -1,77 +0,0 @@ -{- 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 deleted file mode 100644 index bf83fc486e..0000000000 --- a/Assistant/Types/Commits.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- 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 deleted file mode 100644 index 9777e29ee0..0000000000 --- a/Assistant/Types/CredPairCache.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- 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 deleted file mode 100644 index e1b6c997e1..0000000000 --- a/Assistant/Types/DaemonStatus.hs +++ /dev/null @@ -1,122 +0,0 @@ -{- 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 deleted file mode 100644 index b07b322ad9..0000000000 --- a/Assistant/Types/NamedThread.hs +++ /dev/null @@ -1,21 +0,0 @@ -{- 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 deleted file mode 100644 index 475d810ae4..0000000000 --- a/Assistant/Types/NetMessager.hs +++ /dev/null @@ -1,155 +0,0 @@ -{- 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 deleted file mode 100644 index 0da8b44b57..0000000000 --- a/Assistant/Types/Pushes.hs +++ /dev/null @@ -1,24 +0,0 @@ -{- 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 deleted file mode 100644 index 42cb4a5aa4..0000000000 --- a/Assistant/Types/RemoteControl.hs +++ /dev/null @@ -1,16 +0,0 @@ -{- 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 deleted file mode 100644 index 3b9c72cf81..0000000000 --- a/Assistant/Types/RepoProblem.hs +++ /dev/null @@ -1,28 +0,0 @@ -{- 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 deleted file mode 100644 index ac6d8fef9c..0000000000 --- a/Assistant/Types/ScanRemotes.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- 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 deleted file mode 100644 index 57c704dad5..0000000000 --- a/Assistant/Types/ThreadName.hs +++ /dev/null @@ -1,14 +0,0 @@ -{- 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 deleted file mode 100644 index eadf325ea1..0000000000 --- a/Assistant/Types/ThreadedMonad.hs +++ /dev/null @@ -1,38 +0,0 @@ -{- 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 deleted file mode 100644 index 73a7521c59..0000000000 --- a/Assistant/Types/TransferQueue.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- 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 deleted file mode 100644 index 5fa1219a7f..0000000000 --- a/Assistant/Types/TransferSlots.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- 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 deleted file mode 100644 index 697bb8dd5f..0000000000 --- a/Assistant/Types/TransferrerPool.hs +++ /dev/null @@ -1,67 +0,0 @@ -{- 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 deleted file mode 100644 index 68c238d6a1..0000000000 --- a/Assistant/Types/UrlRenderer.hs +++ /dev/null @@ -1,26 +0,0 @@ -{- 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 deleted file mode 100644 index 194739367e..0000000000 --- a/Assistant/Unused.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- 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 deleted file mode 100644 index 35d63d27ae..0000000000 --- a/Assistant/Upgrade.hs +++ /dev/null @@ -1,366 +0,0 @@ -{- 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 deleted file mode 100644 index 52608e7eef..0000000000 --- a/Assistant/WebApp.hs +++ /dev/null @@ -1,74 +0,0 @@ -{- 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 deleted file mode 100644 index 3fa20fc4dd..0000000000 --- a/Assistant/WebApp/Bootstrap3.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# 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 -