Merge branch 'master' into database

This commit is contained in:
Joey Hess 2015-02-15 14:16:48 -04:00
commit bb242bdd82
4982 changed files with 89117 additions and 85285 deletions

4
.gitignore vendored
View file

@ -11,6 +11,7 @@ Build/EvilSplicer
Build/Standalone Build/Standalone
Build/OSXMkLibs Build/OSXMkLibs
Build/LinuxMkLibs Build/LinuxMkLibs
Build/BuildVersion
git-annex git-annex
git-annex.1 git-annex.1
git-annex-shell.1 git-annex-shell.1
@ -23,6 +24,9 @@ html
dist dist
# Sandboxed builds # Sandboxed builds
cabal-dev cabal-dev
.cabal-sandbox
cabal.sandbox.config
cabal.config
# Project-local emacs configuration # Project-local emacs configuration
.dir-locals.el .dir-locals.el
# OSX related # OSX related

View file

@ -1,6 +1,7 @@
Joey Hess <joey@kitenet.net> http://joey.kitenet.net/ <joey@web> Joey Hess <id@joeyh.name> http://joey.kitenet.net/ <joey@web>
Joey Hess <joey@kitenet.net> http://joeyh.name/ <joey@web> Joey Hess <id@joeyh.name> http://joeyh.name/ <joey@web>
Joey Hess <joey@kitenet.net> http://joeyh.name/ <http://joeyh.name/@web> Joey Hess <id@joeyh.name> http://joeyh.name/ <http://joeyh.name/@web>
Yaroslav Halchenko <debian@onerussian.com> Yaroslav Halchenko <debian@onerussian.com>
Yaroslav Halchenko <debian@onerussian.com> http://yarikoptic.myopenid.com/ <site-myopenid@web> Yaroslav Halchenko <debian@onerussian.com> http://yarikoptic.myopenid.com/ <site-myopenid@web>
Yaroslav Halchenko <debian@onerussian.com> https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY <Yaroslav@web> Yaroslav Halchenko <debian@onerussian.com> https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY <Yaroslav@web>
Richard Hartmann <richih@debian.org> https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U <Richard@web>

View file

@ -1,21 +1,21 @@
{- git-annex monad {- git-annex monad
- -
- Copyright 2010-2013 Joey Hess <joey@kitenet.net> - Copyright 2010-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-}
module Annex ( module Annex (
Annex, Annex,
AnnexState(..), AnnexState(..),
PreferredContentMap,
new, new,
run, run,
eval, eval,
getState, getState,
changeState, changeState,
withState,
setFlag, setFlag,
setField, setField,
setOutput, setOutput,
@ -29,13 +29,11 @@ module Annex (
getGitConfig, getGitConfig,
changeGitConfig, changeGitConfig,
changeGitRepo, changeGitRepo,
getRemoteGitConfig,
withCurrentState, withCurrentState,
changeDirectory,
) where ) where
import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import Control.Concurrent
import Common import Common
import qualified Git import qualified Git
import qualified Git.Config import qualified Git.Config
@ -60,29 +58,38 @@ import Types.FileMatcher
import Types.NumCopies import Types.NumCopies
import Types.LockPool import Types.LockPool
import Types.MetaData import Types.MetaData
import Types.DesktopNotify
import Types.CleanupActions import Types.CleanupActions
import qualified Utility.Matcher #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.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import Utility.Quvi (QuviVersion)
{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar. {- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.
- This allows modifying the state in an exception-safe fashion.
- The MVar is not exposed outside this module. - 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 } newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
deriving ( deriving (
Monad, Monad,
MonadIO, MonadIO,
MonadReader (MVar AnnexState), MonadReader (MVar AnnexState),
MonadCatchIO, MonadCatch,
MonadThrow,
MonadMask,
Functor, Functor,
Applicative Applicative
) )
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> MatchInfo -> Annex Bool))
-- internal state storage -- internal state storage
data AnnexState = AnnexState data AnnexState = AnnexState
{ repo :: Git.Repo { repo :: Git.Repo
@ -103,9 +110,10 @@ data AnnexState = AnnexState
, forcebackend :: Maybe String , forcebackend :: Maybe String
, globalnumcopies :: Maybe NumCopies , globalnumcopies :: Maybe NumCopies
, forcenumcopies :: Maybe NumCopies , forcenumcopies :: Maybe NumCopies
, limit :: Matcher (MatchInfo -> Annex Bool) , limit :: ExpandableMatcher Annex
, uuidmap :: Maybe UUIDMap , uuidmap :: Maybe UUIDMap
, preferredcontentmap :: Maybe PreferredContentMap , preferredcontentmap :: Maybe (FileMatcherMap Annex)
, requiredcontentmap :: Maybe (FileMatcherMap Annex)
, shared :: Maybe SharedRepository , shared :: Maybe SharedRepository
, forcetrust :: TrustMap , forcetrust :: TrustMap
, trustmap :: Maybe TrustMap , trustmap :: Maybe TrustMap
@ -116,12 +124,16 @@ data AnnexState = AnnexState
, fields :: M.Map String String , fields :: M.Map String String
, modmeta :: [ModMeta] , modmeta :: [ModMeta]
, cleanup :: M.Map CleanupAction (Annex ()) , cleanup :: M.Map CleanupAction (Annex ())
, inodeschanged :: Maybe Bool , sentinalstatus :: Maybe SentinalStatus
, useragent :: Maybe String , useragent :: Maybe String
, errcounter :: Integer , errcounter :: Integer
, unusedkeys :: Maybe (S.Set Key) , unusedkeys :: Maybe (S.Set Key)
, tempurls :: M.Map Key URLString
#ifdef WITH_QUVI
, quviversion :: Maybe QuviVersion , quviversion :: Maybe QuviVersion
#endif
, existinghooks :: M.Map Git.Hook.Hook Bool , existinghooks :: M.Map Git.Hook.Hook Bool
, desktopnotify :: DesktopNotify
} }
newState :: GitConfig -> Git.Repo -> AnnexState newState :: GitConfig -> Git.Repo -> AnnexState
@ -144,9 +156,10 @@ newState c r = AnnexState
, forcebackend = Nothing , forcebackend = Nothing
, globalnumcopies = Nothing , globalnumcopies = Nothing
, forcenumcopies = Nothing , forcenumcopies = Nothing
, limit = Left [] , limit = BuildingMatcher []
, uuidmap = Nothing , uuidmap = Nothing
, preferredcontentmap = Nothing , preferredcontentmap = Nothing
, requiredcontentmap = Nothing
, shared = Nothing , shared = Nothing
, forcetrust = M.empty , forcetrust = M.empty
, trustmap = Nothing , trustmap = Nothing
@ -157,19 +170,23 @@ newState c r = AnnexState
, fields = M.empty , fields = M.empty
, modmeta = [] , modmeta = []
, cleanup = M.empty , cleanup = M.empty
, inodeschanged = Nothing , sentinalstatus = Nothing
, useragent = Nothing , useragent = Nothing
, errcounter = 0 , errcounter = 0
, unusedkeys = Nothing , unusedkeys = Nothing
, tempurls = M.empty
#ifdef WITH_QUVI
, quviversion = Nothing , quviversion = Nothing
#endif
, existinghooks = M.empty , existinghooks = M.empty
, desktopnotify = mempty
} }
{- Makes an Annex state object for the specified git repo. {- Makes an Annex state object for the specified git repo.
- Ensures the config is read, if it was not already. -} - Ensures the config is read, if it was not already. -}
new :: Git.Repo -> IO AnnexState new :: Git.Repo -> IO AnnexState
new r = do new r = do
r' <- Git.Config.read r r' <- Git.Config.read =<< Git.relPath r
let c = extractGitConfig r' let c = extractGitConfig r'
newState c <$> if annexDirect c then fixupDirect r' else return r' newState c <$> if annexDirect c then fixupDirect r' else return r'
@ -200,6 +217,11 @@ changeState modifier = do
mvar <- ask mvar <- ask
liftIO $ modifyMVar_ mvar $ return . modifier 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 -} {- Sets a flag to True -}
setFlag :: String -> Annex () setFlag :: String -> Annex ()
setFlag flag = changeState $ \s -> setFlag flag = changeState $ \s ->
@ -261,6 +283,13 @@ changeGitRepo r = changeState $ \s -> s
, gitconfig = extractGitConfig 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 {- Converts an Annex action into an IO action, that runs with a copy
- of the current Annex state. - of the current Annex state.
- -
@ -270,3 +299,14 @@ withCurrentState :: Annex a -> Annex (IO a)
withCurrentState a = do withCurrentState a = do
s <- getState id s <- getState id
return $ eval s a 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' }

View file

@ -1,24 +1,27 @@
{- git-annex automatic merge conflict resolution {- git-annex automatic merge conflict resolution
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
module Annex.AutoMerge (autoMergeFrom) where module Annex.AutoMerge
( autoMergeFrom
, resolveMerge
, commitResolvedMerge
) where
import Common.Annex import Common.Annex
import qualified Annex.Queue import qualified Annex.Queue
import Annex.Direct import Annex.Direct
import Annex.CatFile import Annex.CatFile
import Annex.Link import Annex.Link
import qualified Git.Command
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
import qualified Git.UpdateIndex as UpdateIndex import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Merge import qualified Git.Merge
import qualified Git.Ref import qualified Git.Ref
import qualified Git.Sha
import qualified Git import qualified Git
import qualified Git.Branch
import Git.Types (BlobType(..)) import Git.Types (BlobType(..))
import Config import Config
import Annex.ReplaceFile import Annex.ReplaceFile
@ -29,23 +32,22 @@ import qualified Data.Set as S
{- Merges from a branch into the current branch {- Merges from a branch into the current branch
- (which may not exist yet), - (which may not exist yet),
- with automatic merge conflict resolution. -} - with automatic merge conflict resolution.
autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Annex Bool -
autoMergeFrom branch currbranch = do - 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 showOutput
case currbranch of case currbranch of
Nothing -> go Nothing Nothing -> go Nothing
Just b -> go =<< inRepo (Git.Ref.sha b) Just b -> go =<< inRepo (Git.Ref.sha b)
where where
go old = ifM isDirect go old = ifM isDirect
( do ( mergeDirect currbranch old branch (resolveMerge old branch) commitmode
d <- fromRepo gitAnnexMergeDir , inRepo (Git.Merge.mergeNonInteractive branch commitmode)
r <- inRepo (mergeDirect d branch) <||> (resolveMerge old branch <&&> commitResolvedMerge commitmode)
<||> resolveMerge old branch
mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree old) Git.Ref.headRef
return r
, inRepo (Git.Merge.mergeNonInteractive branch)
<||> resolveMerge old branch
) )
{- Resolves a conflicted merge. It's important that any conflicts be {- Resolves a conflicted merge. It's important that any conflicts be
@ -70,9 +72,11 @@ autoMergeFrom branch currbranch = do
- -
- In indirect mode, the merge is resolved in the work tree and files - 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 - 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 - tree.
- staged to the index, and written to the gitAnnexMergeDir, and later -
- mergeDirectCleanup handles updating 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 :: Maybe Git.Ref -> Git.Ref -> Annex Bool
resolveMerge us them = do resolveMerge us them = do
@ -92,14 +96,6 @@ resolveMerge us them = do
unlessM isDirect $ unlessM isDirect $
cleanConflictCruft mergedfs top cleanConflictCruft mergedfs top
Annex.Queue.flush Annex.Queue.flush
whenM isDirect $
void preCommitDirect
void $ inRepo $ Git.Command.runBool
[ Param "commit"
, Param "--no-verify"
, Param "-m"
, Param "git-annex automatic merge conflict fix"
]
showLongNote "Merge conflict was automatically resolved; you may want to examine the result." showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
return merged return merged
@ -118,11 +114,11 @@ resolveMerge' (Just us) them u = do
makelink keyUs makelink keyUs
-- Our side is annexed file, other side is not. -- Our side is annexed file, other side is not.
(Just keyUs, Nothing) -> resolveby $ do (Just keyUs, Nothing) -> resolveby $ do
graftin them file graftin them file LsFiles.valThem LsFiles.valThem
makelink keyUs makelink keyUs
-- Our side is not annexed file, other side is. -- Our side is not annexed file, other side is.
(Nothing, Just keyThem) -> resolveby $ do (Nothing, Just keyThem) -> resolveby $ do
graftin us file graftin us file LsFiles.valUs LsFiles.valUs
makelink keyThem makelink keyThem
-- Neither side is annexed file; cannot resolve. -- Neither side is annexed file; cannot resolve.
(Nothing, Nothing) -> return Nothing (Nothing, Nothing) -> return Nothing
@ -138,18 +134,42 @@ resolveMerge' (Just us) them u = do
makelink key = do makelink key = do
let dest = variantFile file key let dest = variantFile file key
l <- inRepo $ gitAnnexLink dest key l <- calcRepo $ gitAnnexLink dest key
ifM isDirect replacewithlink dest l
( do
d <- fromRepo gitAnnexMergeDir
replaceFile (d </> dest) $ makeAnnexLink l
, replaceFile dest $ makeAnnexLink l
)
stageSymlink dest =<< hashSymlink l stageSymlink dest =<< hashSymlink l
{- stage a graft of a directory or file from a branch -} replacewithlink dest link = ifM isDirect
graftin b item = Annex.Queue.addUpdateIndex ( do
=<< fromRepo (UpdateIndex.lsSubTree b item) 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 resolveby a = do
{- Remove conflicted file from index so merge can be resolved. -} {- Remove conflicted file from index so merge can be resolved. -}
@ -158,7 +178,7 @@ resolveMerge' (Just us) them u = do
return (Just file) return (Just file)
{- git-merge moves conflicting files away to files {- git-merge moves conflicting files away to files
- named something like f~HEAD or f~branch, but the - named something like f~HEAD or f~branch or just f, but the
- exact name chosen can vary. Once the conflict is resolved, - exact name chosen can vary. Once the conflict is resolved,
- this cruft can be deleted. To avoid deleting legitimate - this cruft can be deleted. To avoid deleting legitimate
- files that look like this, only delete files that are - files that look like this, only delete files that are
@ -175,5 +195,12 @@ cleanConflictCruft resolvedfs top = do
liftIO $ nukeFile f liftIO $ nukeFile f
| otherwise = noop | otherwise = noop
s = S.fromList resolvedfs s = S.fromList resolvedfs
matchesresolved f = S.member (base f) s matchesresolved f = S.member f s || S.member (base f) s
base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f 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"
]

View file

@ -1,6 +1,6 @@
{- management of the git-annex branch {- management of the git-annex branch
- -
- Copyright 2011-2013 Joey Hess <joey@kitenet.net> - Copyright 2011-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -25,9 +25,11 @@ module Annex.Branch (
performTransitions, performTransitions,
) where ) where
import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy as L
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import Data.Bits.Utils
import Control.Concurrent (threadDelay)
import Common.Annex import Common.Annex
import Annex.BranchState import Annex.BranchState
@ -48,9 +50,11 @@ import Annex.Perms
import Logs import Logs
import Logs.Transitions import Logs.Transitions
import Logs.Trust.Pure import Logs.Trust.Pure
import Logs.Difference.Pure
import Annex.ReplaceFile import Annex.ReplaceFile
import qualified Annex.Queue import qualified Annex.Queue
import Annex.Branch.Transitions import Annex.Branch.Transitions
import qualified Annex
{- Name of the branch that is used to store git-annex's information. -} {- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref name :: Git.Ref
@ -91,7 +95,7 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
fromMaybe (error $ "failed to create " ++ fromRef name) fromMaybe (error $ "failed to create " ++ fromRef name)
<$> branchsha <$> branchsha
go False = withIndex' True $ go False = withIndex' True $
inRepo $ Git.Branch.commitAlways "branch created" fullname [] inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname []
use sha = do use sha = do
setIndexSha sha setIndexSha sha
return sha return sha
@ -159,6 +163,7 @@ updateTo pairs = do
<$> getLocal transitionsLog <$> getLocal transitionsLog
unless (null branches) $ do unless (null branches) $ do
showSideAction merge_desc showSideAction merge_desc
mapM_ checkBranchDifferences refs
mergeIndex jl refs mergeIndex jl refs
let commitrefs = nub $ fullname:refs let commitrefs = nub $ fullname:refs
unlessM (handleTransitions jl localtransitions commitrefs) $ do unlessM (handleTransitions jl localtransitions commitrefs) $ do
@ -199,7 +204,7 @@ getHistorical :: RefDate -> FilePath -> Annex String
getHistorical date = getRef (Git.Ref.dateRef fullname date) getHistorical date = getRef (Git.Ref.dateRef fullname date)
getRef :: Ref -> FilePath -> Annex String getRef :: Ref -> FilePath -> Annex String
getRef ref file = withIndex $ L.unpack <$> catFile ref file getRef ref file = withIndex $ decodeBS <$> catFile ref file
{- Applies a function to modifiy the content of a file. {- Applies a function to modifiy the content of a file.
- -
@ -217,7 +222,7 @@ set = setJournalFile
commit :: String -> Annex () commit :: String -> Annex ()
commit = whenM journalDirty . forceCommit commit = whenM journalDirty . forceCommit
{- Commits the current index to the branch even without any journalleda {- Commits the current index to the branch even without any journalled
- changes. -} - changes. -}
forceCommit :: String -> Annex () forceCommit :: String -> Annex ()
forceCommit message = lockJournal $ \jl -> do forceCommit message = lockJournal $ \jl -> do
@ -228,30 +233,34 @@ forceCommit message = lockJournal $ \jl -> do
{- Commits the staged changes in the index to the branch. {- Commits the staged changes in the index to the branch.
- -
- Ensures that the branch's index file is first updated to the state - 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 - of the branch at branchref, before running the commit action. This
- is needed because the branch may have had changes pushed to it, that - is needed because the branch may have had changes pushed to it, that
- are not yet reflected in the index. - are not yet reflected in the index.
-
- Also safely handles a race that can occur if a change is being pushed
- into the branch at the same time. When the race happens, the commit will
- be made on top of the newly pushed change, but without the index file
- being updated to include it. The result is that the newly pushed
- change is reverted. This race is detected and another commit made
- to fix it.
- -
- The branchref value can have been obtained using getBranch at any - The branchref value can have been obtained using getBranch at any
- previous point, though getting it a long time ago makes the race - previous point, though getting it a long time ago makes the race
- more likely to occur. - 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 :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
commitIndex jl branchref message parents = do commitIndex jl branchref message parents = do
showStoringStateAction showStoringStateAction
commitIndex' jl branchref message parents commitIndex' jl branchref message message 0 parents
commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex () commitIndex' :: JournalLocked -> Git.Ref -> String -> String -> Integer -> [Git.Ref] -> Annex ()
commitIndex' jl branchref message parents = do commitIndex' jl branchref message basemessage retrynum parents = do
updateIndex jl branchref updateIndex jl branchref
committedref <- inRepo $ Git.Branch.commitAlways message fullname parents committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname parents
setIndexSha committedref setIndexSha committedref
parentrefs <- commitparents <$> catObject committedref parentrefs <- commitparents <$> catObject committedref
when (racedetected branchref parentrefs) $ when (racedetected branchref parentrefs) $
@ -259,7 +268,8 @@ commitIndex' jl branchref message parents = do
where where
-- look for "parent ref" lines and return the refs -- look for "parent ref" lines and return the refs
commitparents = map (Git.Ref . snd) . filter isparent . commitparents = map (Git.Ref . snd) . filter isparent .
map (toassoc . L.unpack) . L.lines map (toassoc . decodeBS) . L.split newline
newline = c2w8 '\n'
toassoc = separate (== ' ') toassoc = separate (== ' ')
isparent (k,_) = k == "parent" isparent (k,_) = k == "parent"
@ -271,12 +281,16 @@ commitIndex' jl branchref message parents = do
| otherwise = True -- race! | otherwise = True -- race!
{- To recover from the race, union merge the lost refs {- To recover from the race, union merge the lost refs
- into the index, and recommit on top of the bad commit. -} - into the index. -}
fixrace committedref lostrefs = do 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 mergeIndex jl lostrefs
commitIndex jl committedref racemessage [committedref] let racemessage = basemessage ++ " (recovery from race #" ++ show retrynum' ++ "; expected commit parent " ++ show branchref ++ " but found " ++ show lostrefs ++ " )"
commitIndex' jl committedref racemessage basemessage retrynum' [committedref]
racemessage = message ++ " (recovery from race)"
{- Lists all files on the branch. There may be duplicates in the list. -} {- Lists all files on the branch. There may be duplicates in the list. -}
files :: Annex [FilePath] files :: Annex [FilePath]
@ -332,7 +346,7 @@ withIndex :: Annex a -> Annex a
withIndex = withIndex' False withIndex = withIndex' False
withIndex' :: Bool -> Annex a -> Annex a withIndex' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do withIndex' bootstrapping a = do
f <- fromRepo gitAnnexIndex f <- liftIO . absPath =<< fromRepo gitAnnexIndex
withIndexFile f $ do withIndexFile f $ do
checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
unless bootstrapping create unless bootstrapping create
@ -387,19 +401,40 @@ stageJournal jl = withIndex $ do
prepareModifyIndex jl prepareModifyIndex jl
g <- gitRepo g <- gitRepo
let dir = gitAnnexJournalDir g let dir = gitAnnexJournalDir g
fs <- getJournalFiles jl (jlogf, jlogh) <- openjlog
liftIO $ do withJournalHandle $ \jh -> do
h <- hashObjectStart g h <- hashObjectStart g
Git.UpdateIndex.streamUpdateIndex g Git.UpdateIndex.streamUpdateIndex g
[genstream dir h fs] [genstream dir h jh jlogh]
hashObjectStop h hashObjectStop h
return $ liftIO $ mapM_ (removeFile . (dir </>)) fs return $ cleanup dir jlogh jlogf
where where
genstream dir h fs streamer = forM_ fs $ \file -> do genstream dir h jh jlogh streamer = do
let path = dir </> file v <- readDirectory jh
sha <- hashFile h path case v of
streamer $ Git.UpdateIndex.updateIndexLine Nothing -> return ()
sha FileBlob (asTopFilePath $ fileJournal file) 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, {- This is run after the refs have been merged into the index,
- but before the result is committed to the branch. - but before the result is committed to the branch.
@ -431,8 +466,8 @@ handleTransitions jl localts refs = do
ignoreRefs untransitionedrefs ignoreRefs untransitionedrefs
return True return True
where where
getreftransition ref = do getreftransition ref = do
ts <- parseTransitionsStrictly "remote" . L.unpack ts <- parseTransitionsStrictly "remote" . decodeBS
<$> catFile ref transitionsLog <$> catFile ref transitionsLog
return (ref, ts) return (ref, ts)
@ -447,7 +482,7 @@ ignoreRefs rs = do
getIgnoredRefs :: Annex (S.Set Git.Ref) getIgnoredRefs :: Annex (S.Set Git.Ref)
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
where where
content = do content = do
f <- fromRepo gitAnnexIgnoredRefs f <- fromRepo gitAnnexIgnoredRefs
liftIO $ catchDefaultIO "" $ readFile f liftIO $ catchDefaultIO "" $ readFile f
@ -469,13 +504,13 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
Annex.Queue.flush Annex.Queue.flush
if neednewlocalbranch if neednewlocalbranch
then do then do
committedref <- inRepo $ Git.Branch.commitAlways message fullname transitionedrefs committedref <- inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit message fullname transitionedrefs
setIndexSha committedref setIndexSha committedref
else do else do
ref <- getBranch ref <- getBranch
commitIndex jl ref message (nub $ fullname:transitionedrefs) commitIndex jl ref message (nub $ fullname:transitionedrefs)
where where
message message
| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc | neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc
| otherwise = "continuing transition " ++ tdesc | otherwise = "continuing transition " ++ tdesc
tdesc = show $ map describeTransition $ transitionList ts tdesc = show $ map describeTransition $ transitionList ts
@ -514,3 +549,11 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
apply rest hasher file content' trustmap apply rest hasher file content' trustmap
PreserveFile -> PreserveFile ->
apply rest hasher file content trustmap 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."

View file

@ -1,6 +1,6 @@
{- git-annex branch transitions {- git-annex branch transitions
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -12,12 +12,14 @@ module Annex.Branch.Transitions (
import Logs import Logs
import Logs.Transitions import Logs.Transitions
import Logs.UUIDBased as UUIDBased import qualified Logs.UUIDBased as UUIDBased
import Logs.Presence.Pure as Presence import qualified Logs.Presence.Pure as Presence
import qualified Logs.Chunk.Pure as Chunk
import Types.TrustLevel import Types.TrustLevel
import Types.UUID import Types.UUID
import qualified Data.Map as M import qualified Data.Map as M
import Data.Default
data FileTransition data FileTransition
= ChangeFile String = ChangeFile String
@ -32,10 +34,16 @@ getTransitionCalculator ForgetDeadRemotes = Just dropDead
dropDead :: FilePath -> String -> TrustMap -> FileTransition dropDead :: FilePath -> String -> TrustMap -> FileTransition
dropDead f content trustmap = case getLogVariety f of dropDead f content trustmap = case getLogVariety f of
Just UUIDBasedLog -> ChangeFile $ Just UUIDBasedLog
UUIDBased.showLog id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLog Just content -- 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 $ Just NewUUIDBasedLog -> ChangeFile $
UUIDBased.showLogNew id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLogNew Just content UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content
Just (ChunkLog _) -> ChangeFile $
Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content
Just (PresenceLog _) -> Just (PresenceLog _) ->
let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
in if null newlog in if null newlog
@ -44,8 +52,8 @@ dropDead f content trustmap = case getLogVariety f of
Just OtherLog -> PreserveFile Just OtherLog -> PreserveFile
Nothing -> PreserveFile Nothing -> PreserveFile
dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String dropDeadFromMapLog :: Ord k => TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v
dropDeadFromUUIDBasedLog trustmap = M.filterWithKey $ notDead trustmap . const dropDeadFromMapLog trustmap getuuid = M.filterWithKey $ \k _v -> notDead trustmap getuuid k
{- Presence logs can contain UUIDs or other values. Any line that matches {- Presence logs can contain UUIDs or other values. Any line that matches
- a dead uuid is dropped; any other values are passed through. -} - a dead uuid is dropped; any other values are passed through. -}
@ -53,4 +61,4 @@ dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info) dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)
notDead :: TrustMap -> (v -> UUID) -> v -> Bool notDead :: TrustMap -> (v -> UUID) -> v -> Bool
notDead trustmap a v = M.findWithDefault SemiTrusted (a v) trustmap /= DeadTrusted notDead trustmap a v = M.findWithDefault def (a v) trustmap /= DeadTrusted

View file

@ -2,7 +2,7 @@
- -
- Runtime state about the git-annex branch. - Runtime state about the git-annex branch.
- -
- Copyright 2011-2012 Joey Hess <joey@kitenet.net> - Copyright 2011-2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git cat-file interface, with handle automatically stored in the Annex monad {- git cat-file interface, with handle automatically stored in the Annex monad
- -
- Copyright 2011-2013 Joey Hess <joey@kitenet.net> - Copyright 2011-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -12,9 +12,11 @@ module Annex.CatFile (
catTree, catTree,
catObjectDetails, catObjectDetails,
catFileHandle, catFileHandle,
catFileStop,
catKey, catKey,
catKeyFile, catKeyFile,
catKeyFileHEAD, catKeyFileHEAD,
catLink,
) where ) where
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -70,6 +72,14 @@ catFileHandle = do
Annex.changeState $ \s -> s { Annex.catfilehandles = m' } Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
return h 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. {- From the Sha or Ref of a symlink back to the key.
- -
- Requires a mode witness, to guarantee that the file is a symlink. - Requires a mode witness, to guarantee that the file is a symlink.
@ -77,21 +87,25 @@ catFileHandle = do
catKey :: Ref -> FileMode -> Annex (Maybe Key) catKey :: Ref -> FileMode -> Annex (Maybe Key)
catKey = catKey' True catKey = catKey' True
catKey' :: Bool -> Ref -> FileMode -> Annex (Maybe Key) catKey' :: Bool -> Sha -> FileMode -> Annex (Maybe Key)
catKey' modeguaranteed ref mode catKey' modeguaranteed sha mode
| isSymLink mode = do | isSymLink mode = do
l <- fromInternalGitPath . decodeBS <$> get l <- catLink modeguaranteed sha
return $ if isLinkToAnnex l return $ if isLinkToAnnex l
then fileKey $ takeFileName l then fileKey $ takeFileName l
else Nothing else Nothing
| otherwise = return Nothing | otherwise = return Nothing
{- Gets a symlink target. -}
catLink :: Bool -> Sha -> Annex String
catLink modeguaranteed sha = fromInternalGitPath . decodeBS <$> get
where where
-- If the mode is not guaranteed to be correct, avoid -- If the mode is not guaranteed to be correct, avoid
-- buffering the whole file content, which might be large. -- buffering the whole file content, which might be large.
-- 8192 is enough if it really is a symlink. -- 8192 is enough if it really is a symlink.
get get
| modeguaranteed = catObject ref | modeguaranteed = catObject sha
| otherwise = L.take 8192 <$> catObject ref | otherwise = L.take 8192 <$> catObject sha
{- Looks up the key corresponding to the Ref using the running cat-file. {- Looks up the key corresponding to the Ref using the running cat-file.
- -
@ -106,7 +120,7 @@ catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
catKeyChecked needhead ref@(Ref r) = catKeyChecked needhead ref@(Ref r) =
catKey' False ref =<< findmode <$> catTree treeref catKey' False ref =<< findmode <$> catTree treeref
where where
pathparts = split "/" r pathparts = split "/" r
dir = intercalate "/" $ take (length pathparts - 1) pathparts dir = intercalate "/" $ take (length pathparts - 1) pathparts
file = fromMaybe "" $ lastMaybe pathparts file = fromMaybe "" $ lastMaybe pathparts
treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/" treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"

View file

@ -1,6 +1,6 @@
{- git check-attr interface, with handle automatically stored in the Annex monad {- git check-attr interface, with handle automatically stored in the Annex monad
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,7 +1,7 @@
{- git check-ignore interface, with handle automatically stored in {- git check-ignore interface, with handle automatically stored in
- the Annex monad - the Annex monad
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -18,7 +18,7 @@ import qualified Annex
checkIgnored :: FilePath -> Annex Bool checkIgnored :: FilePath -> Annex Bool
checkIgnored file = go =<< checkIgnoreHandle checkIgnored file = go =<< checkIgnoreHandle
where where
go Nothing = return False go Nothing = return False
go (Just h) = liftIO $ Git.checkIgnored h file go (Just h) = liftIO $ Git.checkIgnored h file
checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle) checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)

View file

@ -1,6 +1,6 @@
{- git-annex file content managing {- git-annex file content managing
- -
- Copyright 2010-2014 Joey Hess <joey@kitenet.net> - Copyright 2010-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -16,6 +16,7 @@ module Annex.Content (
getViaTmpChecked, getViaTmpChecked,
getViaTmpUnchecked, getViaTmpUnchecked,
prepGetViaTmpChecked, prepGetViaTmpChecked,
prepTmp,
withTmp, withTmp,
checkDiskSpace, checkDiskSpace,
moveAnnex, moveAnnex,
@ -55,11 +56,7 @@ import Annex.Perms
import Annex.Link import Annex.Link
import Annex.Content.Direct import Annex.Content.Direct
import Annex.ReplaceFile import Annex.ReplaceFile
import Annex.Exception import Utility.LockFile
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif
{- Checks if a given key's content is currently present. -} {- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool inAnnex :: Key -> Annex Bool
@ -104,27 +101,32 @@ inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key
=<< contentLockFile key =<< contentLockFile key
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
checkindirect f = liftIO $ openforlock f >>= check is_missing checkindirect contentfile = liftIO $ checkOr is_missing contentfile
{- In direct mode, the content file must exist, but {- In direct mode, the content file must exist, but
- the lock file often generally won't exist unless a removal is in - the lock file generally won't exist unless a removal is in
- process. This does not create the lock file, it only checks for - process. -}
- it. -}
checkdirect contentfile lockfile = liftIO $ checkdirect contentfile lockfile = liftIO $
ifM (doesFileExist contentfile) ifM (doesFileExist contentfile)
( openforlock lockfile >>= check is_unlocked ( checkOr is_unlocked lockfile
, return is_missing , return is_missing
) )
openforlock f = catchMaybeIO $ checkOr d lockfile = do
openFd f ReadOnly Nothing defaultFileFlags v <- checkLocked lockfile
check _ (Just h) = do
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
closeFd h
return $ case v of return $ case v of
Just _ -> is_locked Nothing -> d
Nothing -> is_unlocked Just True -> is_locked
check def Nothing = return def Just False -> is_unlocked
#else #else
checkindirect _ = return is_missing 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, {- In Windows, see if we can take a shared lock. If so,
- remove the lock file to clean up after ourselves. -} - remove the lock file to clean up after ourselves. -}
checkdirect contentfile lockfile = checkdirect contentfile lockfile =
@ -150,14 +152,20 @@ contentLockFile key = ifM isDirect
, return Nothing , return Nothing
) )
newtype ContentLock = ContentLock Key
{- Content is exclusively locked while running an action that might remove {- Content is exclusively locked while running an action that might remove
- it. (If the content is not present, no locking is done.) -} - it. (If the content is not present, no locking is done.)
lockContent :: Key -> Annex a -> Annex a -}
lockContent :: Key -> (ContentLock -> Annex a) -> Annex a
lockContent key a = do lockContent key a = do
contentfile <- calcRepo $ gitAnnexLocation key contentfile <- calcRepo $ gitAnnexLocation key
lockfile <- contentLockFile key lockfile <- contentLockFile key
maybe noop setuplockfile lockfile maybe noop setuplockfile lockfile
bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a) bracket
(lock contentfile lockfile)
(unlock lockfile)
(const $ a $ ContentLock key)
where where
alreadylocked = error "content is locked" alreadylocked = error "content is locked"
setuplockfile lockfile = modifyContent lockfile $ setuplockfile lockfile = modifyContent lockfile $
@ -167,17 +175,17 @@ lockContent key a = do
void $ liftIO $ tryIO $ void $ liftIO $ tryIO $
nukeFile lockfile nukeFile lockfile
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
lock contentfile Nothing = opencontentforlock contentfile >>= dolock lock contentfile Nothing = liftIO $
lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just 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 {- Since content files are stored with the write bit disabled, have
- to fiddle with permissions to open for an exclusive lock. -} - to fiddle with permissions to open for an exclusive lock. -}
opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f) opencontentforlock f = catchDefaultIO Nothing $
( withModifiedFileMode f withModifiedFileMode f
(`unionFileModes` ownerWriteMode) (`unionFileModes` ownerWriteMode)
(openforlock f) (openExistingLockFile f)
, openforlock f
)
openforlock f = openFd f ReadWrite Nothing defaultFileFlags
dolock Nothing = return Nothing dolock Nothing = return Nothing
dolock (Just fd) = do dolock (Just fd) = do
v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
@ -188,7 +196,8 @@ lockContent key a = do
maybe noop cleanuplockfile mlockfile maybe noop cleanuplockfile mlockfile
liftIO $ maybe noop closeFd mfd liftIO $ maybe noop closeFd mfd
#else #else
lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile lock _ (Just lockfile) = liftIO $
maybe alreadylocked (return . Just) =<< lockExclusive lockfile
lock _ Nothing = return Nothing lock _ Nothing = return Nothing
unlock mlockfile mlockhandle = do unlock mlockfile mlockhandle = do
liftIO $ maybe noop dropLock mlockhandle liftIO $ maybe noop dropLock mlockhandle
@ -209,7 +218,7 @@ getViaTmpUnchecked = finishGetViaTmp (return True)
getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpChecked check key action = getViaTmpChecked check key action =
prepGetViaTmpChecked key $ prepGetViaTmpChecked key False $
finishGetViaTmp check key action finishGetViaTmp check key action
{- Prepares to download a key via a tmp file, and checks that there is {- Prepares to download a key via a tmp file, and checks that there is
@ -220,20 +229,20 @@ getViaTmpChecked check key action =
- -
- Wen there's enough free space, runs the download action. - Wen there's enough free space, runs the download action.
-} -}
prepGetViaTmpChecked :: Key -> Annex Bool -> Annex Bool prepGetViaTmpChecked :: Key -> a -> Annex a -> Annex a
prepGetViaTmpChecked key getkey = do prepGetViaTmpChecked key unabletoget getkey = do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key tmp <- fromRepo $ gitAnnexTmpObjectLocation key
e <- liftIO $ doesFileExist tmp e <- liftIO $ doesFileExist tmp
alreadythere <- if e alreadythere <- liftIO $ if e
then fromIntegral . fileSize <$> liftIO (getFileStatus tmp) then getFileSize tmp
else return 0 else return 0
ifM (checkDiskSpace Nothing key alreadythere) ifM (checkDiskSpace Nothing key alreadythere)
( do ( do
-- The tmp file may not have been left writable -- The tmp file may not have been left writable
when e $ thawContent tmp when e $ thawContent tmp
getkey getkey
, return False , return unabletoget
) )
finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
@ -255,7 +264,10 @@ prepTmp key = do
createAnnexDirectory (parentDir tmp) createAnnexDirectory (parentDir tmp)
return tmp return tmp
{- Creates a temp file, runs an action on it, and cleans up the temp file. -} {- 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 -> (FilePath -> Annex a) -> Annex a
withTmp key action = do withTmp key action = do
tmp <- prepTmp key tmp <- prepTmp key
@ -365,7 +377,7 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex key
) )
{- Returns a file that contains an object's content, {- Returns a file that contains an object's content,
- and an check to run after the transfer is complete. - 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, - 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. - and the check detects this case and returns False.
@ -407,7 +419,7 @@ withObjectLoc key indirect direct = ifM isDirect
cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc :: Key -> Annex () -> Annex ()
cleanObjectLoc key cleaner = do cleanObjectLoc key cleaner = do
file <- calcRepo $ gitAnnexLocation key file <- calcRepo $ gitAnnexLocation key
void $ tryAnnexIO $ thawContentDir file void $ tryIO $ thawContentDir file
cleaner cleaner
liftIO $ removeparents file (3 :: Int) liftIO $ removeparents file (3 :: Int)
where where
@ -420,9 +432,10 @@ cleanObjectLoc key cleaner = do
{- Removes a key's file from .git/annex/objects/ {- Removes a key's file from .git/annex/objects/
- -
- In direct mode, deletes the associated files or files, and replaces - In direct mode, deletes the associated files or files, and replaces
- them with symlinks. -} - them with symlinks.
removeAnnex :: Key -> Annex () -}
removeAnnex key = withObjectLoc key remove removedirect removeAnnex :: ContentLock -> Annex ()
removeAnnex (ContentLock key) = withObjectLoc key remove removedirect
where where
remove file = cleanObjectLoc key $ do remove file = cleanObjectLoc key $ do
secureErase file secureErase file
@ -433,7 +446,7 @@ removeAnnex key = withObjectLoc key remove removedirect
removeInodeCache key removeInodeCache key
mapM_ (resetfile cache) fs mapM_ (resetfile cache) fs
resetfile cache f = whenM (sameInodeCache f cache) $ do resetfile cache f = whenM (sameInodeCache f cache) $ do
l <- inRepo $ gitAnnexLink f key l <- calcRepo $ gitAnnexLink f key
secureErase f secureErase f
replaceFile f $ makeAnnexLink l replaceFile f $ makeAnnexLink l
@ -443,7 +456,7 @@ removeAnnex key = withObjectLoc key remove removedirect
secureErase :: FilePath -> Annex () secureErase :: FilePath -> Annex ()
secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
where where
go basecmd = void $ liftIO $ go basecmd = void $ liftIO $
boolSystem "sh" [Param "-c", Param $ gencmd basecmd] boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
gencmd = massReplace [ ("%file", shellEscape file) ] gencmd = massReplace [ ("%file", shellEscape file) ]
@ -542,7 +555,7 @@ saveState nocommit = doSideAction $ do
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
where where
go Nothing = Url.withUrlOptions $ \uo -> go Nothing = Url.withUrlOptions $ \uo ->
anyM (\u -> Url.download u file uo) urls anyM (\u -> Url.download u file uo) urls
go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
downloadcmd basecmd url = downloadcmd basecmd url =
@ -567,7 +580,7 @@ preseedTmp key file = go =<< inAnnex key
( return True ( return True
, do , do
s <- calcRepo $ gitAnnexLocation key s <- calcRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file liftIO $ copyFileExternal CopyTimeStamps s file
) )
{- Blocks writing to an annexed file, and modifies file permissions to {- Blocks writing to an annexed file, and modifies file permissions to

View file

@ -1,10 +1,12 @@
{- git-annex file content managing for direct mode {- git-annex file content managing for direct mode
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE CPP #-}
module Annex.Content.Direct ( module Annex.Content.Direct (
associatedFiles, associatedFiles,
associatedFilesRelative, associatedFilesRelative,
@ -27,6 +29,8 @@ module Annex.Content.Direct (
inodesChanged, inodesChanged,
createInodeSentinalFile, createInodeSentinalFile,
addContentWhenNotPresent, addContentWhenNotPresent,
withTSDelta,
getTSDelta,
) where ) where
import Common.Annex import Common.Annex
@ -110,7 +114,7 @@ addAssociatedFile key file = do
normaliseAssociatedFile :: FilePath -> Annex FilePath normaliseAssociatedFile :: FilePath -> Annex FilePath
normaliseAssociatedFile file = do normaliseAssociatedFile file = do
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
liftIO $ relPathDirToFile top <$> absPath file liftIO $ relPathDirToFile top file
{- Checks if a file in the tree, associated with a key, has not been modified. {- Checks if a file in the tree, associated with a key, has not been modified.
- -
@ -136,7 +140,7 @@ recordedInodeCache key = withInodeCacheFile key $ \f ->
-} -}
updateInodeCache :: Key -> FilePath -> Annex () updateInodeCache :: Key -> FilePath -> Annex ()
updateInodeCache key file = maybe noop (addInodeCache key) updateInodeCache key file = maybe noop (addInodeCache key)
=<< liftIO (genInodeCache file) =<< withTSDelta (liftIO . genInodeCache file)
{- Adds another inode to the cache for a key. -} {- Adds another inode to the cache for a key. -}
addInodeCache :: Key -> InodeCache -> Annex () addInodeCache :: Key -> InodeCache -> Annex ()
@ -164,16 +168,16 @@ withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
{- Checks if a InodeCache matches the current version of a file. -} {- Checks if a InodeCache matches the current version of a file. -}
sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
sameInodeCache _ [] = return False sameInodeCache _ [] = return False
sameInodeCache file old = go =<< liftIO (genInodeCache file) sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
where where
go Nothing = return False go Nothing = return False
go (Just curr) = elemInodeCaches curr old go (Just curr) = elemInodeCaches curr old
{- Checks if a FileStatus matches the recorded InodeCache of a file. -} {- Checks if a FileStatus matches the recorded InodeCache of a file. -}
sameFileStatus :: Key -> FileStatus -> Annex Bool sameFileStatus :: Key -> FilePath -> FileStatus -> Annex Bool
sameFileStatus key status = do sameFileStatus key f status = do
old <- recordedInodeCache key old <- recordedInodeCache key
let curr = toInodeCache status curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta f status
case (old, curr) of case (old, curr) of
(_, Just c) -> elemInodeCaches c old (_, Just c) -> elemInodeCaches c old
([], Nothing) -> return True ([], Nothing) -> return True
@ -206,7 +210,7 @@ addContentWhenNotPresent key contentfile associatedfile = do
v <- isAnnexLink associatedfile v <- isAnnexLink associatedfile
when (Just key == v) $ when (Just key == v) $
replaceFile associatedfile $ replaceFile associatedfile $
liftIO . void . copyFileExternal contentfile liftIO . void . copyFileExternal CopyAllMetaData contentfile
updateInodeCache key associatedfile updateInodeCache key associatedfile
{- Some filesystems get new inodes each time they are mounted. {- Some filesystems get new inodes each time they are mounted.
@ -217,40 +221,43 @@ addContentWhenNotPresent key contentfile associatedfile = do
- inodes have changed. - inodes have changed.
-} -}
inodesChanged :: Annex Bool inodesChanged :: Annex Bool
inodesChanged = maybe calc return =<< Annex.getState Annex.inodeschanged 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 where
calc = do check = do
scache <- liftIO . genInodeCache sc <- liftIO . checkSentinalFile =<< annexSentinalFile
=<< fromRepo gitAnnexInodeSentinal Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc }
scached <- readInodeSentinalFile return sc
let changed = case (scache, scached) of
(Just c1, Just c2) -> not $ compareStrong c1 c2
_ -> True
Annex.changeState $ \s -> s { Annex.inodeschanged = Just changed }
return changed
readInodeSentinalFile :: Annex (Maybe InodeCache)
readInodeSentinalFile = do
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
liftIO $ catchDefaultIO Nothing $
readInodeCache <$> readFile sentinalcachefile
writeInodeSentinalFile :: Annex ()
writeInodeSentinalFile = do
sentinalfile <- fromRepo gitAnnexInodeSentinal
createAnnexDirectory (parentDir sentinalfile)
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
liftIO $ writeFile sentinalfile ""
liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache)
=<< genInodeCache sentinalfile
{- The sentinal file is only created when first initializing a repository. {- The sentinal file is only created when first initializing a repository.
- If there are any annexed objects in the repository already, creating - If there are any annexed objects in the repository already, creating
- the file would invalidate their inode caches. -} - the file would invalidate their inode caches. -}
createInodeSentinalFile :: Annex () createInodeSentinalFile :: Annex ()
createInodeSentinalFile = createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do
unlessM (alreadyexists <||> hasobjects) s <- annexSentinalFile
writeInodeSentinalFile createAnnexDirectory (parentDir (sentinalFile s))
liftIO $ writeSentinalFile s
where where
alreadyexists = isJust <$> readInodeSentinalFile alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir
annexSentinalFile :: Annex SentinalFile
annexSentinalFile = do
sentinalfile <- fromRepo gitAnnexInodeSentinal
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
return $ SentinalFile
{ sentinalFile = sentinalfile
, sentinalCacheFile = sentinalcachefile
}

58
Annex/Difference.hs Normal file
View file

@ -0,0 +1,58 @@
{- git-annex repository differences
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- 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

86
Annex/DirHashes.hs Normal file
View file

@ -0,0 +1,86 @@
{- git-annex file locations
-
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -1,6 +1,6 @@
{- git-annex direct mode {- git-annex direct mode
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -32,8 +32,10 @@ import Utility.InodeCache
import Utility.CopyFile import Utility.CopyFile
import Annex.Perms import Annex.Perms
import Annex.ReplaceFile import Annex.ReplaceFile
import Annex.Exception
import Annex.VariantFile 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 {- 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. -} - them into the index. Returns True if some changes were staged. -}
@ -51,11 +53,12 @@ stageDirect = do
{- Determine what kind of modified or deleted file this is, as {- Determine what kind of modified or deleted file this is, as
- efficiently as we can, by getting any key that's associated - efficiently as we can, by getting any key that's associated
- with it in git, as well as its stat info. -} - with it in git, as well as its stat info. -}
go (file, Just sha, Just mode) = do go (file, Just sha, Just mode) = withTSDelta $ \delta -> do
shakey <- catKey sha mode shakey <- catKey sha mode
mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
mcache <- liftIO $ maybe (pure Nothing) (toInodeCache delta file) mstat
filekey <- isAnnexLink file filekey <- isAnnexLink file
case (shakey, filekey, mstat, toInodeCache =<< mstat) of case (shakey, filekey, mstat, mcache) of
(_, Just key, _, _) (_, Just key, _, _)
| shakey == filekey -> noop | shakey == filekey -> noop
{- A changed symlink. -} {- A changed symlink. -}
@ -83,7 +86,7 @@ stageDirect = do
deletegit file deletegit file
stageannexlink file key = do stageannexlink file key = do
l <- inRepo $ gitAnnexLink file key l <- calcRepo $ gitAnnexLink file key
stageSymlink file =<< hashSymlink l stageSymlink file =<< hashSymlink l
void $ addAssociatedFile key file void $ addAssociatedFile key file
@ -128,7 +131,7 @@ addDirect file cache = do
return False return False
got (Just (key, _)) = ifM (sameInodeCache file [cache]) got (Just (key, _)) = ifM (sameInodeCache file [cache])
( do ( do
l <- inRepo $ gitAnnexLink file key l <- calcRepo $ gitAnnexLink file key
stageSymlink file =<< hashSymlink l stageSymlink file =<< hashSymlink l
addInodeCache key cache addInodeCache key cache
void $ addAssociatedFile key file void $ addAssociatedFile key file
@ -141,21 +144,101 @@ addDirect file cache = do
) )
{- In direct mode, git merge would usually refuse to do anything, since it {- In direct mode, git merge would usually refuse to do anything, since it
- sees present direct mode files as type changed files. To avoid this, - sees present direct mode files as type changed files.
- merge is run with the work tree set to a temp directory. -
- 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 :: FilePath -> Git.Ref -> Git.Repo -> IO Bool mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool
mergeDirect d branch g = do mergeDirect startbranch oldref branch resolvemerge commitmode = exclusively $ do
whenM (doesDirectoryExist d) $ reali <- liftIO . absPath =<< fromRepo indexFile
removeDirectoryRecursive d tmpi <- liftIO . absPath =<< fromRepo indexFileLock
createDirectoryIfMissing True d liftIO $ copyFile reali tmpi
let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
Git.Merge.mergeNonInteractive branch g'
{- Cleans up after a direct mode merge. The merge must have been committed, d <- fromRepo gitAnnexMergeDir
- and the commit sha passed in, along with the old sha of the tree liftIO $ do
- before the merge. Uses git diff-tree to find files that changed between whenM (doesDirectoryExist d) $
- the two shas, and applies those changes to the work tree. 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.
-- <http://marc.info/?l=git&m=140262402204212&w=2>
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, - 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 - or a new item added. Two passes are made, first deleting and then
@ -164,9 +247,9 @@ mergeDirect d branch g = do
- order, but we cannot add the directory until the file with the - order, but we cannot add the directory until the file with the
- same name is removed.) - same name is removed.)
-} -}
mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex () updateWorkTree :: FilePath -> Git.Ref -> Annex ()
mergeDirectCleanup d oldsha newsha = do updateWorkTree d oldref = do
(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha (items, cleanup) <- inRepo $ DiffTree.diffIndex oldref
makeabs <- flip fromTopFilePath <$> gitRepo makeabs <- flip fromTopFilePath <$> gitRepo
let fsitems = zip (map (makeabs . DiffTree.file) items) items let fsitems = zip (map (makeabs . DiffTree.file) items) items
forM_ fsitems $ forM_ fsitems $
@ -174,12 +257,11 @@ mergeDirectCleanup d oldsha newsha = do
forM_ fsitems $ forM_ fsitems $
go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw
void $ liftIO cleanup void $ liftIO cleanup
liftIO $ removeDirectoryRecursive d
where where
go makeabs getsha getmode a araw (f, item) go makeabs getsha getmode a araw (f, item)
| getsha item == nullSha = noop | getsha item == nullSha = noop
| otherwise = void $ | otherwise = void $
tryAnnex . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f) tryNonAsync . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
=<< catKey (getsha item) (getmode item) =<< catKey (getsha item) (getmode item)
moveout _ _ = removeDirect moveout _ _ = removeDirect
@ -194,26 +276,26 @@ mergeDirectCleanup d oldsha newsha = do
- key, it's left alone. - key, it's left alone.
- -
- If the file is already present, and does not exist in the - If the file is already present, and does not exist in the
- oldsha branch, preserve this local file. - oldref, preserve this local file.
- -
- Otherwise, create the symlink and then if possible, replace it - Otherwise, create the symlink and then if possible, replace it
- with the content. -} - with the content. -}
movein item makeabs k f = unlessM (goodContent k f) $ do movein item makeabs k f = unlessM (goodContent k f) $ do
preserveUnannexed item makeabs f oldsha preserveUnannexed item makeabs f oldref
l <- inRepo $ gitAnnexLink f k l <- calcRepo $ gitAnnexLink f k
replaceFile f $ makeAnnexLink l replaceFile f $ makeAnnexLink l
toDirect k f toDirect k f
{- Any new, modified, or renamed files were written to the temp {- Any new, modified, or renamed files were written to the temp
- directory by the merge, and are moved to the real work tree. -} - directory by the merge, and are moved to the real work tree. -}
movein_raw item makeabs f = do movein_raw item makeabs f = do
preserveUnannexed item makeabs f oldsha preserveUnannexed item makeabs f oldref
liftIO $ do liftIO $ do
createDirectoryIfMissing True $ parentDir f createDirectoryIfMissing True $ parentDir f
void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
{- If the file that's being moved in is already present in the work {- If the file that's being moved in is already present in the work
- tree, but did not exist in the oldsha branch, preserve this - tree, but did not exist in the oldref, preserve this
- local, unannexed file (or directory), as "variant-local". - local, unannexed file (or directory), as "variant-local".
- -
- It's also possible that the file that's being moved in - It's also possible that the file that's being moved in
@ -221,15 +303,15 @@ mergeDirectCleanup d oldsha newsha = do
- file (not a directory), which should be preserved. - file (not a directory), which should be preserved.
-} -}
preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex () preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex ()
preserveUnannexed item makeabs absf oldsha = do preserveUnannexed item makeabs absf oldref = do
whenM (liftIO (collidingitem absf) <&&> unannexed absf) $ whenM (liftIO (collidingitem absf) <&&> unannexed absf) $
liftIO $ findnewname absf 0 liftIO $ findnewname absf 0
checkdirs (DiffTree.file item) checkdirs (DiffTree.file item)
where where
checkdirs from = do checkdirs from = case upFrom (getTopFilePath from) of
let p = parentDir (getTopFilePath from) Nothing -> noop
let d = asTopFilePath p Just p -> do
unless (null p) $ do let d = asTopFilePath p
let absd = makeabs d let absd = makeabs d
whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $ whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
liftIO $ findnewname absd 0 liftIO $ findnewname absd 0
@ -241,7 +323,7 @@ preserveUnannexed item makeabs absf oldsha = do
<$> catchMaybeIO (getSymbolicLinkStatus f) <$> catchMaybeIO (getSymbolicLinkStatus f)
unannexed f = (isNothing <$> isAnnexLink f) unannexed f = (isNothing <$> isAnnexLink f)
<&&> (isNothing <$> catFileDetails oldsha f) <&&> (isNothing <$> catFileDetails oldref f)
findnewname :: FilePath -> Int -> IO () findnewname :: FilePath -> Int -> IO ()
findnewname f n = do findnewname f n = do
@ -275,16 +357,17 @@ toDirectGen k f = do
(dloc:_) -> return $ Just $ fromdirect dloc (dloc:_) -> return $ Just $ fromdirect dloc
) )
where where
fromindirect loc = do fromindirect loc = do
{- Move content from annex to direct file. -} {- Move content from annex to direct file. -}
updateInodeCache k loc updateInodeCache k loc
void $ addAssociatedFile k f void $ addAssociatedFile k f
modifyContent loc $ do modifyContent loc $ do
thawContent loc thawContent loc
replaceFile f $ liftIO . moveFile loc liftIO (replaceFileFrom loc f)
`catchIO` (\_ -> freezeContent loc)
fromdirect loc = do fromdirect loc = do
replaceFile f $ replaceFile f $
liftIO . void . copyFileExternal loc liftIO . void . copyFileExternal CopyAllMetaData loc
updateInodeCache k f updateInodeCache k f
{- Removes a direct mode file, while retaining its content in the annex {- Removes a direct mode file, while retaining its content in the annex

View file

@ -1,6 +1,6 @@
{- git-annex direct mode guard fixup {- git-annex direct mode guard fixup
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- dropping of unwanted content {- dropping of unwanted content
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -16,7 +16,6 @@ import qualified Remote
import qualified Command.Drop import qualified Command.Drop
import Command import Command
import Annex.Wanted import Annex.Wanted
import Annex.Exception
import Config import Config
import Annex.Content.Direct import Annex.Content.Direct
@ -120,5 +119,5 @@ handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
slocs = S.fromList locs slocs = S.fromList locs
safely a = either (const False) id <$> tryAnnex a safely a = either (const False) id <$> tryNonAsync a

View file

@ -1,6 +1,6 @@
{- git-annex environment {- git-annex environment
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -13,11 +13,7 @@ import Common.Annex
import Utility.UserInfo import Utility.UserInfo
import qualified Git.Config import qualified Git.Config
import Config import Config
import Annex.Exception
#ifndef mingw32_HOST_OS
import Utility.Env import Utility.Env
#endif
{- Checks that the system's environment allows git to function. {- Checks that the system's environment allows git to function.
- Git requires a GECOS username, or suitable git configuration, or - Git requires a GECOS username, or suitable git configuration, or
@ -36,30 +32,27 @@ checkEnvironment = do
liftIO checkEnvironmentIO liftIO checkEnvironmentIO
checkEnvironmentIO :: IO () checkEnvironmentIO :: IO ()
checkEnvironmentIO = checkEnvironmentIO = whenM (isNothing <$> myUserGecos) $ do
#ifdef mingw32_HOST_OS username <- myUserName
noop ensureEnv "GIT_AUTHOR_NAME" username
#else ensureEnv "GIT_COMMITTER_NAME" username
whenM (null <$> myUserGecos) $ do
username <- myUserName
ensureEnv "GIT_AUTHOR_NAME" username
ensureEnv "GIT_COMMITTER_NAME" username
where where
#ifndef __ANDROID__ #ifndef __ANDROID__
-- existing environment is not overwritten -- existing environment is not overwritten
ensureEnv var val = void $ setEnv var val False ensureEnv var val = setEnv var val False
#else #else
-- Environment setting is broken on Android, so this is dealt with -- Environment setting is broken on Android, so this is dealt with
-- in runshell instead. -- in runshell instead.
ensureEnv _ _ = noop ensureEnv _ _ = noop
#endif #endif
#endif
{- Runs an action that commits to the repository, and if it fails, {- Runs an action that commits to the repository, and if it fails,
- sets user.email to a dummy value and tries the action again. -} - sets user.email and user.name to a dummy value and tries the action again. -}
ensureCommit :: Annex a -> Annex a ensureCommit :: Annex a -> Annex a
ensureCommit a = either retry return =<< tryAnnex a ensureCommit a = either retry return =<< tryNonAsync a
where where
retry _ = do retry _ = do
setConfig (ConfigKey "user.email") =<< liftIO myUserName name <- liftIO myUserName
setConfig (ConfigKey "user.name") name
setConfig (ConfigKey "user.email") name
a a

View file

@ -1,50 +0,0 @@
{- exception handling in the git-annex monad
-
- Note that when an Annex action fails and the exception is handled
- by these functions, any changes the action has made to the
- AnnexState are retained. This works because the Annex monad
- internally stores the AnnexState in a MVar.
-
- Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE PackageImports #-}
module Annex.Exception (
bracketIO,
bracketAnnex,
tryAnnex,
tryAnnexIO,
throwAnnex,
catchAnnex,
) where
import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
import Control.Exception
import Common.Annex
{- Runs an Annex action, with setup and cleanup both in the IO monad. -}
bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)
bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a
bracketAnnex = M.bracket
{- try in the Annex monad -}
tryAnnex :: Annex a -> Annex (Either SomeException a)
tryAnnex = M.try
{- try in the Annex monad, but only catching IO exceptions -}
tryAnnexIO :: Annex a -> Annex (Either IOException a)
tryAnnexIO = M.try
{- throw in the Annex monad -}
throwAnnex :: Exception e => e -> Annex a
throwAnnex = M.throw
{- catch in the Annex monad -}
catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a
catchAnnex = M.catch

View file

@ -1,6 +1,6 @@
{- git-annex file matching {- git-annex file matching
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -13,7 +13,6 @@ import Common.Annex
import Limit import Limit
import Utility.Matcher import Utility.Matcher
import Types.Group import Types.Group
import Types.Limit
import Logs.Group import Logs.Group
import Logs.Remote import Logs.Remote
import Annex.UUID import Annex.UUID
@ -25,18 +24,16 @@ import Types.Remote (RemoteConfig)
import Data.Either import Data.Either
import qualified Data.Set as S import qualified Data.Set as S
type FileMatcher = Matcher MatchFiles checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool
checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool
checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True
checkMatcher :: FileMatcher -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool checkMatcher :: (FileMatcher Annex) -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
checkMatcher matcher mkey afile notpresent def checkMatcher matcher mkey afile notpresent d
| isEmpty matcher = return def | isEmpty matcher = return d
| otherwise = case (mkey, afile) of | otherwise = case (mkey, afile) of
(_, Just file) -> go =<< fileMatchInfo file (_, Just file) -> go =<< fileMatchInfo file
(Just key, _) -> go (MatchingKey key) (Just key, _) -> go (MatchingKey key)
_ -> return def _ -> return d
where where
go mi = matchMrun matcher $ \a -> a notpresent mi go mi = matchMrun matcher $ \a -> a notpresent mi
@ -45,18 +42,18 @@ fileMatchInfo file = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
return $ MatchingFile FileInfo return $ MatchingFile FileInfo
{ matchFile = matchfile { matchFile = matchfile
, relFile = file , currFile = file
} }
matchAll :: FileMatcher matchAll :: FileMatcher Annex
matchAll = generate [] matchAll = generate []
parsedToMatcher :: [Either String (Token MatchFiles)] -> Either String FileMatcher parsedToMatcher :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex)
parsedToMatcher parsed = case partitionEithers parsed of parsedToMatcher parsed = case partitionEithers parsed of
([], vs) -> Right $ generate vs ([], vs) -> Right $ generate vs
(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
exprParser :: FileMatcher -> FileMatcher -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)] 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 = exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
map parse $ tokenizeMatcher expr map parse $ tokenizeMatcher expr
where where
@ -69,7 +66,7 @@ exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
preferreddir = fromMaybe "public" $ preferreddir = fromMaybe "public" $
M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
parseToken :: FileMatcher -> FileMatcher -> MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex))
parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t
| t `elem` tokens = Right $ token t | t `elem` tokens = Right $ token t
| t == "standard" = call matchstandard | t == "standard" = call matchstandard
@ -106,10 +103,10 @@ tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
{- Generates a matcher for files large enough (or meeting other criteria) {- Generates a matcher for files large enough (or meeting other criteria)
- to be added to the annex, rather than directly to git. -} - to be added to the annex, rather than directly to git. -}
largeFilesMatcher :: Annex FileMatcher largeFilesMatcher :: Annex (FileMatcher Annex)
largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
where where
go Nothing = return matchAll go Nothing = return matchAll
go (Just expr) = do go (Just expr) = do
gm <- groupMap gm <- groupMap
rc <- readRemoteLog rc <- readRemoteLog

View file

@ -4,7 +4,7 @@
- not change, otherwise removing old hooks using an old version of - not change, otherwise removing old hooks using an old version of
- the script would fail. - the script would fail.
- -
- Copyright 2013-2014 Joey Hess <joey@kitenet.net> - Copyright 2013-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -16,7 +16,6 @@ import qualified Git.Hook as Git
import Config import Config
import qualified Annex import qualified Annex
import Utility.Shell import Utility.Shell
import Utility.FileMode
import qualified Data.Map as M import qualified Data.Map as M
@ -53,19 +52,16 @@ hookWarning h msg = do
- the existing hooks are cached. -} - the existing hooks are cached. -}
runAnnexHook :: Git.Hook -> Annex () runAnnexHook :: Git.Hook -> Annex ()
runAnnexHook hook = do runAnnexHook hook = do
cmd <- fromRepo $ Git.hookFile hook
m <- Annex.getState Annex.existinghooks m <- Annex.getState Annex.existinghooks
case M.lookup hook m of case M.lookup hook m of
Just True -> run cmd Just True -> run
Just False -> noop Just False -> noop
Nothing -> do Nothing -> do
exists <- hookexists cmd exists <- inRepo $ Git.hookExists hook
Annex.changeState $ \s -> s Annex.changeState $ \s -> s
{ Annex.existinghooks = M.insert hook exists m } { Annex.existinghooks = M.insert hook exists m }
when exists $ when exists run
run cmd
where where
hookexists f = liftIO $ catchBoolIO $ run = unlessM (inRepo $ Git.runHook hook) $ do
isExecutable . fileMode <$> getFileStatus f h <- fromRepo $ Git.hookFile hook
run cmd = unlessM (liftIO $ boolSystem cmd []) $ warning $ h ++ " failed"
warning $ cmd ++ " failed"

View file

@ -1,6 +1,6 @@
{- Using other git index files {- Using other git index files
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -9,6 +9,7 @@
module Annex.Index ( module Annex.Index (
withIndexFile, withIndexFile,
addGitEnv,
) where ) where
import qualified Control.Exception as E import qualified Control.Exception as E
@ -17,30 +18,35 @@ import Common.Annex
import Git.Types import Git.Types
import qualified Annex import qualified Annex
import Utility.Env import Utility.Env
import Annex.Exception
{- Runs an action using a different git index file. -} {- Runs an action using a different git index file. -}
withIndexFile :: FilePath -> Annex a -> Annex a withIndexFile :: FilePath -> Annex a -> Annex a
withIndexFile f a = do withIndexFile f a = do
g <- gitRepo g <- gitRepo
#ifdef __ANDROID__ g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f
{- This should not be necessary on Android, but there is some
- weird getEnvironment breakage. See
- https://github.com/neurocyte/ghc-android/issues/7
- Use getEnv to get some key environment variables that
- git expects to have. -}
let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
let e' = ("GIT_INDEX_FILE", f):e
#else
e <- liftIO getEnvironment
let e' = addEntry "GIT_INDEX_FILE" f e
#endif
let g' = g { gitEnv = Just e' }
r <- tryAnnex $ do r <- tryNonAsync $ do
Annex.changeState $ \s -> s { Annex.repo = g' } Annex.changeState $ \s -> s { Annex.repo = g' }
a a
Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} } Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
either E.throw return r 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

View file

@ -1,6 +1,6 @@
{- git-annex repository initialization {- git-annex repository initialization
- -
- Copyright 2011 Joey Hess <joey@kitenet.net> - Copyright 2011 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -11,44 +11,41 @@ module Annex.Init (
ensureInitialized, ensureInitialized,
isInitialized, isInitialized,
initialize, initialize,
initialize',
uninitialize, uninitialize,
probeCrippledFileSystem, probeCrippledFileSystem,
) where ) where
import Common.Annex import Common.Annex
import Utility.Network
import qualified Annex import qualified Annex
import qualified Git import qualified Git
import qualified Git.LsFiles import qualified Git.LsFiles
import qualified Git.Config import qualified Git.Config
import qualified Git.Construct import qualified Git.Objects
import qualified Git.Types as Git
import qualified Annex.Branch import qualified Annex.Branch
import Logs.UUID import Logs.UUID
import Logs.Trust.Basic
import Types.TrustLevel
import Annex.Version import Annex.Version
import Annex.Difference
import Annex.UUID import Annex.UUID
import Config import Config
import Annex.Direct import Annex.Direct
import Annex.Content.Direct import Annex.Content.Direct
import Annex.Environment import Annex.Environment
import Annex.Perms
import Backend import Backend
import Annex.Hook
import Upgrade
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Utility.UserInfo import Utility.UserInfo
import Utility.FileMode import Utility.FileMode
import Annex.Perms
#endif #endif
import Annex.Hook
import Git.Hook (hookFile)
import Upgrade
import Annex.Content
import Logs.Location
import System.Log.Logger
genDescription :: Maybe String -> Annex String genDescription :: Maybe String -> Annex String
genDescription (Just d) = return d genDescription (Just d) = return d
genDescription Nothing = do genDescription Nothing = do
reldir <- liftIO . relHome =<< fromRepo Git.repoPath reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath
hostname <- fromMaybe "" <$> liftIO getHostname hostname <- fromMaybe "" <$> liftIO getHostname
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
let at = if null hostname then "" else "@" let at = if null hostname then "" else "@"
@ -61,10 +58,23 @@ genDescription Nothing = do
initialize :: Maybe String -> Annex () initialize :: Maybe String -> Annex ()
initialize mdescription = do initialize mdescription = do
prepUUID 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 checkFifoSupport
checkCrippledFileSystem checkCrippledFileSystem
unlessM isBare $ unlessM isBare $
hookWrite preCommitHook hookWrite preCommitHook
setDifferences
setVersion supportedVersion setVersion supportedVersion
ifM (crippledFileSystem <&&> not <$> isBare) ifM (crippledFileSystem <&&> not <$> isBare)
( do ( do
@ -76,12 +86,7 @@ initialize mdescription = do
switchHEADBack switchHEADBack
) )
createInodeSentinalFile createInodeSentinalFile
u <- getUUID checkSharedClone
{- 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
uninitialize :: Annex () uninitialize :: Annex ()
uninitialize = do uninitialize = do
@ -97,9 +102,7 @@ uninitialize = do
- Checks repository version and handles upgrades too. - Checks repository version and handles upgrades too.
-} -}
ensureInitialized :: Annex () ensureInitialized :: Annex ()
ensureInitialized = do ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
getVersion >>= maybe needsinit checkUpgrade
fixBadBare
where where
needsinit = ifM Annex.Branch.hasSibling needsinit = ifM Annex.Branch.hasSibling
( initialize Nothing ( initialize Nothing
@ -184,56 +187,9 @@ enableDirectMode = unlessM isDirect $ do
maybe noop (`toDirect` f) =<< isAnnexLink f maybe noop (`toDirect` f) =<< isAnnexLink f
void $ liftIO clean void $ liftIO clean
{- Work around for git-annex version 5.20131118 - 5.20131127, which checkSharedClone :: Annex ()
- had a bug that unset core.bare when initializing a bare repository. checkSharedClone = whenM (inRepo Git.Objects.isSharedClone) $ do
- showSideAction "Repository was cloned with --shared; setting annex.hardlink=true and making repository untrusted."
- This resulted in objects sent to the repository being stored in u <- getUUID
- repo/.git/annex/objects, so move them to repo/annex/objects. trustSet u UnTrusted
- setConfig (annexConfig "hardlink") (Git.Config.boolConfig True)
- This check slows down every git-annex run somewhat (by one file stat),
- so should be removed after a suitable period of time has passed.
- Since the bare repository may be on an offline USB drive, best to
- keep it for a while. However, git-annex was only buggy for a few
- weeks, so not too long.
-}
fixBadBare :: Annex ()
fixBadBare = whenM checkBadBare $ do
ks <- getKeysPresent InAnnex
liftIO $ debugM "Init" $ unwords
[ "Detected bad bare repository with"
, show (length ks)
, "objects; fixing"
]
g <- Annex.gitRepo
gc <- Annex.getGitConfig
d <- Git.repoPath <$> Annex.gitRepo
void $ liftIO $ boolSystem "git"
[ Param $ "--git-dir=" ++ d
, Param "config"
, Param Git.Config.coreBare
, Param $ Git.Config.boolConfig True
]
g' <- liftIO $ Git.Construct.fromPath d
s' <- liftIO $ Annex.new $ g' { Git.location = Git.Local { Git.gitdir = d, Git.worktree = Nothing } }
Annex.changeState $ \s -> s
{ Annex.repo = Annex.repo s'
, Annex.gitconfig = Annex.gitconfig s'
}
forM_ ks $ \k -> do
oldloc <- liftIO $ gitAnnexLocation k g gc
thawContentDir oldloc
moveAnnex k oldloc
logStatus k InfoPresent
let dotgit = d </> ".git"
liftIO $ removeDirectoryRecursive dotgit
`catchIO` const (renameDirectory dotgit (d </> "removeme"))
{- A repostory with the problem won't know it's a bare repository, but will
- have no pre-commit hook (which is not set up in a bare repository),
- and will not have a HEAD file in its .git directory. -}
checkBadBare :: Annex Bool
checkBadBare = allM (not <$>)
[isBare, hasPreCommitHook, hasDotGitHEAD]
where
hasPreCommitHook = inRepo $ doesFileExist . hookFile preCommitHook
hasDotGitHEAD = inRepo $ \r -> doesFileExist $ Git.localGitDir r </> "HEAD"

View file

@ -4,7 +4,7 @@
- git-annex branch. Among other things, it ensures that if git-annex is - git-annex branch. Among other things, it ensures that if git-annex is
- interrupted, its recorded data is not lost. - interrupted, its recorded data is not lost.
- -
- Copyright 2011-2013 Joey Hess <joey@kitenet.net> - Copyright 2011-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -13,16 +13,10 @@
module Annex.Journal where module Annex.Journal where
import System.IO.Binary
import Common.Annex import Common.Annex
import Annex.Exception
import qualified Git import qualified Git
import Annex.Perms import Annex.Perms
import Annex.LockFile
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif
{- Records content for a file in the branch to the journal. {- Records content for a file in the branch to the journal.
- -
@ -42,7 +36,12 @@ setJournalFile _jl file content = do
jfile <- fromRepo $ journalFile file jfile <- fromRepo $ journalFile file
let tmpfile = tmp </> takeFileName jfile let tmpfile = tmp </> takeFileName jfile
liftIO $ do liftIO $ do
writeBinaryFile tmpfile content withFile tmpfile WriteMode $ \h -> do
fileEncoding h
#ifdef mingw32_HOST_OS
hSetNewlineMode h noNewlineTranslation
#endif
hPutStr h content
moveFile tmpfile jfile moveFile tmpfile jfile
{- Gets any journalled content for a file in the branch. -} {- Gets any journalled content for a file in the branch. -}
@ -54,7 +53,7 @@ getJournalFile _jl = getJournalFileStale
- changes. -} - changes. -}
getJournalFileStale :: FilePath -> Annex (Maybe String) getJournalFileStale :: FilePath -> Annex (Maybe String)
getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
readFileStrict $ journalFile file g readFileStrictAnyEncoding $ journalFile file g
{- List of files that have updated content in the journal. -} {- List of files that have updated content in the journal. -}
getJournalledFiles :: JournalLocked -> Annex [FilePath] getJournalledFiles :: JournalLocked -> Annex [FilePath]
@ -77,9 +76,18 @@ getJournalFilesStale = do
getDirectoryContents $ gitAnnexJournalDir g getDirectoryContents $ gitAnnexJournalDir g
return $ filter (`notElem` [".", ".."]) fs 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. -} {- Checks if there are changes in the journal. -}
journalDirty :: Annex Bool journalDirty :: Annex Bool
journalDirty = not . null <$> getJournalFilesStale 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. {- Produces a filename to use in the journal for a file on the branch.
- -
@ -109,19 +117,4 @@ data JournalLocked = ProduceJournalLocked
{- Runs an action that modifies the journal, using locking to avoid {- Runs an action that modifies the journal, using locking to avoid
- contention with other git-annex processes. -} - contention with other git-annex processes. -}
lockJournal :: (JournalLocked -> Annex a) -> Annex a lockJournal :: (JournalLocked -> Annex a) -> Annex a
lockJournal a = do lockJournal a = withExclusiveLock gitAnnexJournalLock $ a ProduceJournalLocked
lockfile <- fromRepo gitAnnexJournalLock
createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
bracketIO (lock lockfile mode) unlock (const $ a ProduceJournalLocked)
where
#ifndef mingw32_HOST_OS
lock lockfile mode = do
l <- noUmask mode $ createFile lockfile mode
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
return l
unlock = closeFd
#else
lock lockfile _mode = waitToLock $ lockExclusive lockfile
unlock = dropLock
#endif

View file

@ -5,7 +5,7 @@
- On other filesystems, git instead stores the symlink target in a regular - On other filesystems, git instead stores the symlink target in a regular
- file. - file.
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -35,13 +35,17 @@ isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget
- content. - content.
-} -}
getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget) getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig) getAnnexLinkTarget f = getAnnexLinkTarget' f
( check readSymbolicLink $ =<< (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 return Nothing
, check readSymbolicLink $ else check readSymbolicLink $
check probefilecontent $ check probefilecontent $
return Nothing return Nothing
)
where where
check getlinktarget fallback = do check getlinktarget fallback = do
v <- liftIO $ catchMaybeIO $ getlinktarget file v <- liftIO $ catchMaybeIO $ getlinktarget file
@ -68,6 +72,9 @@ getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
then "" then ""
else s else s
makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
makeAnnexLink = makeGitLink
{- Creates a link on disk. {- Creates a link on disk.
- -
- On a filesystem that does not support symlinks, writes the link target - On a filesystem that does not support symlinks, writes the link target
@ -75,8 +82,8 @@ getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
- it's staged as such, so use addAnnexLink when adding a new file or - it's staged as such, so use addAnnexLink when adding a new file or
- modified link to git. - modified link to git.
-} -}
makeAnnexLink :: LinkTarget -> FilePath -> Annex () makeGitLink :: LinkTarget -> FilePath -> Annex ()
makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do ( liftIO $ do
void $ tryIO $ removeFile file void $ tryIO $ removeFile file
createSymbolicLink linktarget file createSymbolicLink linktarget file

72
Annex/LockFile.hs Normal file
View file

@ -0,0 +1,72 @@
{- git-annex lock files.
-
- Copyright 2012, 2014 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -1,60 +0,0 @@
{- git-annex lock pool
-
- Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.LockPool where
import Common.Annex
import Annex
import Types.LockPool
import qualified Data.Map as M
#ifndef mingw32_HOST_OS
import Annex.Perms
#else
import Utility.WinLock
#endif
{- Create a specified lock file, and takes a shared lock. -}
lockFile :: FilePath -> Annex ()
lockFile file = go =<< fromPool file
where
go (Just _) = noop -- already locked
go Nothing = do
#ifndef mingw32_HOST_OS
mode <- annexFileMode
lockhandle <- liftIO $ noUmask mode $
openFd file ReadOnly (Just mode) defaultFileFlags
liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
#else
lockhandle <- liftIO $ waitToLock $ lockShared file
#endif
changePool $ M.insert file lockhandle
unlockFile :: FilePath -> Annex ()
unlockFile file = maybe noop go =<< fromPool file
where
go lockhandle = do
#ifndef mingw32_HOST_OS
liftIO $ closeFd lockhandle
#else
liftIO $ dropLock lockhandle
#endif
changePool $ M.delete file
getPool :: Annex LockPool
getPool = getState lockpool
fromPool :: FilePath -> Annex (Maybe LockHandle)
fromPool file = M.lookup file <$> getPool
changePool :: (LockPool -> LockPool) -> Annex ()
changePool a = do
m <- getPool
changeState $ \s -> s { lockpool = a m }

88
Annex/MakeRepo.hs Normal file
View file

@ -0,0 +1,88 @@
{- making local repositories (used by webapp mostly)
-
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
- 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)

View file

@ -1,12 +1,13 @@
{- git-annex metadata {- git-annex metadata
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
module Annex.MetaData ( module Annex.MetaData (
genMetaData, genMetaData,
dateMetaData,
module X module X
) where ) where
@ -37,20 +38,18 @@ genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
genMetaData key file status = do genMetaData key file status = do
maybe noop (flip copyMetaData key) =<< catKeyFileHEAD file maybe noop (flip copyMetaData key) =<< catKeyFileHEAD file
whenM (annexGenMetaData <$> Annex.getGitConfig) $ do whenM (annexGenMetaData <$> Annex.getGitConfig) $ do
metadata <- getCurrentMetaData key curr <- getCurrentMetaData key
let metadata' = genMetaData' status metadata addMetaData key (dateMetaData mtime curr)
unless (metadata' == emptyMetaData) $ where
addMetaData key metadata' mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status
{- Generates metadata from the FileStatus. {- Generates metadata for a file's date stamp.
- Does not overwrite any existing metadata values. -} - Does not overwrite any existing metadata values. -}
genMetaData' :: FileStatus -> MetaData -> MetaData dateMetaData :: UTCTime -> MetaData -> MetaData
genMetaData' status old = MetaData $ M.fromList $ filter isnew dateMetaData mtime old = MetaData $ M.fromList $ filter isnew
[ (yearMetaField, S.singleton $ toMetaValue $ show y) [ (yearMetaField, S.singleton $ toMetaValue $ show y)
, (monthMetaField, S.singleton $ toMetaValue $ show m) , (monthMetaField, S.singleton $ toMetaValue $ show m)
] ]
where where
isnew (f, _) = S.null (currentMetaDataValues f old) isnew (f, _) = S.null (currentMetaDataValues f old)
(y, m, _d) = toGregorian $ utctDay $ (y, m, _d) = toGregorian $ utctDay $ mtime
posixSecondsToUTCTime $ realToFrac $
modificationTime status

View file

@ -1,6 +1,6 @@
{- git-annex metadata, standard fields {- git-annex metadata, standard fields
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

101
Annex/Notification.hs Normal file
View file

@ -0,0 +1,101 @@
{- git-annex desktop notifications
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -1,6 +1,6 @@
{- git-annex program path {- git-annex program path
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex file permissions {- git-annex file permissions
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -21,7 +21,6 @@ import Common.Annex
import Utility.FileMode import Utility.FileMode
import Git.SharedRepository import Git.SharedRepository
import qualified Annex import qualified Annex
import Annex.Exception
import Config import Config
import System.Posix.Types import System.Posix.Types
@ -120,6 +119,6 @@ createContentDir dest = do
modifyContent :: FilePath -> Annex a -> Annex a modifyContent :: FilePath -> Annex a -> Annex a
modifyContent f a = do modifyContent f a = do
createContentDir f -- also thaws it createContentDir f -- also thaws it
v <- tryAnnex a v <- tryNonAsync a
freezeContentDir f freezeContentDir f
either throwAnnex return v either throwM return v

View file

@ -1,6 +1,6 @@
{- git-annex command queue {- git-annex command queue
- -
- Copyright 2011, 2012 Joey Hess <joey@kitenet.net> - Copyright 2011, 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- quvi options for git-annex {- quvi options for git-annex
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex file replacing {- git-annex file replacing
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -9,7 +9,6 @@ module Annex.ReplaceFile where
import Common.Annex import Common.Annex
import Annex.Perms import Annex.Perms
import Annex.Exception
{- Replaces a possibly already existing file with a new version, {- Replaces a possibly already existing file with a new version,
- atomically, by running an action. - atomically, by running an action.
@ -23,17 +22,29 @@ import Annex.Exception
- Throws an IO exception when it was unable to replace the file. - Throws an IO exception when it was unable to replace the file.
-} -}
replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex () replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
replaceFile file a = do 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 tmpdir <- fromRepo gitAnnexTmpMiscDir
void $ createAnnexDirectory tmpdir void $ createAnnexDirectory tmpdir
bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do tmpfile <- liftIO $ setup tmpdir
a tmpfile go tmpfile `catchNonAsync` (const $ rollback tmpfile)
liftIO $ catchIO (rename tmpfile file) (fallback tmpfile)
where where
setup tmpdir = do setup tmpdir = do
(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp" (tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
hClose h hClose h
return tmpfile return tmpfile
fallback tmpfile _ = do go tmpfile = do
createDirectoryIfMissing True $ parentDir file action tmpfile
moveFile tmpfile file 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

View file

@ -1,6 +1,6 @@
{- git-annex ssh interface, with connection caching {- git-annex ssh interface, with connection caching
- -
- Copyright 2012,2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2015 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -8,50 +8,59 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Annex.Ssh ( module Annex.Ssh (
sshCachingOptions, sshOptions,
sshCacheDir, sshCacheDir,
sshReadPort, sshReadPort,
forceSshCleanup,
sshOptionsEnv,
sshOptionsTo,
inRepoWithSshOptionsTo,
runSshOptions,
sshAskPassEnv,
runSshAskPass
) where ) where
import qualified Data.Map as M import qualified Data.Map as M
import Data.Hash.MD5 import Data.Hash.MD5
import System.Process (cwd) import System.Exit
import Common.Annex import Common.Annex
import Annex.LockPool import Annex.LockFile
import qualified Build.SysConfig as SysConfig import qualified Build.SysConfig as SysConfig
import qualified Annex import qualified Annex
import qualified Git
import qualified Git.Url
import Config import Config
import Config.Files
import Utility.Env import Utility.Env
import Types.CleanupActions import Types.CleanupActions
import Annex.Index (addGitEnv)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Annex.Perms import Annex.Perms
import Utility.LockFile
#endif #endif
{- Generates parameters to ssh to a given host (or user@host) on a given {- Generates parameters to ssh to a given host (or user@host) on a given
- port, with connection caching. -} - port. This includes connection caching parameters, and any ssh-options. -}
sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam] sshOptions :: (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
sshCachingOptions (host, port) opts = do sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port)
Annex.addCleanup SshCachingCleanup sshCleanup
go =<< sshInfo (host, port)
where where
go (Nothing, params) = ret params go (Nothing, params) = ret params
go (Just socketfile, params) = do go (Just socketfile, params) = do
cleanstale prepSocket socketfile
liftIO $ createDirectoryIfMissing True $ parentDir socketfile
lockFile $ socket2lock socketfile
ret params ret params
ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"] ret ps = return $ concat
-- If the lock pool is empty, this is the first ssh of this [ ps
-- run. There could be stale ssh connections hanging around , map Param (remoteAnnexSshOptions gc)
-- from a previous git-annex run that was interrupted. , opts
cleanstale = whenM (not . any isLock . M.keys <$> getPool) , portParams port
sshCleanup , [Param "-T"]
]
{- Returns a filename to use for a ssh connection caching socket, and {- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -} - parameters to enable ssh connection caching. -}
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshCachingInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
sshInfo (host, port) = go =<< sshCacheDir sshCachingInfo (host, port) = go =<< sshCacheDir
where where
go Nothing = return (Nothing, []) go Nothing = return (Nothing, [])
go (Just dir) = do go (Just dir) = do
@ -75,10 +84,10 @@ bestSocketPath abssocketfile = do
then Just socketfile then Just socketfile
else Nothing else Nothing
where where
-- ssh appends a 16 char extension to the socket when setting it -- ssh appends a 16 char extension to the socket when setting it
-- up, which needs to be taken into account when checking -- up, which needs to be taken into account when checking
-- that a valid socket was constructed. -- that a valid socket was constructed.
sshgarbage = replicate (1+16) 'X' sshgarbage = replicate (1+16) 'X'
sshConnectionCachingParams :: FilePath -> [CommandParam] sshConnectionCachingParams :: FilePath -> [CommandParam]
sshConnectionCachingParams socketfile = sshConnectionCachingParams socketfile =
@ -102,55 +111,79 @@ sshCacheDir
where where
gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR" gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
usetmpdir tmpdir = liftIO $ catchMaybeIO $ do usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
createDirectoryIfMissing True tmpdir let socktmp = tmpdir </> "ssh"
return tmpdir createDirectoryIfMissing True socktmp
return socktmp
portParams :: Maybe Integer -> [CommandParam] portParams :: Maybe Integer -> [CommandParam]
portParams Nothing = [] portParams Nothing = []
portParams (Just port) = [Param "-p", Param $ show port] portParams (Just port) = [Param "-p", Param $ show port]
{- Stop any unused ssh processes. -} {- Prepare to use a socket file. Locks a lock file to prevent
sshCleanup :: Annex () - other git-annex processes from stopping the ssh on this socket. -}
sshCleanup = go =<< sshCacheDir 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 where
go Nothing = noop
go (Just dir) = do
sockets <- liftIO $ filter (not . isLock)
<$> catchDefaultIO [] (dirContents dir)
forM_ sockets cleanup
cleanup socketfile = do cleanup socketfile = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
-- Drop any shared lock we have, and take an -- Drop any shared lock we have, and take an
-- exclusive lock, without blocking. If the lock -- exclusive lock, without blocking. If the lock
-- succeeds, nothing is using this ssh, and it can -- succeeds, nothing is using this ssh, and it can
-- be stopped. -- 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 let lockfile = socket2lock socketfile
unlockFile lockfile unlockFile lockfile
mode <- annexFileMode mode <- annexFileMode
fd <- liftIO $ noUmask mode $ v <- liftIO $ noUmask mode $ tryLockExclusive (Just mode) lockfile
openFd lockfile ReadWrite (Just mode) defaultFileFlags
v <- liftIO $ tryIO $
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of case v of
Left _ -> noop Nothing -> noop
Right _ -> stopssh socketfile Just lck -> do
liftIO $ closeFd fd forceStopSsh socketfile
liftIO $ dropLock lck
#else #else
stopssh socketfile forceStopSsh socketfile
#endif #endif
stopssh socketfile = do
let (dir, base) = splitFileName socketfile {- Stop all ssh connection caching processes, even when they're in use. -}
let params = sshConnectionCachingParams base forceSshCleanup :: Annex ()
-- "ssh -O stop" is noisy on stderr even with -q forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
void $ liftIO $ catchMaybeIO $
withQuietOutput createProcessSuccess $ forceStopSsh :: FilePath -> Annex ()
(proc "ssh" $ toCommand $ forceStopSsh socketfile = do
[ Params "-O stop" let (dir, base) = splitFileName socketfile
] ++ params ++ [Param "localhost"]) let params = sshConnectionCachingParams base
{ cwd = Just dir } -- "ssh -O stop" is noisy on stderr even with -q
liftIO $ nukeFile socketfile void $ liftIO $ catchMaybeIO $
-- Cannot remove the lock file; other processes may withQuietOutput createProcessSuccess $
-- be waiting on our exclusive lock to use it. (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 {- 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 - of the path to a socket file. At the same time, it needs to be unique
@ -199,3 +232,70 @@ sshReadPort params = (port, reverse args)
aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
| otherwise = aux (p,q:ps) rest | otherwise = aux (p,q:ps) rest
readPort p = fmap fst $ listToMaybe $ reads p 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

View file

@ -1,6 +1,6 @@
{- git-annex tagged pushes {- git-annex tagged pushes
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -49,13 +49,13 @@ fromTaggedBranch b = case split "/" $ Git.fromRef b of
taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
taggedPush u info branch remote = Git.Command.runBool taggedPush u info branch remote = Git.Command.runBool
[ Param "push" [ Param "push"
, Param $ Remote.name remote , Param $ Remote.name remote
{- Using forcePush here is safe because we "own" the tagged branch {- Using forcePush here is safe because we "own" the tagged branch
- we're pushing; it has no other writers. Ensures it is pushed - we're pushing; it has no other writers. Ensures it is pushed
- even if it has been rewritten by a transition. -} - even if it has been rewritten by a transition. -}
, Param $ Git.Branch.forcePush $ refspec Annex.Branch.name , Param $ Git.Branch.forcePush $ refspec Annex.Branch.name
, Param $ refspec branch , Param $ refspec branch
] ]
where where
refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b) refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)

145
Annex/Transfer.hs Normal file
View file

@ -0,0 +1,145 @@
{- git-annex transfers
-
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -6,7 +6,7 @@
- UUIDs of remotes are cached in git config, using keys named - UUIDs of remotes are cached in git config, using keys named
- remote.<name>.annex-uuid - remote.<name>.annex-uuid
- -
- Copyright 2010-2013 Joey Hess <joey@kitenet.net> - Copyright 2010-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -21,7 +21,10 @@ module Annex.UUID (
gCryptNameSpace, gCryptNameSpace,
removeRepoUUID, removeRepoUUID,
storeUUID, storeUUID,
storeUUIDIn,
setUUID, setUUID,
webUUID,
bitTorrentUUID,
) where ) where
import Common.Annex import Common.Annex
@ -70,7 +73,7 @@ getRepoUUID r = do
where where
updatecache u = do updatecache u = do
g <- gitRepo g <- gitRepo
when (g /= r) $ storeUUID cachekey u when (g /= r) $ storeUUIDIn cachekey u
cachekey = remoteConfig r "uuid" cachekey = remoteConfig r "uuid"
removeRepoUUID :: Annex () removeRepoUUID :: Annex ()
@ -84,13 +87,24 @@ getUncachedUUID = toUUID . Git.Config.get key ""
{- Make sure that the repo has an annex.uuid setting. -} {- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex () prepUUID :: Annex ()
prepUUID = whenM ((==) NoUUID <$> getUUID) $ prepUUID = whenM ((==) NoUUID <$> getUUID) $
storeUUID configkey =<< liftIO genUUID storeUUID =<< liftIO genUUID
storeUUID :: ConfigKey -> UUID -> Annex () storeUUID :: UUID -> Annex ()
storeUUID configfield = setConfig configfield . fromUUID storeUUID = storeUUIDIn configkey
storeUUIDIn :: ConfigKey -> UUID -> Annex ()
storeUUIDIn configfield = setConfig configfield . fromUUID
{- Only sets the configkey in the Repo; does not change .git/config -} {- Only sets the configkey in the Repo; does not change .git/config -}
setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID :: Git.Repo -> UUID -> IO Git.Repo
setUUID r u = do setUUID r u = do
let s = show configkey ++ "=" ++ fromUUID u let s = show configkey ++ "=" ++ fromUUID u
Git.Config.store s r 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"

View file

@ -1,7 +1,7 @@
{- Url downloading, with git-annex user agent and configured http {- Url downloading, with git-annex user agent and configured http
- headers and wget/curl options. - headers and wget/curl options.
- -
- Copyright 2013-2014 Joey Hess <joey@kitenet.net> - Copyright 2013-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -26,7 +26,7 @@ getUserAgent = Annex.getState $
Just . fromMaybe defaultUserAgent . Annex.useragent Just . fromMaybe defaultUserAgent . Annex.useragent
getUrlOptions :: Annex U.UrlOptions getUrlOptions :: Annex U.UrlOptions
getUrlOptions = U.UrlOptions getUrlOptions = mkUrlOptions
<$> getUserAgent <$> getUserAgent
<*> headers <*> headers
<*> options <*> options

View file

@ -1,6 +1,6 @@
{- git-annex .variant files for automatic merge conflict resolution {- git-annex .variant files for automatic merge conflict resolution
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex repository versioning {- git-annex repository versioning
- -
- Copyright 2010,2013 Joey Hess <joey@kitenet.net> - Copyright 2010,2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- metadata based branch views {- metadata based branch views
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -102,7 +102,7 @@ refineView origview = checksize . calc Unchanged origview
let (components', viewchanges) = runWriter $ let (components', viewchanges) = runWriter $
mapM (\c -> updateViewComponent c field vf) (viewComponents view) mapM (\c -> updateViewComponent c field vf) (viewComponents view)
viewchange = if field `elem` map viewField (viewComponents origview) viewchange = if field `elem` map viewField (viewComponents origview)
then maximum viewchanges then maximum viewchanges
else Narrowing else Narrowing
in (view { viewComponents = components' }, viewchange) in (view { viewComponents = components' }, viewchange)
| otherwise = | otherwise =
@ -207,7 +207,7 @@ viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
viewComponentMatcher viewcomponent = \metadata -> viewComponentMatcher viewcomponent = \metadata ->
matcher (currentMetaDataValues metafield metadata) matcher (currentMetaDataValues metafield metadata)
where where
metafield = viewField viewcomponent metafield = viewField viewcomponent
matcher = case viewFilter viewcomponent of matcher = case viewFilter viewcomponent of
FilterValues s -> \values -> setmatches $ FilterValues s -> \values -> setmatches $
S.intersection s values S.intersection s values
@ -236,8 +236,8 @@ toViewPath = concatMap escapeslash . fromMetaValue
fromViewPath :: FilePath -> MetaValue fromViewPath :: FilePath -> MetaValue
fromViewPath = toMetaValue . deescapeslash [] fromViewPath = toMetaValue . deescapeslash []
where where
deescapeslash s [] = reverse s deescapeslash s [] = reverse s
deescapeslash s (c:cs) deescapeslash s (c:cs)
| c == pseudoSlash = case cs of | c == pseudoSlash = case cs of
(c':cs') (c':cs')
| c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs' | c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
@ -340,19 +340,21 @@ applyView' mkviewedfile getfilemetadata view = do
genViewBranch view $ do genViewBranch view $ do
uh <- inRepo Git.UpdateIndex.startUpdateIndex uh <- inRepo Git.UpdateIndex.startUpdateIndex
hasher <- inRepo hashObjectStart hasher <- inRepo hashObjectStart
forM_ l $ \f -> forM_ l $ \f -> do
go uh hasher f =<< Backend.lookupFile f relf <- getTopFilePath <$> inRepo (toTopFilePath f)
go uh hasher relf =<< Backend.lookupFile f
liftIO $ do liftIO $ do
hashObjectStop hasher hashObjectStop hasher
void $ stopUpdateIndex uh void $ stopUpdateIndex uh
void clean void clean
where where
genviewedfiles = viewedFiles view mkviewedfile -- enables memoization genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
go uh hasher f (Just (k, _)) = do go uh hasher f (Just k) = do
metadata <- getCurrentMetaData k metadata <- getCurrentMetaData k
let metadata' = getfilemetadata f `unionMetaData` metadata let metadata' = getfilemetadata f `unionMetaData` metadata
forM_ (genviewedfiles f metadata') $ \fv -> do forM_ (genviewedfiles f metadata') $ \fv -> do
stagesymlink uh hasher fv =<< inRepo (gitAnnexLink fv k) f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv
stagesymlink uh hasher f' =<< calcRepo (gitAnnexLink f' k)
go uh hasher f Nothing go uh hasher f Nothing
| "." `isPrefixOf` f = do | "." `isPrefixOf` f = do
s <- liftIO $ getSymbolicLinkStatus f s <- liftIO $ getSymbolicLinkStatus f
@ -410,19 +412,19 @@ withViewChanges addmeta removemeta = do
where where
handleremovals item handleremovals item
| DiffTree.srcsha item /= nullSha = | DiffTree.srcsha item /= nullSha =
handle item removemeta handlechange item removemeta
=<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item) =<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
| otherwise = noop | otherwise = noop
handleadds makeabs item handleadds makeabs item
| DiffTree.dstsha item /= nullSha = | DiffTree.dstsha item /= nullSha =
handle item addmeta handlechange item addmeta
=<< ifM isDirect =<< ifM isDirect
( catKey (DiffTree.dstsha item) (DiffTree.dstmode item) ( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
-- optimisation -- optimisation
, isAnnexLink $ makeabs $ DiffTree.file item , isAnnexLink $ makeabs $ DiffTree.file item
) )
| otherwise = noop | otherwise = noop
handle item a = maybe noop handlechange item a = maybe noop
(void . commandAction . a (getTopFilePath $ DiffTree.file item)) (void . commandAction . a (getTopFilePath $ DiffTree.file item))
{- Generates a branch for a view. This is done using a different index {- Generates a branch for a view. This is done using a different index
@ -433,7 +435,7 @@ genViewBranch :: View -> Annex () -> Annex Git.Branch
genViewBranch view a = withIndex $ do genViewBranch view a = withIndex $ do
a a
let branch = branchView view let branch = branchView view
void $ inRepo $ Git.Branch.commit True (fromRef branch) branch [] void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch []
return branch return branch
{- Runs an action using the view index file. {- Runs an action using the view index file.

View file

@ -1,10 +1,12 @@
{- filenames (not paths) used in views {- filenames (not paths) used in views
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE CPP #-}
module Annex.View.ViewedFile ( module Annex.View.ViewedFile (
ViewedFile, ViewedFile,
MkViewedFile, MkViewedFile,
@ -43,10 +45,18 @@ viewedFileFromReference f = concat
{- To avoid collisions with filenames or directories that contain {- To avoid collisions with filenames or directories that contain
- '%', and to allow the original directories to be extracted - '%', and to allow the original directories to be extracted
- from the ViewedFile, '%' is escaped to '\%' (and '\' to '\\'). - from the ViewedFile, '%' is escaped. )
-} -}
escape :: String -> String escape :: String -> String
escape = replace "%" "\\%" . replace "\\" "\\\\" 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 {- For use when operating already within a view, so whatever filepath
- is present in the work tree is already a ViewedFile. -} - is present in the work tree is already a ViewedFile. -}
@ -58,10 +68,10 @@ viewedFileReuse = takeFileName
dirFromViewedFile :: ViewedFile -> FilePath dirFromViewedFile :: ViewedFile -> FilePath
dirFromViewedFile = joinPath . drop 1 . sep [] "" dirFromViewedFile = joinPath . drop 1 . sep [] ""
where where
sep l _ [] = reverse l sep l _ [] = reverse l
sep l curr (c:cs) sep l curr (c:cs)
| c == '%' = sep (reverse curr:l) "" cs | c == '%' = sep (reverse curr:l) "" cs
| c == '\\' = case cs of | c == escchar = case cs of
(c':cs') -> sep l (c':curr) cs' (c':cs') -> sep l (c':curr) cs'
[] -> sep l curr cs [] -> sep l curr cs
| otherwise = sep l (c:curr) cs | otherwise = sep l (c:curr) cs
@ -70,6 +80,7 @@ prop_viewedFile_roundtrips :: FilePath -> Bool
prop_viewedFile_roundtrips f prop_viewedFile_roundtrips f
-- Relative filenames wanted, not directories. -- Relative filenames wanted, not directories.
| any (isPathSeparator) (end f ++ beginning f) = True | any (isPathSeparator) (end f ++ beginning f) = True
| isAbsolute f = True
| otherwise = dir == dirFromViewedFile (viewedFileFromReference f) | otherwise = dir == dirFromViewedFile (viewedFileFromReference f)
where where
dir = joinPath $ beginning $ splitDirectories f dir = joinPath $ beginning $ splitDirectories f

View file

@ -1,6 +1,6 @@
{- git-annex checking whether content is wanted {- git-annex checking whether content is wanted
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -15,15 +15,15 @@ import qualified Data.Set as S
{- Check if a file is preferred content for the local repository. -} {- Check if a file is preferred content for the local repository. -}
wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
wantGet def key file = isPreferredContent Nothing S.empty key file def wantGet d key file = isPreferredContent Nothing S.empty key file d
{- Check if a file is preferred content for a remote. -} {- Check if a file is preferred content for a remote. -}
wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
wantSend def key file to = isPreferredContent (Just to) S.empty key file def wantSend d key file to = isPreferredContent (Just to) S.empty key file d
{- Check if a file can be dropped, maybe from a remote. {- Check if a file can be dropped, maybe from a remote.
- Don't drop files that are preferred content. -} - Don't drop files that are preferred content. -}
wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool
wantDrop def from key file = do wantDrop d from key file = do
u <- maybe getUUID (return . id) from u <- maybe getUUID (return . id) from
not <$> isPreferredContent (Just u) (S.singleton u) key file def not <$> isPreferredContent (Just u) (S.singleton u) key file d

View file

@ -1,6 +1,6 @@
{- git-annex assistant daemon {- git-annex assistant daemon
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -21,6 +21,7 @@ import Assistant.Threads.Pusher
import Assistant.Threads.Merger import Assistant.Threads.Merger
import Assistant.Threads.TransferWatcher import Assistant.Threads.TransferWatcher
import Assistant.Threads.Transferrer import Assistant.Threads.Transferrer
import Assistant.Threads.RemoteControl
import Assistant.Threads.SanityChecker import Assistant.Threads.SanityChecker
import Assistant.Threads.Cronner import Assistant.Threads.Cronner
import Assistant.Threads.ProblemFixer import Assistant.Threads.ProblemFixer
@ -51,9 +52,12 @@ import qualified Utility.Daemon
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Utility.HumanTime import Utility.HumanTime
import qualified Build.SysConfig as SysConfig import qualified Build.SysConfig as SysConfig
#ifndef mingw32_HOST_OS
import Utility.LogFile
import Annex.Perms import Annex.Perms
import Utility.LogFile
#ifdef mingw32_HOST_OS
import Utility.Env
import Config.Files
import System.Environment (getArgs)
#endif #endif
import System.Log.Logger import System.Log.Logger
@ -69,23 +73,21 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
- stdout and stderr descriptors. -} - stdout and stderr descriptors. -}
startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () 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 startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do
Annex.changeState $ \s -> s { Annex.daemon = True } Annex.changeState $ \s -> s { Annex.daemon = True }
pidfile <- fromRepo gitAnnexPidFile pidfile <- fromRepo gitAnnexPidFile
#ifndef mingw32_HOST_OS
logfile <- fromRepo gitAnnexLogFile logfile <- fromRepo gitAnnexLogFile
liftIO $ debugM desc $ "logging to " ++ logfile
#ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile) createAnnexDirectory (parentDir logfile)
logfd <- liftIO $ openLog logfile logfd <- liftIO $ handleToFd =<< openLog logfile
if foreground if foreground
then do then do
origout <- liftIO $ catchMaybeIO $ origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $ origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError fdToHandle =<< dup stdError
let undaemonize a = do let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
debugM desc $ "logging to " ++ logfile
Utility.Daemon.lockPidFile pidfile
Utility.LogFile.redirLog logfd
a
start undaemonize $ start undaemonize $
case startbrowser of case startbrowser of
Nothing -> Nothing Nothing -> Nothing
@ -93,16 +95,32 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
else else
start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
#else #else
-- Windows is always foreground, and has no log file. -- 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 when (foreground || not foreground) $ do
liftIO $ Utility.Daemon.lockPidFile pidfile let flag = "GIT_ANNEX_OUTPUT_REDIR"
start id $ do createAnnexDirectory (parentDir logfile)
case startbrowser of ifM (liftIO $ isNothing <$> getEnv flag)
Nothing -> Nothing ( liftIO $ withFile devNull WriteMode $ \nullh -> do
Just a -> Just $ a Nothing Nothing 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 #endif
where where
desc desc
| assistant = "assistant" | assistant = "assistant"
| otherwise = "watch" | otherwise = "watch"
start daemonize webappwaiter = withThreadState $ \st -> do start daemonize webappwaiter = withThreadState $ \st -> do
@ -130,7 +148,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
let threads = if isJust cannotrun let threads = if isJust cannotrun
then webappthread then webappthread
else webappthread ++ else webappthread ++
[ watch $ commitThread [ watch commitThread
#ifdef WITH_WEBAPP #ifdef WITH_WEBAPP
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
, assist $ pairListenerThread urlrenderer , assist $ pairListenerThread urlrenderer
@ -141,28 +159,29 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
, assist $ xmppReceivePackThread urlrenderer , assist $ xmppReceivePackThread urlrenderer
#endif #endif
#endif #endif
, assist $ pushThread , assist pushThread
, assist $ pushRetryThread , assist pushRetryThread
, assist $ mergeThread , assist mergeThread
, assist $ transferWatcherThread , assist transferWatcherThread
, assist $ transferPollerThread , assist transferPollerThread
, assist $ transfererThread , assist transfererThread
, assist $ daemonStatusThread , assist remoteControlThread
, assist daemonStatusThread
, assist $ sanityCheckerDailyThread urlrenderer , assist $ sanityCheckerDailyThread urlrenderer
, assist $ sanityCheckerHourlyThread , assist sanityCheckerHourlyThread
, assist $ problemFixerThread urlrenderer , assist $ problemFixerThread urlrenderer
#ifdef WITH_CLIBS #ifdef WITH_CLIBS
, assist $ mountWatcherThread urlrenderer , assist $ mountWatcherThread urlrenderer
#endif #endif
, assist $ netWatcherThread , assist netWatcherThread
, assist $ upgraderThread urlrenderer , assist $ upgraderThread urlrenderer
, assist $ upgradeWatcherThread urlrenderer , assist $ upgradeWatcherThread urlrenderer
, assist $ netWatcherFallbackThread , assist netWatcherFallbackThread
, assist $ transferScannerThread urlrenderer , assist $ transferScannerThread urlrenderer
, assist $ cronnerThread urlrenderer , assist $ cronnerThread urlrenderer
, assist $ configMonitorThread , assist configMonitorThread
, assist $ glacierThread , assist glacierThread
, watch $ watchThread , watch watchThread
-- must come last so that all threads that wait -- must come last so that all threads that wait
-- on it have already started waiting -- on it have already started waiting
, watch $ sanityCheckerStartupThread startdelay , watch $ sanityCheckerStartupThread startdelay

View file

@ -1,6 +1,6 @@
{- git-annex assistant alerts {- git-annex assistant alerts
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -16,6 +16,7 @@ import qualified Remote
import Utility.Tense import Utility.Tense
import Logs.Transfer import Logs.Transfer
import Types.Distribution import Types.Distribution
import Git.Types (RemoteName)
import Data.String import Data.String
import qualified Data.Text as T import qualified Data.Text as T
@ -117,11 +118,14 @@ commitAlert :: Alert
commitAlert = activityAlert Nothing commitAlert = activityAlert Nothing
[Tensed "Committing" "Committed", "changes to git"] [Tensed "Committing" "Committed", "changes to git"]
showRemotes :: [Remote] -> TenseChunk showRemotes :: [RemoteName] -> TenseChunk
showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name) showRemotes = UnTensed . T.intercalate ", " . map T.pack
syncAlert :: [Remote] -> Alert syncAlert :: [Remote] -> Alert
syncAlert rs = baseActivityAlert syncAlert = syncAlert' . map Remote.name
syncAlert' :: [RemoteName] -> Alert
syncAlert' rs = baseActivityAlert
{ alertName = Just SyncAlert { alertName = Just SyncAlert
, alertHeader = Just $ tenseWords , alertHeader = Just $ tenseWords
[Tensed "Syncing" "Synced", "with", showRemotes rs] [Tensed "Syncing" "Synced", "with", showRemotes rs]
@ -130,13 +134,18 @@ syncAlert rs = baseActivityAlert
} }
syncResultAlert :: [Remote] -> [Remote] -> Alert syncResultAlert :: [Remote] -> [Remote] -> Alert
syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $ syncResultAlert succeeded failed = syncResultAlert'
(map Remote.name succeeded)
(map Remote.name failed)
syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert
syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
baseActivityAlert baseActivityAlert
{ alertName = Just SyncAlert { alertName = Just SyncAlert
, alertHeader = Just $ tenseWords msg , alertHeader = Just $ tenseWords msg
} }
where where
msg msg
| null succeeded = ["Failed to sync with", showRemotes failed] | null succeeded = ["Failed to sync with", showRemotes failed]
| null failed = ["Synced with", showRemotes succeeded] | null failed = ["Synced with", showRemotes succeeded]
| otherwise = | otherwise =
@ -320,10 +329,10 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert
, alertButtons = maybeToList button , alertButtons = maybeToList button
} }
xmppNeededAlert :: AlertButton -> Alert connectionNeededAlert :: AlertButton -> Alert
xmppNeededAlert button = Alert connectionNeededAlert button = Alert
{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud." { alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
, alertIcon = Just TheCloud , alertIcon = Just ConnectionIcon
, alertPriority = High , alertPriority = High
, alertButtons = [button] , alertButtons = [button]
, alertClosable = True , alertClosable = True
@ -331,7 +340,7 @@ xmppNeededAlert button = Alert
, alertMessageRender = renderData , alertMessageRender = renderData
, alertCounter = 0 , alertCounter = 0
, alertBlockDisplay = True , alertBlockDisplay = True
, alertName = Just $ XMPPNeededAlert , alertName = Just ConnectionNeededAlert
, alertCombiner = Just $ dataCombiner $ \_old new -> new , alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertData = [] , alertData = []
} }

View file

@ -1,6 +1,6 @@
{- git-annex assistant alert utilities {- git-annex assistant alert utilities
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -14,7 +14,6 @@ import Utility.Tense
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Monoid
{- This is as many alerts as it makes sense to display at a time. {- 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 - A display might be smaller, or larger, the point is to not overwhelm the
@ -120,7 +119,7 @@ mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
where where
bloat = M.size m' - maxAlerts bloat = M.size m' - maxAlerts
pruneold l = pruneold l =
let (f, rest) = partition (\(_, a) -> isFiller a) l let (f, rest) = partition (\(_, a) -> isFiller a) l
in drop bloat f ++ rest in drop bloat f ++ rest
updatePrune = pruneBloat $ M.filterWithKey pruneSame $ updatePrune = pruneBloat $ M.filterWithKey pruneSame $
M.insertWith' const i al m M.insertWith' const i al m

View file

@ -1,6 +1,6 @@
{- git-annex assistant git-annex branch change tracking {- git-annex assistant git-annex branch change tracking
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant change tracking {- git-annex assistant change tracking
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant commit tracking {- git-annex assistant commit tracking
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- Common infrastructure for the git-annex assistant. {- Common infrastructure for the git-annex assistant.
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -0,0 +1,53 @@
{- git-annex assistant CredPair cache.
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Assistant.CredPairCache (
cacheCred,
getCachedCred,
expireCachedCred,
) where
import Assistant.Types.CredPairCache
import Types.Creds
import Assistant.Common
import Utility.ThreadScheduler
import qualified Data.Map as M
import Control.Concurrent
{- Caches a CredPair, but only for a limited time, after which it
- will expire.
-
- Note that repeatedly caching the same CredPair
- does not reset its expiry time.
-}
cacheCred :: CredPair -> Seconds -> Assistant ()
cacheCred (login, password) expireafter = do
cache <- getAssistant credPairCache
liftIO $ do
changeStrict cache $ M.insert login password
void $ forkIO $ do
threadDelaySeconds expireafter
changeStrict cache $ M.delete login
getCachedCred :: Login -> Assistant (Maybe Password)
getCachedCred login = do
cache <- getAssistant credPairCache
liftIO $ M.lookup login <$> readMVar cache
expireCachedCred :: Login -> Assistant ()
expireCachedCred login = do
cache <- getAssistant credPairCache
liftIO $ changeStrict cache $ M.delete login
{- Update map strictly to avoid keeping references to old creds in memory. -}
changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO ()
changeStrict cache a = modifyMVar_ cache $ \m -> do
let !m' = a m
return m'

View file

@ -1,6 +1,6 @@
{- git-annex assistant daemon status {- git-annex assistant daemon status
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -26,6 +26,7 @@ import Data.Time.Clock.POSIX
import Data.Time import Data.Time
import System.Locale import System.Locale
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
getDaemonStatus :: Assistant DaemonStatus getDaemonStatus :: Assistant DaemonStatus
@ -64,7 +65,7 @@ calcSyncRemotes = do
, syncingToCloudRemote = any iscloud syncdata , syncingToCloudRemote = any iscloud syncdata
} }
where where
iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable
{- Updates the syncRemotes list from the list of all remotes in Annex state. -} {- Updates the syncRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant () updateSyncRemotes :: Assistant ()
@ -78,6 +79,15 @@ updateSyncRemotes = do
M.filter $ \alert -> M.filter $ \alert ->
alertName alert /= Just CloudRepoNeededAlert 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 :: Assistant ()
updateScheduleLog = updateScheduleLog =
liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus

View file

@ -1,6 +1,6 @@
{- git-annex assistant remote deletion utilities {- git-annex assistant remote deletion utilities
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -17,7 +17,7 @@ import Logs.Location
import Assistant.DaemonStatus import Assistant.DaemonStatus
import qualified Remote import qualified Remote
import Remote.List import Remote.List
import qualified Git.Remote import qualified Git.Remote.Remove
import Logs.Trust import Logs.Trust
import qualified Annex import qualified Annex
@ -34,7 +34,7 @@ disableRemote uuid = do
remote <- fromMaybe (error "unknown remote") remote <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid) <$> liftAnnex (Remote.remoteFromUUID uuid)
liftAnnex $ do liftAnnex $ do
inRepo $ Git.Remote.remove (Remote.name remote) inRepo $ Git.Remote.Remove.remove (Remote.name remote)
void $ remoteListRefresh void $ remoteListRefresh
updateSyncRemotes updateSyncRemotes
return remote return remote
@ -62,7 +62,7 @@ removableRemote urlrenderer uuid = do
<$> liftAnnex (Remote.remoteFromUUID uuid) <$> liftAnnex (Remote.remoteFromUUID uuid)
mapM_ (queueremaining r) keys mapM_ (queueremaining r) keys
where where
queueremaining r k = queueremaining r k =
queueTransferWhenSmall "remaining object in unwanted remote" queueTransferWhenSmall "remaining object in unwanted remote"
Nothing (Transfer Download uuid k) r Nothing (Transfer Download uuid k) r
{- Scanning for keys can take a long time; do not tie up {- Scanning for keys can take a long time; do not tie up

View file

@ -1,6 +1,6 @@
{- git-annex assistant dropping of unwanted content {- git-annex assistant dropping of unwanted content
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant fscking {- git-annex assistant fscking
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant gpg stuff {- git-annex assistant gpg stuff
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -20,7 +20,7 @@ newUserId :: IO UserId
newUserId = do newUserId = do
oldkeys <- secretKeys oldkeys <- secretKeys
username <- myUserName username <- myUserName
let basekeyname = username ++ "'s git-annex encryption key" let basekeyname = username ++ "'s git-annex encryption key"
return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys) return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
( basekeyname ( basekeyname
: map (\n -> basekeyname ++ show n) ([2..] :: [Int]) : map (\n -> basekeyname ++ show n) ([2..] :: [Int])

View file

@ -1,6 +1,6 @@
{- Assistant installation {- Assistant installation
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -22,6 +22,9 @@ import Utility.SshConfig
import Utility.OSX import Utility.OSX
#else #else
import Utility.FreeDesktop import Utility.FreeDesktop
#ifdef linux_HOST_OS
import Utility.UserInfo
#endif
import Assistant.Install.Menu import Assistant.Install.Menu
#endif #endif
@ -30,16 +33,19 @@ standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process. {- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant - So when it's run, it needs to set up autostarting of the assistant
- daemon, as well as writing the programFile, and putting a - daemon, as well as writing the programFile, and putting the
- git-annex-shell wrapper into ~/.ssh - 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 - 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. - 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 :: IO ()
ensureInstalled = go =<< standaloneAppBase ensureInstalled = go =<< standaloneAppBase
where where
go Nothing = noop go Nothing = installFileManagerHooks "git-annex"
go (Just base) = do go (Just base) = do
let program = base </> "git-annex" let program = base </> "git-annex"
programfile <- programFile programfile <- programFile
@ -56,27 +62,98 @@ ensureInstalled = go =<< standaloneAppBase
#endif #endif
installAutoStart program autostartfile installAutoStart program autostartfile
{- This shim is only updated if it doesn't
- already exist with the right content. -}
sshdir <- sshDir sshdir <- sshDir
let shim = sshdir </> "git-annex-shell" let runshell var = "exec " ++ base </> "runshell " ++ var
let runshell var = "exec " ++ base </> "runshell" ++ let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
" git-annex-shell -c \"" ++ var ++ "\""
let content = unlines installWrapper (sshdir </> "git-annex-shell") $ unlines
[ shebang_local [ shebang_local
, "set -e" , "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, runshell "$SSH_ORIGINAL_COMMAND" , rungitannexshell "$SSH_ORIGINAL_COMMAND"
, "else" , "else"
, runshell "$@" , rungitannexshell "$@"
, "fi" , "fi"
] ]
installWrapper (sshdir </> "git-annex-wrapper") $ unlines
[ shebang_local
, "set -e"
, runshell "\"$@\""
]
curr <- catchDefaultIO "" $ readFileStrict shim installFileManagerHooks program
when (curr /= content) $ do
createDirectoryIfMissing True (parentDir shim) installWrapper :: FilePath -> String -> IO ()
viaTmp writeFile shim content installWrapper file content = do
modifyFileMode shim $ addModes [ownerExecuteMode] 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 {- Returns a cleaned up environment that lacks settings used to make the
- standalone builds use their bundled libraries and programs. - standalone builds use their bundled libraries and programs.
@ -87,15 +164,15 @@ ensureInstalled = go =<< standaloneAppBase
cleanEnvironment :: IO (Maybe [(String, String)]) cleanEnvironment :: IO (Maybe [(String, String)])
cleanEnvironment = clean <$> getEnvironment cleanEnvironment = clean <$> getEnvironment
where where
clean env clean environ
| null vars = Nothing | null vars = Nothing
| otherwise = Just $ catMaybes $ map (restoreorig env) env | otherwise = Just $ catMaybes $ map (restoreorig environ) environ
| otherwise = Nothing | otherwise = Nothing
where where
vars = words $ fromMaybe "" $ vars = words $ fromMaybe "" $
lookup "GIT_ANNEX_STANDLONE_ENV" env lookup "GIT_ANNEX_STANDLONE_ENV" environ
restoreorig oldenv p@(k, _v) restoreorig oldenviron p@(k, _v)
| k `elem` vars = case lookup ("ORIG_" ++ k) oldenv of | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
(Just v') (Just v')
| not (null v') -> Just (k, v') | not (null v') -> Just (k, v')
_ -> Nothing _ -> Nothing

View file

@ -1,6 +1,6 @@
{- Assistant autostart file installation {- Assistant autostart file installation
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- Assistant menu installation. {- Assistant menu installation.
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant remote creation utilities {- git-annex assistant remote creation utilities
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -48,7 +48,7 @@ makeRsyncRemote :: RemoteName -> String -> Annex String
makeRsyncRemote name location = makeRemote name location $ const $ void $ makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Command.InitRemote.findExisting name go =<< Command.InitRemote.findExisting name
where where
go Nothing = setupSpecialRemote name Rsync.remote config Nothing go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, Command.InitRemote.newConfig name) (Nothing, Command.InitRemote.newConfig name)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
(Just u, c) (Just u, c)
@ -90,18 +90,23 @@ enableSpecialRemote name remotetype mcreds config = do
r <- Command.InitRemote.findExisting name r <- Command.InitRemote.findExisting name
case r of case r of
Nothing -> error $ "Cannot find a special remote named " ++ name Nothing -> error $ "Cannot find a special remote named " ++ name
Just (u, c) -> setupSpecialRemote name remotetype config mcreds (Just u, c) Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, c)
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config mcreds (mu, c) = do setupSpecialRemote = setupSpecialRemote' True
setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do
{- Currently, only 'weak' ciphers can be generated from the {- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy - assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user - pool is drained, and as of now there's no way to tell the user
- to perform IO actions to refill the pool. -} - to perform IO actions to refill the pool. -}
(c', u) <- R.setup remotetype mu mcreds $ (c', u) <- R.setup remotetype mu mcreds $
M.insert "highRandomQuality" "false" $ M.union config c M.insert "highRandomQuality" "false" $ M.union config c
describeUUID u name
configSet u c' configSet u c'
when setdesc $
whenM (isNothing . M.lookup u <$> uuidMap) $
describeUUID u name
return name return name
{- Returns the name of the git remote it created. If there's already a {- Returns the name of the git remote it created. If there's already a

View file

@ -1,6 +1,6 @@
{- git-annex assistant monad {- git-annex assistant monad
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -43,6 +43,8 @@ import Assistant.Types.RepoProblem
import Assistant.Types.Buddies import Assistant.Types.Buddies
import Assistant.Types.NetMessager import Assistant.Types.NetMessager
import Assistant.Types.ThreadName import Assistant.Types.ThreadName
import Assistant.Types.RemoteControl
import Assistant.Types.CredPairCache
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving ( deriving (
@ -68,6 +70,8 @@ data AssistantData = AssistantData
, branchChangeHandle :: BranchChangeHandle , branchChangeHandle :: BranchChangeHandle
, buddyList :: BuddyList , buddyList :: BuddyList
, netMessager :: NetMessager , netMessager :: NetMessager
, remoteControl :: RemoteControl
, credPairCache :: CredPairCache
} }
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@ -86,6 +90,8 @@ newAssistantData st dstatus = AssistantData
<*> newBranchChangeHandle <*> newBranchChangeHandle
<*> newBuddyList <*> newBuddyList
<*> newNetMessager <*> newNetMessager
<*> newRemoteControl
<*> newCredPairCache
runAssistant :: AssistantData -> Assistant a -> IO a runAssistant :: AssistantData -> Assistant a -> IO a
runAssistant d a = runReaderT (mkAssistant a) d runAssistant d a = runReaderT (mkAssistant a) d

View file

@ -1,6 +1,6 @@
{- git-annex assistant named threads. {- git-annex assistant named threads.
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant out of band network messager interface {- git-annex assistant out of band network messager interface
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -80,7 +80,7 @@ checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
queuePushInitiation :: NetMessage -> Assistant () queuePushInitiation :: NetMessage -> Assistant ()
queuePushInitiation msg@(Pushing clientid stage) = do queuePushInitiation msg@(Pushing clientid stage) = do
tv <- getPushInitiationQueue side tv <- getPushInitiationQueue side
liftIO $ atomically $ do liftIO $ atomically $ do
r <- tryTakeTMVar tv r <- tryTakeTMVar tv
case r of case r of
Nothing -> putTMVar tv [msg] Nothing -> putTMVar tv [msg]
@ -88,7 +88,7 @@ queuePushInitiation msg@(Pushing clientid stage) = do
let !l' = msg : filter differentclient l let !l' = msg : filter differentclient l
putTMVar tv l' putTMVar tv l'
where where
side = pushDestinationSide stage side = pushDestinationSide stage
differentclient (Pushing cid _) = cid /= clientid differentclient (Pushing cid _) = cid /= clientid
differentclient _ = True differentclient _ = True
queuePushInitiation _ = noop queuePushInitiation _ = noop

View file

@ -1,6 +1,6 @@
{- git-annex assistant repo pairing, core data types {- git-annex assistant repo pairing, core data types
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -58,6 +58,15 @@ data PairData = PairData
} }
deriving (Eq, Read, Show) 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 type UserName = String
{- A pairing that is in progress has a secret, a thread that is {- A pairing that is in progress has a secret, a thread that is

View file

@ -1,6 +1,6 @@
{- git-annex assistant pairing remote creation {- git-annex assistant pairing remote creation
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -23,12 +23,11 @@ import qualified Data.Text as T
{- Authorized keys are set up before pairing is complete, so that the other {- Authorized keys are set up before pairing is complete, so that the other
- side can immediately begin syncing. -} - side can immediately begin syncing. -}
setupAuthorizedKeys :: PairMsg -> FilePath -> IO () setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = do setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
validateSshPubKey pubkey Left err -> error err
unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $ Right pubkey ->
error "failed setting up ssh authorized keys" unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
where error "failed setting up ssh authorized keys"
pubkey = remoteSshPubKey $ pairMsgData msg
{- When local pairing is complete, this is used to set up the remote for {- When local pairing is complete, this is used to set up the remote for
- the host we paired with. -} - the host we paired with. -}

View file

@ -4,7 +4,7 @@
- each message is repeated until acknowledged. This is done using a - each message is repeated until acknowledged. This is done using a
- thread, that gets stopped before the next message is sent. - thread, that gets stopped before the next message is sent.
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -20,7 +20,6 @@ import Utility.Verifiable
import Network.Multicast import Network.Multicast
import Network.Info import Network.Info
import Network.Socket import Network.Socket
import Control.Exception (bracket)
import qualified Data.Map as M import qualified Data.Map as M
import Control.Concurrent import Control.Concurrent

View file

@ -1,6 +1,6 @@
{- git-annex assistant push tracking {- git-annex assistant push tracking
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -0,0 +1,21 @@
{- git-annex assistant RemoteDaemon control
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.RemoteControl (
sendRemoteControl,
RemoteDaemon.Consumed(..)
) where
import Assistant.Common
import qualified RemoteDaemon.Types as RemoteDaemon
import Control.Concurrent
sendRemoteControl :: RemoteDaemon.Consumed -> Assistant ()
sendRemoteControl msg = do
clicker <- getAssistant remoteControl
liftIO $ writeChan clicker msg

View file

@ -1,6 +1,6 @@
{- git-annex assistant repository repair {- git-annex assistant repository repair
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -63,7 +63,7 @@ runRepair u mrmt destructiverepair = do
return ok return ok
where where
localrepair fsckresults = do localrepair fsckresults = do
-- Stop the watcher from running while running repairs. -- Stop the watcher from running while running repairs.
changeSyncable Nothing False changeSyncable Nothing False
@ -140,9 +140,8 @@ repairStaleGitLocks r = do
repairStaleLocks :: [FilePath] -> Assistant () repairStaleLocks :: [FilePath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes repairStaleLocks lockfiles = go =<< getsizes
where where
getsize lf = catchMaybeIO $ getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize lf
(\s -> (lf, fileSize s)) <$> getFileStatus lf getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return () go [] = return ()
go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l)) go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
( do ( do

View file

@ -1,6 +1,6 @@
{- git-annex assistant remote problem handling {- git-annex assistant remote problem handling
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant restarting {- git-annex assistant restarting
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -24,13 +24,11 @@ import qualified Annex
import qualified Git import qualified Git
import Control.Concurrent import Control.Concurrent
import System.Process (cwd)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix (signalProcess, sigTERM) import System.Posix (signalProcess, sigTERM)
#else #else
import Utility.WinProcess import Utility.WinProcess
#endif #endif
import Data.Default
import Network.URI import Network.URI
{- Before the assistant can be restarted, have to remove our {- Before the assistant can be restarted, have to remove our
@ -54,6 +52,10 @@ postRestart url = do
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
void $ liftIO $ forkIO $ do void $ liftIO $ forkIO $ do
threadDelaySeconds (Seconds 120) threadDelaySeconds (Seconds 120)
terminateSelf
terminateSelf :: IO ()
terminateSelf =
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
signalProcess sigTERM =<< getPID signalProcess sigTERM =<< getPID
#else #else
@ -93,7 +95,7 @@ newAssistantUrl repo = do
- warp-tls listens to http, in order to show an error page, so this works. - warp-tls listens to http, in order to show an error page, so this works.
-} -}
assistantListening :: URLString -> IO Bool assistantListening :: URLString -> IO Bool
assistantListening url = catchBoolIO $ fst <$> exists url' def assistantListening url = catchBoolIO $ exists url' def
where where
url' = case parseURI url of url' = case parseURI url of
Nothing -> url Nothing -> url

View file

@ -1,6 +1,6 @@
{- git-annex assistant remotes needing scanning {- git-annex assistant remotes needing scanning
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant ssh utilities {- git-annex assistant ssh utilities
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -92,7 +92,7 @@ parseSshUrl u
, sshCapabilities = [] , sshCapabilities = []
} }
where where
(user, host) = if '@' `elem` userhost (user, host) = if '@' `elem` userhost
then separate (== '@') userhost then separate (== '@') userhost
else ("", userhost) else ("", userhost)
fromrsync s fromrsync s
@ -111,34 +111,26 @@ sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
sshTranscript opts input = processTranscript "ssh" opts input sshTranscript opts input = processTranscript "ssh" opts input
{- Ensure that the ssh public key doesn't include any ssh options, like {- Ensure that the ssh public key doesn't include any ssh options, like
- command=foo, or other weirdness -} - command=foo, or other weirdness.
validateSshPubKey :: SshPubKey -> IO () -
- The returned version of the key has its comment removed.
-}
validateSshPubKey :: SshPubKey -> Either String SshPubKey
validateSshPubKey pubkey validateSshPubKey pubkey
| length (lines pubkey) == 1 = | length (lines pubkey) == 1 = check $ words pubkey
either error return $ check $ words pubkey | otherwise = Left "too many lines in ssh public key"
| otherwise = error "too many lines in ssh public key"
where where
check [prefix, _key, comment] = do check (prefix:key:_) = checkprefix prefix (unwords [prefix, key])
checkprefix prefix
checkcomment comment
check [prefix, _key] =
checkprefix prefix
check _ = err "wrong number of words in ssh public key" check _ = err "wrong number of words in ssh public key"
ok = Right ()
err msg = Left $ unwords [msg, pubkey] err msg = Left $ unwords [msg, pubkey]
checkprefix prefix checkprefix prefix validpubkey
| ssh == "ssh" && all isAlphaNum keytype = ok | ssh == "ssh" && all isAlphaNum keytype = Right validpubkey
| otherwise = err "bad ssh public key prefix" | otherwise = err "bad ssh public key prefix"
where where
(ssh, keytype) = separate (== '-') prefix (ssh, keytype) = separate (== '-') prefix
checkcomment comment = case filter (not . safeincomment) comment of
[] -> ok
badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")"
safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh" addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ] [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
@ -197,7 +189,7 @@ authorizedKeysLine gitannexshellonly dir pubkey
- long perl script. -} - long perl script. -}
| otherwise = pubkey | otherwise = pubkey
where where
limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty " limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
{- Generates a ssh key pair. -} {- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair genSshKeyPair :: IO SshKeyPair
@ -260,7 +252,7 @@ setupSshKeyPair sshkeypair sshdata = do
fixSshKeyPairIdentitiesOnly :: IO () fixSshKeyPairIdentitiesOnly :: IO ()
fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
where where
go c [] = reverse c go c [] = reverse c
go c (l:[]) go c (l:[])
| all (`isInfixOf` l) indicators = go (fixedline l:l:c) [] | all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
| otherwise = go (l:c) [] | otherwise = go (l:c) []
@ -268,7 +260,7 @@ fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) = | all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) =
go (fixedline l:l:c) (next:rest) go (fixedline l:l:c) (next:rest)
| otherwise = go (l:c) (next:rest) | otherwise = go (l:c) (next:rest)
indicators = ["IdentityFile", "key.git-annex"] indicators = ["IdentityFile", "key.git-annex"]
fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes" fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
{- Add StrictHostKeyChecking to any ssh config stanzas that were written {- Add StrictHostKeyChecking to any ssh config stanzas that were written
@ -312,7 +304,7 @@ setSshConfig sshdata config = do
{- This hostname is specific to a given repository on the ssh host, {- 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. - so it is based on the real hostname, the username, and the directory.
- -
- The mangled hostname has the form "git-annex-realhostname-username_dir". - The mangled hostname has the form "git-annex-realhostname-username-port_dir".
- The only use of "-" is to separate the parts shown; this is necessary - The only use of "-" is to separate the parts shown; this is necessary
- to allow unMangleSshHostName to work. Any unusual characters in the - to allow unMangleSshHostName to work. Any unusual characters in the
- username or directory are url encoded, except using "." rather than "%" - username or directory are url encoded, except using "." rather than "%"
@ -324,6 +316,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
where where
extra = intercalate "_" $ map T.unpack $ catMaybes extra = intercalate "_" $ map T.unpack $ catMaybes
[ sshUserName sshdata [ sshUserName sshdata
, Just $ T.pack $ show $ sshPort sshdata
, Just $ sshDirectory sshdata , Just $ sshDirectory sshdata
] ]
safe c safe c

View file

@ -1,6 +1,6 @@
{- git-annex assistant repo syncing {- git-annex assistant repo syncing
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -15,6 +15,7 @@ import Assistant.Alert
import Assistant.Alert.Utility import Assistant.Alert.Utility
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.ScanRemotes import Assistant.ScanRemotes
import Assistant.RemoteControl
import qualified Command.Sync import qualified Command.Sync
import Utility.Parallel import Utility.Parallel
import qualified Git import qualified Git
@ -95,7 +96,7 @@ reconnectRemotes notifypushes rs = void $ do
=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers =<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
<$> getDaemonStatus <$> getDaemonStatus
{- Updates the local sync branch, then pushes it to all remotes, in {- Pushes the local sync branch to all remotes, in
- parallel, along with the git-annex branch. This is the same - 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 - as "git annex sync", except in parallel, and will co-exist with use of
- "git annex sync". - "git annex sync".
@ -147,7 +148,6 @@ pushToRemotes' now notifypushes remotes = do
go _ _ _ _ [] = return [] -- no remotes, so nothing to do go _ _ _ _ [] = return [] -- no remotes, so nothing to do
go shouldretry (Just branch) g u rs = do go shouldretry (Just branch) g u rs = do
debug ["pushing to", show rs] debug ["pushing to", show rs]
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
(succeeded, failed) <- liftIO $ inParallel (push g branch) rs (succeeded, failed) <- liftIO $ inParallel (push g branch) rs
updatemap succeeded [] updatemap succeeded []
if null failed if null failed
@ -258,6 +258,7 @@ changeSyncable Nothing enable = do
changeSyncable (Just r) True = do changeSyncable (Just r) True = do
liftAnnex $ changeSyncFlag r True liftAnnex $ changeSyncFlag r True
syncRemote r syncRemote r
sendRemoteControl RELOAD
changeSyncable (Just r) False = do changeSyncable (Just r) False = do
liftAnnex $ changeSyncFlag r False liftAnnex $ changeSyncFlag r False
updateSyncRemotes updateSyncRemotes

View file

@ -1,6 +1,6 @@
{- git-annex assistant commit thread {- git-annex assistant commit thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -27,7 +27,6 @@ import qualified Utility.Lsof as Lsof
import qualified Utility.DirWatcher as DirWatcher import qualified Utility.DirWatcher as DirWatcher
import Types.KeySource import Types.KeySource
import Config import Config
import Annex.Exception
import Annex.Content import Annex.Content
import Annex.Link import Annex.Link
import Annex.CatFile import Annex.CatFile
@ -35,6 +34,7 @@ import qualified Annex
import Utility.InodeCache import Utility.InodeCache
import Annex.Content.Direct import Annex.Content.Direct
import qualified Command.Sync import qualified Command.Sync
import qualified Git.Branch
import Data.Time.Clock import Data.Time.Clock
import Data.Tuple.Utils import Data.Tuple.Utils
@ -50,6 +50,7 @@ commitThread = namedThread "Committer" $ do
delayadd <- liftAnnex $ delayadd <- liftAnnex $
maybe delayaddDefault (return . Just . Seconds) maybe delayaddDefault (return . Just . Seconds)
=<< annexDelayAdd <$> Annex.getGitConfig =<< annexDelayAdd <$> Annex.getGitConfig
msg <- liftAnnex Command.Sync.commitMsg
waitChangeTime $ \(changes, time) -> do waitChangeTime $ \(changes, time) -> do
readychanges <- handleAdds havelsof delayadd changes readychanges <- handleAdds havelsof delayadd changes
if shouldCommit False time (length readychanges) readychanges if shouldCommit False time (length readychanges) readychanges
@ -60,7 +61,7 @@ commitThread = namedThread "Committer" $ do
, "changes" , "changes"
] ]
void $ alertWhile commitAlert $ void $ alertWhile commitAlert $
liftAnnex commitStaged liftAnnex $ commitStaged msg
recordCommit recordCommit
let numchanges = length readychanges let numchanges = length readychanges
mapM_ checkChangeContent readychanges mapM_ checkChangeContent readychanges
@ -164,8 +165,8 @@ waitChangeTime a = waitchanges 0
-} -}
aftermaxcommit oldchanges = loop (30 :: Int) aftermaxcommit oldchanges = loop (30 :: Int)
where where
loop 0 = continue oldchanges loop 0 = continue oldchanges
loop n = do loop n = do
liftAnnex noop -- ensure Annex state is free liftAnnex noop -- ensure Annex state is free
liftIO $ threadDelaySeconds (Seconds 1) liftIO $ threadDelaySeconds (Seconds 1)
changes <- getAnyChanges changes <- getAnyChanges
@ -212,14 +213,18 @@ shouldCommit scanning now len changes
recentchanges = filter thissecond changes recentchanges = filter thissecond changes
timeDelta c = now `diffUTCTime` changeTime c timeDelta c = now `diffUTCTime` changeTime c
commitStaged :: Annex Bool commitStaged :: String -> Annex Bool
commitStaged = do commitStaged msg = do
{- This could fail if there's another commit being made by {- This could fail if there's another commit being made by
- something else. -} - something else. -}
v <- tryAnnex Annex.Queue.flush v <- tryNonAsync Annex.Queue.flush
case v of case v of
Left _ -> return False Left _ -> return False
Right _ -> Command.Sync.commitStaged "" Right _ -> do
ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg
when ok $
Command.Sync.updateSyncBranch =<< inRepo Git.Branch.current
return ok
{- OSX needs a short delay after a file is added before locking it down, {- 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 - when using a non-direct mode repository, as pasting a file seems to
@ -297,7 +302,7 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
add change@(InProcessAddChange { keySource = ks }) = add change@(InProcessAddChange { keySource = ks }) =
catchDefaultIO Nothing <~> doadd catchDefaultIO Nothing <~> doadd
where where
doadd = sanitycheck ks $ do doadd = sanitycheck ks $ do
(mkey, mcache) <- liftAnnex $ do (mkey, mcache) <- liftAnnex $ do
showStart "add" $ keyFilename ks showStart "add" $ keyFilename ks
Command.Add.ingest $ Just ks Command.Add.ingest $ Just ks
@ -313,10 +318,11 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
adddirect toadd = do adddirect toadd = do
ct <- liftAnnex compareInodeCachesWith ct <- liftAnnex compareInodeCachesWith
m <- liftAnnex $ removedKeysMap ct cs m <- liftAnnex $ removedKeysMap ct cs
delta <- liftAnnex getTSDelta
if M.null m if M.null m
then forM toadd add then forM toadd add
else forM toadd $ \c -> do else forM toadd $ \c -> do
mcache <- liftIO $ genInodeCache $ changeFile c mcache <- liftIO $ genInodeCache (changeFile c) delta
case mcache of case mcache of
Nothing -> add c Nothing -> add c
Just cache -> Just cache ->
@ -347,7 +353,7 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
done change mcache file key = liftAnnex $ do done change mcache file key = liftAnnex $ do
logStatus key InfoPresent logStatus key InfoPresent
link <- ifM isDirect link <- ifM isDirect
( inRepo $ gitAnnexLink file key ( calcRepo $ gitAnnexLink file key
, Command.Add.link file key mcache , Command.Add.link file key mcache
) )
whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $

View file

@ -1,6 +1,6 @@
{- git-annex assistant config monitor thread {- git-annex assistant config monitor thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -62,15 +62,17 @@ configFilesActions =
, (groupLog, void $ liftAnnex groupMapLoad) , (groupLog, void $ liftAnnex groupMapLoad)
, (numcopiesLog, void $ liftAnnex globalNumCopiesLoad) , (numcopiesLog, void $ liftAnnex globalNumCopiesLoad)
, (scheduleLog, void updateScheduleLog) , (scheduleLog, void updateScheduleLog)
-- Preferred content settings depend on most of the other configs, -- Preferred and required content settings depend on most of the
-- so will be reloaded whenever any configs change. -- other configs, so will be reloaded whenever any configs change.
, (preferredContentLog, noop) , (preferredContentLog, noop)
, (requiredContentLog, noop)
, (groupPreferredContentLog, noop)
] ]
reloadConfigs :: Configs -> Assistant () reloadConfigs :: Configs -> Assistant ()
reloadConfigs changedconfigs = do reloadConfigs changedconfigs = do
sequence_ as sequence_ as
void $ liftAnnex preferredContentMapLoad void $ liftAnnex preferredRequiredMapsLoad
{- Changes to the remote log, or the trust log, can affect the {- Changes to the remote log, or the trust log, can affect the
- syncRemotes list. Changes to the uuid log may affect its - syncRemotes list. Changes to the uuid log may affect its
- display so are also included. -} - display so are also included. -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant sceduled jobs runner {- git-annex assistant sceduled jobs runner
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -87,7 +87,7 @@ cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
liftIO $ waitNotification h liftIO $ waitNotification h
debug ["reloading changed activities"] debug ["reloading changed activities"]
go h amap' nmap' go h amap' nmap'
startactivities as lastruntimes = forM as $ \activity -> startactivities as lastruntimes = forM as $ \activity ->
case connectActivityUUID activity of case connectActivityUUID activity of
Nothing -> do Nothing -> do
runner <- asIO2 (sleepingActivityThread urlrenderer) runner <- asIO2 (sleepingActivityThread urlrenderer)
@ -108,8 +108,8 @@ cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
sleepingActivityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant () sleepingActivityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime
where where
getnexttime = liftIO . nextTime schedule getnexttime = liftIO . nextTime schedule
go _ Nothing = debug ["no scheduled events left for", desc] go _ Nothing = debug ["no scheduled events left for", desc]
go l (Just (NextTimeExactly t)) = waitrun l t Nothing go l (Just (NextTimeExactly t)) = waitrun l t Nothing
go l (Just (NextTimeWindow windowstart windowend)) = go l (Just (NextTimeWindow windowstart windowend)) =
waitrun l windowstart (Just windowend) waitrun l windowstart (Just windowend)
@ -129,7 +129,7 @@ sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnextti
go l =<< getnexttime l go l =<< getnexttime l
else run nowt else run nowt
where where
tolate nowt tz = case mmaxt of tolate nowt tz = case mmaxt of
Just maxt -> nowt > maxt Just maxt -> nowt > maxt
-- allow the job to start 10 minutes late -- allow the job to start 10 minutes late
Nothing ->diffUTCTime Nothing ->diffUTCTime
@ -191,10 +191,10 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir) mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
where where
reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (remoteFromUUID u) runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (remoteFromUUID u)
where where
handle Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
handle (Just rmt) = void $ case Remote.remoteFsck rmt of dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of
Nothing -> go rmt $ do Nothing -> go rmt $ do
program <- readProgramFile program <- readProgramFile
void $ batchCommand program $ void $ batchCommand program $

View file

@ -1,6 +1,6 @@
{- git-annex assistant daemon status thread {- git-annex assistant daemon status thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant Amazon Glacier retrieval {- git-annex assistant Amazon Glacier retrieval
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant git merge thread {- git-annex assistant git merge thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -78,12 +78,13 @@ onChange file
changedbranch = fileToBranch file changedbranch = fileToBranch file
mergecurrent (Just current) mergecurrent (Just current)
| equivBranches changedbranch current = do | equivBranches changedbranch current =
debug whenM (liftAnnex $ inRepo $ Git.Branch.changed current changedbranch) $ do
[ "merging", Git.fromRef changedbranch debug
, "into", Git.fromRef current [ "merging", Git.fromRef changedbranch
] , "into", Git.fromRef current
void $ liftAnnex $ autoMergeFrom changedbranch (Just current) ]
void $ liftAnnex $ autoMergeFrom changedbranch (Just current) Git.Branch.AutomaticCommit
mergecurrent _ = noop mergecurrent _ = noop
handleDesynced = case fromTaggedBranch changedbranch of handleDesynced = case fromTaggedBranch changedbranch of

View file

@ -1,6 +1,6 @@
{- git-annex assistant mount watcher, using either dbus or mtab polling {- git-annex assistant mount watcher, using either dbus or mtab polling
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -63,7 +63,11 @@ dbusThread urlrenderer = do
wasmounted <- liftIO $ swapMVar mvar nowmounted wasmounted <- liftIO $ swapMVar mvar nowmounted
handleMounts urlrenderer wasmounted nowmounted handleMounts urlrenderer wasmounted nowmounted
liftIO $ forM_ mountChanged $ \matcher -> liftIO $ forM_ mountChanged $ \matcher ->
#if MIN_VERSION_dbus(0,10,7)
void $ addMatch client matcher handleevent
#else
listen client matcher handleevent listen client matcher handleevent
#endif
, do , do
liftAnnex $ liftAnnex $
warning "No known volume monitor available through dbus; falling back to mtab polling" warning "No known volume monitor available through dbus; falling back to mtab polling"

View file

@ -1,6 +1,6 @@
{- git-annex assistant network connection watcher, using dbus {- git-annex assistant network connection watcher, using dbus
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -18,10 +18,10 @@ import Assistant.DaemonStatus
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
#if WITH_DBUS #if WITH_DBUS
import Assistant.RemoteControl
import Utility.DBus import Utility.DBus
import DBus.Client import DBus.Client
import DBus import DBus
import Data.Word (Word32)
import Assistant.NetMessager import Assistant.NetMessager
#else #else
#ifdef linux_HOST_OS #ifdef linux_HOST_OS
@ -44,8 +44,9 @@ netWatcherThread = thread noop
- while (despite the local network staying up), are synced with - while (despite the local network staying up), are synced with
- periodically. - periodically.
- -
- Note that it does not call notifyNetMessagerRestart, because - Note that it does not call notifyNetMessagerRestart, or
- it doesn't know that the network has changed. - signal the RemoteControl, because it doesn't know that the
- network has changed.
-} -}
netWatcherFallbackThread :: NamedThread netWatcherFallbackThread :: NamedThread
netWatcherFallbackThread = namedThread "NetWatcherFallback" $ netWatcherFallbackThread = namedThread "NetWatcherFallback" $
@ -61,16 +62,22 @@ dbusThread = do
where where
go client = ifM (checkNetMonitor client) go client = ifM (checkNetMonitor client)
( do ( do
listenNMConnections client <~> handleconn callback <- asIO1 connchange
listenWicdConnections client <~> handleconn liftIO $ do
listenNMConnections client callback
listenWicdConnections client callback
, do , do
liftAnnex $ liftAnnex $
warning "No known network monitor available through dbus; falling back to polling" warning "No known network monitor available through dbus; falling back to polling"
) )
handleconn = do connchange False = do
debug ["detected network disconnection"]
sendRemoteControl LOSTNET
connchange True = do
debug ["detected network connection"] debug ["detected network connection"]
notifyNetMessagerRestart notifyNetMessagerRestart
handleConnection handleConnection
sendRemoteControl RESUME
onerr e _ = do onerr e _ = do
liftAnnex $ liftAnnex $
warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
@ -95,38 +102,75 @@ checkNetMonitor client = do
networkmanager = "org.freedesktop.NetworkManager" networkmanager = "org.freedesktop.NetworkManager"
wicd = "org.wicd.daemon" wicd = "org.wicd.daemon"
{- Listens for new NetworkManager connections. -} {- Listens for NetworkManager connections and diconnections.
listenNMConnections :: Client -> IO () -> IO () -
listenNMConnections client callback = - Connection example (once fully connected):
listen client matcher $ \event -> - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}]
when (Just True == anyM activeconnection (signalBody event)) $ -
callback - 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 where
matcher = matchAny matcher = matchAny
{ matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active" { matchInterface = Just "org.freedesktop.NetworkManager"
, matchMember = Just "PropertiesChanged" , matchMember = Just "PropertiesChanged"
} }
nm_connection_activated = toVariant (2 :: Word32) nm_active_connections_key = toVariant ("ActiveConnections" :: String)
nm_state_key = toVariant ("State" :: String) nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String)
activeconnection v = do noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath])
m <- fromVariant v rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/"
vstate <- lookup nm_state_key $ dictionaryItems m handleevent m
state <- fromVariant vstate | lookup nm_active_connections_key m == noconnections =
return $ state == nm_connection_activated setconnected False
| lookup nm_activatingconnection_key m == rootconnection =
setconnected True
| otherwise = noop
{- Listens for new Wicd connections. -} {- Listens for Wicd connections and disconnections.
listenWicdConnections :: Client -> IO () -> IO () -
listenWicdConnections client callback = - Connection example:
listen client matcher $ \event -> - 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)) $ when (any (== wicd_success) (signalBody event)) $
callback setconnected True
match statusmatcher $ \event -> handleevent (signalBody event)
where where
matcher = matchAny connmatcher = matchAny
{ matchInterface = Just "org.wicd.daemon" { matchInterface = Just "org.wicd.daemon"
, matchMember = Just "ConnectResultsSent" , matchMember = Just "ConnectResultsSent"
} }
statusmatcher = matchAny
{ matchInterface = Just "org.wicd.daemon"
, matchMember = Just "StatusChanged"
}
wicd_success = toVariant ("success" :: String) 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 #endif
handleConnection :: Assistant () handleConnection :: Assistant ()

View file

@ -1,6 +1,6 @@
{- git-annex assistant thread to listen for incoming pairing traffic {- git-annex assistant thread to listen for incoming pairing traffic
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -16,13 +16,11 @@ import Assistant.WebApp.Types
import Assistant.Alert import Assistant.Alert
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Utility.Format
import Git import Git
import Network.Multicast import Network.Multicast
import Network.Socket import Network.Socket
import qualified Data.Text as T import qualified Data.Text as T
import Data.Char
pairListenerThread :: UrlRenderer -> NamedThread pairListenerThread :: UrlRenderer -> NamedThread
pairListenerThread urlrenderer = namedThread "PairListener" $ do pairListenerThread urlrenderer = namedThread "PairListener" $ do
@ -39,16 +37,18 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
Nothing -> go reqs cache sock Nothing -> go reqs cache sock
Just m -> do Just m -> do
debug ["received", show msg] debug ["received", show msg]
sane <- checkSane msg
(pip, verified) <- verificationCheck m (pip, verified) <- verificationCheck m
=<< (pairingInProgress <$> getDaemonStatus) =<< (pairingInProgress <$> getDaemonStatus)
let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip
case (wrongstage, fromus, sane, pairMsgStage m) of case (wrongstage, fromus, checkSane (pairMsgData m), pairMsgStage m) of
(_, True, _, _) -> do (_, True, _, _) -> do
debug ["ignoring message that looped back"] debug ["ignoring message that looped back"]
go reqs cache sock go reqs cache sock
(_, _, False, _) -> go reqs cache sock (_, _, False, _) -> do
liftAnnex $ warning
"illegal control characters in pairing message; ignoring"
go reqs cache sock
-- PairReq starts a pairing process, so a -- PairReq starts a pairing process, so a
-- new one is always heeded, even if -- new one is always heeded, even if
-- some other pairing is in process. -- some other pairing is in process.
@ -83,19 +83,10 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
"detected possible pairing brute force attempt; disabled pairing" "detected possible pairing brute force attempt; disabled pairing"
stopSending pip stopSending pip
return (Nothing, False) return (Nothing, False)
|otherwise = return (Just pip, verified && sameuuid) | otherwise = return (Just pip, verified && sameuuid)
where where
verified = verifiedPairMsg m pip verified = verifiedPairMsg m pip
sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m) sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
checkSane msg
{- Control characters could be used in a
- console poisoning attack. -}
| any isControl (filter (/= '\n') (decode_c msg)) = do
liftAnnex $ warning
"illegal control characters in pairing message; ignoring"
return False
| otherwise = return True
{- PairReqs invalidate the cache of recently finished pairings. {- PairReqs invalidate the cache of recently finished pairings.
- This is so that, if a new pairing is started with the - This is so that, if a new pairing is started with the

View file

@ -1,6 +1,6 @@
{- git-annex assistant thread to handle fixing problems with repositories {- git-annex assistant thread to handle fixing problems with repositories
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant git pushing thread {- git-annex assistant git pushing thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -0,0 +1,121 @@
{- git-annex assistant communication with remotedaemon
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.RemoteControl where
import Assistant.Common
import RemoteDaemon.Types
import Config.Files
import Utility.Batch
import Utility.SimpleProtocol
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import qualified Git
import qualified Git.Types as Git
import qualified Remote
import qualified Types.Remote as Remote
import Control.Concurrent
import Control.Concurrent.Async
import Network.URI
import qualified Data.Map as M
import qualified Data.Set as S
remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do
program <- liftIO readProgramFile
(cmd, params) <- liftIO $ toBatchCommand
(program, [Param "remotedaemon"])
let p = proc cmd (toCommand params)
(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
{ std_in = CreatePipe
, std_out = CreatePipe
}
urimap <- liftIO . newMVar =<< liftAnnex getURIMap
controller <- asIO $ remoteControllerThread toh
responder <- asIO $ remoteResponderThread fromh urimap
-- run controller and responder until the remotedaemon dies
liftIO $ void $ tryNonAsync $ controller `concurrently` responder
debug ["remotedaemon exited"]
liftIO $ forceSuccessProcess p pid
-- feed from the remoteControl channel into the remotedaemon
remoteControllerThread :: Handle -> Assistant ()
remoteControllerThread toh = do
clicker <- getAssistant remoteControl
forever $ do
msg <- liftIO $ readChan clicker
debug [show msg]
liftIO $ do
hPutStrLn toh $ unwords $ formatMessage msg
hFlush toh
-- read status messages emitted by the remotedaemon and handle them
remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant ()
remoteResponderThread fromh urimap = go M.empty
where
go syncalerts = do
l <- liftIO $ hGetLine fromh
debug [l]
case parseMessage l of
Just (CONNECTED uri) -> changeconnected S.insert uri
Just (DISCONNECTED uri) -> changeconnected S.delete uri
Just (SYNCING uri) -> withr uri $ \r ->
if M.member (Remote.uuid r) syncalerts
then go syncalerts
else do
i <- addAlert $ syncAlert [r]
go (M.insert (Remote.uuid r) i syncalerts)
Just (DONESYNCING uri status) -> withr uri $ \r ->
case M.lookup (Remote.uuid r) syncalerts of
Nothing -> cont
Just i -> do
let (succeeded, failed) = if status
then ([r], [])
else ([], [r])
updateAlertMap $ mergeAlert i $
syncResultAlert succeeded failed
go (M.delete (Remote.uuid r) syncalerts)
Just (WARNING (RemoteURI uri) msg) -> do
void $ addAlert $
warningAlert ("RemoteControl "++ show uri) msg
cont
Nothing -> do
debug ["protocol error from remotedaemon: ", l]
cont
where
cont = go syncalerts
withr uri = withRemote uri urimap cont
changeconnected sm uri = withr uri $ \r -> do
changeCurrentlyConnected $ sm $ Remote.uuid r
cont
getURIMap :: Annex (M.Map URI Remote)
getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
where
mkk (Git.Url u) = Just u
mkk _ = Nothing
withRemote
:: RemoteURI
-> MVar (M.Map URI Remote)
-> Assistant a
-> (Remote -> Assistant a)
-> Assistant a
withRemote (RemoteURI uri) remotemap noremote a = do
m <- liftIO $ readMVar remotemap
case M.lookup uri m of
Just r -> a r
Nothing -> do
{- Reload map, in case a new remote has been added. -}
m' <- liftAnnex getURIMap
void $ liftIO $ swapMVar remotemap $ m'
maybe noremote a (M.lookup uri m')

View file

@ -1,6 +1,6 @@
{- git-annex assistant sanity checker {- git-annex assistant sanity checker
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -21,9 +21,11 @@ import Assistant.Drop
import Assistant.Ssh import Assistant.Ssh
import Assistant.TransferQueue import Assistant.TransferQueue
import Assistant.Types.UrlRenderer import Assistant.Types.UrlRenderer
import Assistant.Restart
import qualified Annex.Branch import qualified Annex.Branch
import qualified Git
import qualified Git.LsFiles import qualified Git.LsFiles
import qualified Git.Command import qualified Git.Command.Batch
import qualified Git.Config import qualified Git.Config
import Utility.ThreadScheduler import Utility.ThreadScheduler
import qualified Assistant.Threads.Watcher as Watcher import qualified Assistant.Threads.Watcher as Watcher
@ -38,13 +40,14 @@ import Assistant.Unused
import Logs.Unused import Logs.Unused
import Logs.Transfer import Logs.Transfer
import Config.Files import Config.Files
import Utility.DiskFree import Types.Key (keyBackendName)
import qualified Annex import qualified Annex
#ifdef WITH_WEBAPP #ifdef WITH_WEBAPP
import Assistant.WebApp.Types import Assistant.WebApp.Types
#endif #endif
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import Utility.LogFile import Utility.LogFile
import Utility.DiskFree
#endif #endif
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
@ -82,6 +85,11 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
{- Fix up ssh remotes set up by past versions of the assistant. -} {- Fix up ssh remotes set up by past versions of the assistant. -}
liftIO $ fixUpSshRemotes liftIO $ fixUpSshRemotes
{- Clean up old temp files. -}
void $ liftAnnex $ tryNonAsync $ do
cleanOldTmpMisc
cleanReallyOldTmp
{- If there's a startup delay, it's done here. -} {- If there's a startup delay, it's done here. -}
liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
@ -140,6 +148,8 @@ waitForNextCheck = do
- will block the watcher. -} - will block the watcher. -}
dailyCheck :: UrlRenderer -> Assistant Bool dailyCheck :: UrlRenderer -> Assistant Bool
dailyCheck urlrenderer = do dailyCheck urlrenderer = do
checkRepoExists
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
batchmaker <- liftIO getBatchCommandMaker batchmaker <- liftIO getBatchCommandMaker
@ -160,7 +170,7 @@ dailyCheck urlrenderer = do
- to have a lot of small objects and they should not be a - to have a lot of small objects and they should not be a
- significant size. -} - significant size. -}
when (Git.Config.getMaybe "gc.auto" g == Just "0") $ when (Git.Config.getMaybe "gc.auto" g == Just "0") $
liftIO $ void $ Git.Command.runBatch batchmaker liftIO $ void $ Git.Command.Batch.run batchmaker
[ Param "-c", Param "gc.auto=670000" [ Param "-c", Param "gc.auto=670000"
, Param "gc" , Param "gc"
, Param "--auto" , Param "--auto"
@ -197,6 +207,7 @@ dailyCheck urlrenderer = do
hourlyCheck :: Assistant () hourlyCheck :: Assistant ()
hourlyCheck = do hourlyCheck = do
checkRepoExists
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
checkLogSize 0 checkLogSize 0
#else #else
@ -214,10 +225,10 @@ checkLogSize :: Int -> Assistant ()
checkLogSize n = do checkLogSize n = do
f <- liftAnnex $ fromRepo gitAnnexLogFile f <- liftAnnex $ fromRepo gitAnnexLogFile
logs <- liftIO $ listLogs f logs <- liftIO $ listLogs f
totalsize <- liftIO $ sum <$> mapM filesize logs totalsize <- liftIO $ sum <$> mapM getFileSize logs
when (totalsize > 2 * oneMegabyte) $ do when (totalsize > 2 * oneMegabyte) $ do
notice ["Rotated logs due to size:", show totalsize] notice ["Rotated logs due to size:", show totalsize]
liftIO $ openLog f >>= redirLog liftIO $ openLog f >>= handleToFd >>= redirLog
when (n < maxLogs + 1) $ do when (n < maxLogs + 1) $ do
df <- liftIO $ getDiskFree $ takeDirectory f df <- liftIO $ getDiskFree $ takeDirectory f
case df of case df of
@ -226,9 +237,7 @@ checkLogSize n = do
checkLogSize (n + 1) checkLogSize (n + 1)
_ -> noop _ -> noop
where where
filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f) oneMegabyte :: Integer
oneMegabyte :: Int
oneMegabyte = 1000000 oneMegabyte = 1000000
#endif #endif
@ -247,7 +256,7 @@ checkOldUnused :: UrlRenderer -> Assistant ()
checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
where where
go (Just Nothing) = noop go (Just Nothing) = noop
go (Just (Just expireunused)) = expireUnused (Just expireunused) go (Just (Just expireunused)) = expireUnused (Just expireunused)
go Nothing = maybe noop prompt =<< describeUnusedWhenBig go Nothing = maybe noop prompt =<< describeUnusedWhenBig
prompt msg = prompt msg =
@ -258,3 +267,61 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
#else #else
debug [show $ renderTense Past msg] debug [show $ renderTense Past msg]
#endif #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

View file

@ -1,6 +1,6 @@
{- git-annex assistant transfer polling thread {- git-annex assistant transfer polling thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -36,8 +36,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
- temp file being used for the transfer. -} - temp file being used for the transfer. -}
| transferDirection t == Download = do | transferDirection t == Download = do
let f = gitAnnexTmpObjectLocation (transferKey t) g let f = gitAnnexTmpObjectLocation (transferKey t) g
sz <- liftIO $ catchMaybeIO $ sz <- liftIO $ catchMaybeIO $ getFileSize f
fromIntegral . fileSize <$> getFileStatus f
newsize t info sz newsize t info sz
{- Uploads don't need to be polled for when the TransferWatcher {- Uploads don't need to be polled for when the TransferWatcher
- thread can track file modifications. -} - thread can track file modifications. -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant thread to scan remotes to find needed transfers {- git-annex assistant thread to scan remotes to find needed transfers
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -19,7 +19,6 @@ import Assistant.Types.UrlRenderer
import Logs.Transfer import Logs.Transfer
import Logs.Location import Logs.Location
import Logs.Group import Logs.Group
import Logs.Web (webUUID)
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Utility.ThreadScheduler import Utility.ThreadScheduler
@ -115,7 +114,7 @@ failedTransferScan r = do
- since we need to look at the locations of all keys anyway. - since we need to look at the locations of all keys anyway.
-} -}
expensiveScan :: UrlRenderer -> [Remote] -> Assistant () expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()
expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do expensiveScan urlrenderer rs = batch <~> do
debug ["starting scan of", show visiblers] debug ["starting scan of", show visiblers]
let us = map Remote.uuid rs let us = map Remote.uuid rs
@ -135,7 +134,6 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
remove <- asIO1 $ removableRemote urlrenderer remove <- asIO1 $ removableRemote urlrenderer
liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers
where where
onlyweb = all (== webUUID) $ map Remote.uuid rs
visiblers = let rs' = filter (not . Remote.readonly) rs visiblers = let rs' = filter (not . Remote.readonly) rs
in if null rs' then rs else rs' in if null rs' then rs else rs'
@ -151,7 +149,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
enqueue f (r, t) = enqueue f (r, t) =
queueTransferWhenSmall "expensive scan found missing object" queueTransferWhenSmall "expensive scan found missing object"
(Just f) t r (Just f) t r
findtransfers f unwanted (key, _) = do findtransfers f unwanted key = do
{- The syncable remotes may have changed since this {- The syncable remotes may have changed since this
- scan began. -} - scan began. -}
syncrs <- syncDataRemotes <$> getDaemonStatus syncrs <- syncDataRemotes <$> getDaemonStatus

View file

@ -1,6 +1,6 @@
{- git-annex assistant transfer watching thread {- git-annex assistant transfer watching thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant data transferrer thread {- git-annex assistant data transferrer thread
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}

View file

@ -1,6 +1,6 @@
{- git-annex assistant thread to detect when git-annex is upgraded {- git-annex assistant thread to detect when git-annex is upgraded
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -51,9 +51,9 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
let depth = length (splitPath dir) + 1 let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar) void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
-- Ignore bogus events generated during the startup scan. -- Ignore bogus events generated during the startup scan.
-- We ask the watcher to not generate them, but just to be safe.. -- We ask the watcher to not generate them, but just to be safe..
startup mvar scanner = do startup mvar scanner = do
r <- scanner r <- scanner
void $ swapMVar mvar Started void $ swapMVar mvar Started
return r return r

View file

@ -1,6 +1,6 @@
{- git-annex assistant thread to detect when upgrade is available {- git-annex assistant thread to detect when upgrade is available
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -18,11 +18,8 @@ import Assistant.Types.UrlRenderer
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.Alert import Assistant.Alert
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Tmp
import qualified Annex import qualified Annex
import qualified Build.SysConfig import qualified Build.SysConfig
import qualified Utility.Url as Url
import qualified Annex.Url as Url
import qualified Git.Version import qualified Git.Version
import Types.Distribution import Types.Distribution
#ifdef WITH_WEBAPP #ifdef WITH_WEBAPP
@ -42,7 +39,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $
h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus
go h =<< liftIO getCurrentTime go h =<< liftIO getCurrentTime
where where
{- Wait for a network connection event. Then see if it's been {- Wait for a network connection event. Then see if it's been
- half a day since the last upgrade check. If so, proceed with - half a day since the last upgrade check. If so, proceed with
- check. -} - check. -}
go h lastchecked = do go h lastchecked = do
@ -62,7 +59,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $
checkUpgrade :: UrlRenderer -> Assistant () checkUpgrade :: UrlRenderer -> Assistant ()
checkUpgrade urlrenderer = do checkUpgrade urlrenderer = do
debug [ "Checking if an upgrade is available." ] debug [ "Checking if an upgrade is available." ]
go =<< getDistributionInfo go =<< downloadDistributionInfo
where where
go Nothing = debug [ "Failed to check if upgrade is available." ] go Nothing = debug [ "Failed to check if upgrade is available." ]
go (Just d) = do go (Just d) = do
@ -86,16 +83,3 @@ canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled
noop noop
#endif #endif
) )
getDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
getDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions
liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
hClose h
ifM (Url.downloadQuiet distributionInfoUrl tmpfile uo)
( readish <$> readFileStrict tmpfile
, return Nothing
)
distributionInfoUrl :: String
distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"

View file

@ -1,6 +1,6 @@
{- git-annex assistant tree watcher {- git-annex assistant tree watcher
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -35,6 +35,7 @@ import Annex.CatFile
import Annex.CheckIgnore import Annex.CheckIgnore
import Annex.Link import Annex.Link
import Annex.FileMatcher import Annex.FileMatcher
import Types.FileMatcher
import Annex.ReplaceFile import Annex.ReplaceFile
import Git.Types import Git.Types
import Config import Config
@ -71,7 +72,7 @@ needLsof = error $ unlines
{- A special exception that can be thrown to pause or resume the watcher. -} {- A special exception that can be thrown to pause or resume the watcher. -}
data WatcherControl = PauseWatcher | ResumeWatcher data WatcherControl = PauseWatcher | ResumeWatcher
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance E.Exception WatcherControl instance E.Exception WatcherControl
@ -103,13 +104,13 @@ runWatcher = do
, errHook = errhook , errHook = errhook
} }
scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
handle <- liftIO $ watchDir "." ignored scanevents hooks startup h <- liftIO $ watchDir "." ignored scanevents hooks startup
debug [ "watching", "."] debug [ "watching", "."]
{- Let the DirWatcher thread run until signalled to pause it, {- Let the DirWatcher thread run until signalled to pause it,
- then wait for a resume signal, and restart. -} - then wait for a resume signal, and restart. -}
waitFor PauseWatcher $ do waitFor PauseWatcher $ do
liftIO $ stopWatchDir handle liftIO $ stopWatchDir h
waitFor ResumeWatcher runWatcher waitFor ResumeWatcher runWatcher
where where
hook a = Just <$> asIO2 (runHandler a) hook a = Just <$> asIO2 (runHandler a)
@ -183,7 +184,7 @@ runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus r <- tryIO <~> handler (normalize file) filestatus
case r of case r of
Left e -> liftIO $ print e Left e -> liftIO $ warningIO $ show e
Right Nothing -> noop Right Nothing -> noop
Right (Just change) -> do Right (Just change) -> do
-- Just in case the commit thread is not -- Just in case the commit thread is not
@ -191,12 +192,12 @@ runHandler handler file filestatus = void $ do
liftAnnex Annex.Queue.flushWhenFull liftAnnex Annex.Queue.flushWhenFull
recordChange change recordChange change
where where
normalize f normalize f
| "./" `isPrefixOf` file = drop 2 f | "./" `isPrefixOf` file = drop 2 f
| otherwise = f | otherwise = f
{- Small files are added to git as-is, while large ones go into the annex. -} {- Small files are added to git as-is, while large ones go into the annex. -}
add :: FileMatcher -> FilePath -> Assistant (Maybe Change) add :: FileMatcher Annex -> FilePath -> Assistant (Maybe Change)
add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file) add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file)
( pendingAddChange file ( pendingAddChange file
, do , do
@ -205,7 +206,7 @@ add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file)
madeChange file AddFileChange madeChange file AddFileChange
) )
onAdd :: FileMatcher -> Handler onAdd :: FileMatcher Annex -> Handler
onAdd matcher file filestatus onAdd matcher file filestatus
| maybe False isRegularFile filestatus = | maybe False isRegularFile filestatus =
unlessIgnored file $ unlessIgnored file $
@ -218,12 +219,12 @@ shouldRestage ds = scanComplete ds || forceRestage ds
{- In direct mode, add events are received for both new files, and {- In direct mode, add events are received for both new files, and
- modified existing files. - modified existing files.
-} -}
onAddDirect :: Bool -> FileMatcher -> Handler onAddDirect :: Bool -> FileMatcher Annex -> Handler
onAddDirect symlinkssupported matcher file fs = do onAddDirect symlinkssupported matcher file fs = do
v <- liftAnnex $ catKeyFile file v <- liftAnnex $ catKeyFile file
case (v, fs) of case (v, fs) of
(Just key, Just filestatus) -> (Just key, Just filestatus) ->
ifM (liftAnnex $ sameFileStatus key filestatus) ifM (liftAnnex $ sameFileStatus key file filestatus)
{- It's possible to get an add event for {- It's possible to get an add event for
- an existing file that is not - an existing file that is not
- really modified, but it might have - really modified, but it might have
@ -231,7 +232,7 @@ onAddDirect symlinkssupported matcher file fs = do
- so it symlink is restaged to make sure. -} - so it symlink is restaged to make sure. -}
( ifM (shouldRestage <$> getDaemonStatus) ( ifM (shouldRestage <$> getDaemonStatus)
( do ( do
link <- liftAnnex $ inRepo $ gitAnnexLink file key link <- liftAnnex $ calcRepo $ gitAnnexLink file key
addLink file link (Just key) addLink file link (Just key)
, noChange , noChange
) )
@ -245,7 +246,7 @@ onAddDirect symlinkssupported matcher file fs = do
debug ["add direct", file] debug ["add direct", file]
add matcher file add matcher file
where where
{- On a filesystem without symlinks, we'll get changes for regular {- On a filesystem without symlinks, we'll get changes for regular
- files that git uses to stand-in for symlinks. Detect when - files that git uses to stand-in for symlinks. Detect when
- this happens, and stage the symlink, rather than annexing the - this happens, and stage the symlink, rather than annexing the
- file. -} - file. -}
@ -270,15 +271,15 @@ onAddSymlink :: Bool -> Handler
onAddSymlink isdirect file filestatus = unlessIgnored file $ do onAddSymlink isdirect file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
kv <- liftAnnex (Backend.lookupFile file) kv <- liftAnnex (Backend.lookupFile file)
onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus onAddSymlink' linktarget kv isdirect file filestatus
onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
onAddSymlink' linktarget mk isdirect file filestatus = go mk onAddSymlink' linktarget mk isdirect file filestatus = go mk
where where
go (Just key) = do go (Just key) = do
when isdirect $ when isdirect $
liftAnnex $ void $ addAssociatedFile key file liftAnnex $ void $ addAssociatedFile key file
link <- liftAnnex $ inRepo $ gitAnnexLink file key link <- liftAnnex $ calcRepo $ gitAnnexLink file key
if linktarget == Just link if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus then ensurestaged (Just link) =<< getDaemonStatus
else do else do

View file

@ -1,11 +1,12 @@
{- git-annex assistant webapp thread {- git-annex assistant webapp thread
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns, OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
@ -47,6 +48,8 @@ import Yesod
import Network.Socket (SockAddr, HostName) import Network.Socket (SockAddr, HostName)
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
import qualified Network.Wai.Handler.WarpTLS as TLS import qualified Network.Wai.Handler.WarpTLS as TLS
import Network.Wai.Middleware.RequestLogger
import System.Log.Logger
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
@ -83,7 +86,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
setUrlRenderer urlrenderer $ yesodRender webapp (pack "") setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
app <- toWaiAppPlain webapp app <- toWaiAppPlain webapp
app' <- ifM debugEnabled app' <- ifM debugEnabled
( return $ httpDebugLogger app ( return $ logStdout app
, return app , return app
) )
runWebApp tlssettings listenhost' app' $ \addr -> if noannex runWebApp tlssettings listenhost' app' $ \addr -> if noannex
@ -95,7 +98,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
go tlssettings addr webapp htmlshim (Just urlfile) go tlssettings addr webapp htmlshim (Just urlfile)
where where
-- The webapp thread does not wait for the startupSanityCheckThread -- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while -- to finish, so that the user interface remains responsive while
-- that's going on. -- that's going on.
thread = namedThreadUnchecked "WebApp" thread = namedThreadUnchecked "WebApp"
@ -135,3 +138,9 @@ getTlsSettings = do
#else #else
return Nothing return Nothing
#endif #endif
{- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool
debugEnabled = do
l <- getRootLogger
return $ getLevel l <= Just DEBUG

View file

@ -1,6 +1,6 @@
{- git-annex XMPP client {- git-annex XMPP client
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -42,17 +42,20 @@ xmppClientThread urlrenderer = namedThread "XMPPClient" $
restartableClient . xmppClient urlrenderer =<< getAssistant id restartableClient . xmppClient urlrenderer =<< getAssistant id
{- Runs the client, handing restart events. -} {- Runs the client, handing restart events. -}
restartableClient :: (XMPPCreds -> IO ()) -> Assistant () restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant ()
restartableClient a = forever $ go =<< liftAnnex getXMPPCreds restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
where where
go Nothing = waitNetMessagerRestart go Nothing = waitNetMessagerRestart
go (Just creds) = do go (Just creds) = do
tid <- liftIO $ forkIO $ a creds xmppuuid <- maybe NoUUID Remote.uuid . headMaybe
. filter Remote.isXMPPRemote . syncRemotes
<$> getDaemonStatus
tid <- liftIO $ forkIO $ a creds xmppuuid
waitNetMessagerRestart waitNetMessagerRestart
liftIO $ killThread tid liftIO $ killThread tid
xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO () xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO ()
xmppClient urlrenderer d creds = xmppClient urlrenderer d creds xmppuuid =
retry (runclient creds) =<< getCurrentTime retry (runclient creds) =<< getCurrentTime
where where
liftAssistant = runAssistant d liftAssistant = runAssistant d
@ -68,8 +71,11 @@ xmppClient urlrenderer d creds =
liftAssistant $ liftAssistant $
updateBuddyList (const noBuddies) <<~ buddyList updateBuddyList (const noBuddies) <<~ buddyList
void client void client
liftAssistant $ modifyDaemonStatus_ $ \s -> s liftAssistant $ do
{ xmppClientID = Nothing } modifyDaemonStatus_ $ \s -> s
{ xmppClientID = Nothing }
changeCurrentlyConnected $ S.delete xmppuuid
now <- getCurrentTime now <- getCurrentTime
if diffUTCTime now starttime > 300 if diffUTCTime now starttime > 300
then do then do
@ -87,6 +93,7 @@ xmppClient urlrenderer d creds =
inAssistant $ do inAssistant $ do
modifyDaemonStatus_ $ \s -> s modifyDaemonStatus_ $ \s -> s
{ xmppClientID = Just $ xmppJID creds } { xmppClientID = Just $ xmppJID creds }
changeCurrentlyConnected $ S.insert xmppuuid
debug ["connected", logJid selfjid] debug ["connected", logJid selfjid]
lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime
@ -110,7 +117,7 @@ xmppClient urlrenderer d creds =
void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime
inAssistant $ debug inAssistant $ debug
["received:", show $ map logXMPPEvent l] ["received:", show $ map logXMPPEvent l]
mapM_ (handle selfjid) l mapM_ (handlemsg selfjid) l
sendpings selfjid lasttraffic = forever $ do sendpings selfjid lasttraffic = forever $ do
putStanza pingstanza putStanza pingstanza
@ -124,23 +131,23 @@ xmppClient urlrenderer d creds =
{- XEP-0199 says that the server will respond with either {- XEP-0199 says that the server will respond with either
- a ping response or an error message. Either will - a ping response or an error message. Either will
- cause traffic, so good enough. -} - cause traffic, so good enough. -}
pingstanza = xmppPing selfjid pingstanza = xmppPing selfjid
handle selfjid (PresenceMessage p) = do handlemsg selfjid (PresenceMessage p) = do
void $ inAssistant $ void $ inAssistant $
updateBuddyList (updateBuddies p) <<~ buddyList updateBuddyList (updateBuddies p) <<~ buddyList
resendImportantMessages selfjid p resendImportantMessages selfjid p
handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature handlemsg _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us handlemsg _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
handle selfjid (GotNetMessage (PairingNotification stage c u)) = handlemsg selfjid (GotNetMessage (PairingNotification stage c u)) =
maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
handle _ (GotNetMessage m@(Pushing _ pushstage)) handlemsg _ (GotNetMessage m@(Pushing _ pushstage))
| isPushNotice pushstage = inAssistant $ handlePushNotice m | isPushNotice pushstage = inAssistant $ handlePushNotice m
| isPushInitiation pushstage = inAssistant $ queuePushInitiation m | isPushInitiation pushstage = inAssistant $ queuePushInitiation m
| otherwise = inAssistant $ storeInbox m | otherwise = inAssistant $ storeInbox m
handle _ (Ignorable _) = noop handlemsg _ (Ignorable _) = noop
handle _ (Unknown _) = noop handlemsg _ (Unknown _) = noop
handle _ (ProtocolError _) = noop handlemsg _ (ProtocolError _) = noop
resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do
let c = formatJID jid let c = formatJID jid

View file

@ -9,7 +9,7 @@
- they would deadlock with only one thread. For larger numbers of - they would deadlock with only one thread. For larger numbers of
- clients, the two threads are also sufficient. - clients, the two threads are also sufficient.
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -34,7 +34,7 @@ xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack
pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread
pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing
where where
go lastpushedto = do go lastpushedto = do
msg <- waitPushInitiation side $ selectNextPush lastpushedto msg <- waitPushInitiation side $ selectNextPush lastpushedto
debug ["started running push", logNetMessage msg] debug ["started running push", logNetMessage msg]
@ -78,4 +78,4 @@ selectNextPush lastpushedto l = go [] l
(Pushing clientid _) (Pushing clientid _)
| Just clientid /= lastpushedto -> (m, rejected ++ ms) | Just clientid /= lastpushedto -> (m, rejected ++ ms)
_ -> go (m:rejected) ms _ -> go (m:rejected) ms
go [] [] = undefined go [] [] = undefined

Some files were not shown because too many files have changed in this diff Show more