Merge branch 'master' into database
This commit is contained in:
commit
bb242bdd82
4982 changed files with 89117 additions and 85285 deletions
4
.gitignore
vendored
4
.gitignore
vendored
|
@ -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
|
||||||
|
|
7
.mailmap
7
.mailmap
|
@ -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>
|
||||||
|
|
80
Annex.hs
80
Annex.hs
|
@ -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' }
|
||||||
|
|
|
@ -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"
|
||||||
|
]
|
||||||
|
|
117
Annex/Branch.hs
117
Annex/Branch.hs
|
@ -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."
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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 ++ "/"
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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)
|
||||||
|
|
109
Annex/Content.hs
109
Annex/Content.hs
|
@ -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
|
||||||
|
|
|
@ -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
58
Annex/Difference.hs
Normal 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
86
Annex/DirHashes.hs
Normal 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
|
159
Annex/Direct.hs
159
Annex/Direct.hs
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
106
Annex/Init.hs
106
Annex/Init.hs
|
@ -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"
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
72
Annex/LockFile.hs
Normal 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
|
|
@ -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
88
Annex/MakeRepo.hs
Normal 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)
|
|
@ -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
|
|
||||||
|
|
|
@ -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
101
Annex/Notification.hs
Normal 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
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
206
Annex/Ssh.hs
206
Annex/Ssh.hs
|
@ -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
|
||||||
|
|
|
@ -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
145
Annex/Transfer.hs
Normal 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
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
81
Assistant.hs
81
Assistant.hs
|
@ -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
|
||||||
|
|
|
@ -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 = []
|
||||||
}
|
}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
53
Assistant/CredPairCache.hs
Normal file
53
Assistant/CredPairCache.hs
Normal 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'
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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])
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
21
Assistant/RemoteControl.hs
Normal file
21
Assistant/RemoteControl.hs
Normal 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
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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) $
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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 $
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
121
Assistant/Threads/RemoteControl.hs
Normal file
121
Assistant/Threads/RemoteControl.hs
Normal 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')
|
|
@ -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
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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.
|
||||||
-}
|
-}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
Loading…
Reference in a new issue