git-annex (4.20130815) unstable; urgency=low

* assistant, watcher: .gitignore files and other git ignores are now
    honored, when git 1.8.4 or newer is installed.
    (Thanks, Adam Spiers, for getting the necessary support into git for this.)
  * importfeed: Ignores transient problems with feeds. Only exits nonzero
    when a feed has repeatedly had a problems for at least 1 day.
  * importfeed: Fix handling of dots in extensions.
  * Windows: Added support for encrypted special remotes.
  * Windows: Fixed permissions problem that prevented removing files
    from directory special remote. Directory special remotes now fully usable.

# imported from the archive
This commit is contained in:
Joey Hess 2013-08-15 04:14:33 -04:00
commit 341269e035
5105 changed files with 170755 additions and 0 deletions

1
.ghci Normal file
View file

@ -0,0 +1 @@
:load Common

247
Annex.hs Normal file
View file

@ -0,0 +1,247 @@
{- git-annex monad
-
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
module Annex (
Annex,
AnnexState(..),
PreferredContentMap,
new,
newState,
run,
eval,
getState,
changeState,
setFlag,
setField,
setOutput,
getFlag,
getField,
addCleanup,
gitRepo,
inRepo,
fromRepo,
calcRepo,
getGitConfig,
changeGitConfig,
changeGitRepo,
withCurrentState,
) where
import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import System.Posix.Types (Fd)
import Control.Concurrent
import Common
import qualified Git
import qualified Git.Config
import Git.CatFile
import Git.CheckAttr
import Git.CheckIgnore
import Git.SharedRepository
import qualified Git.Queue
import Types.Backend
import Types.GitConfig
import qualified Types.Remote
import Types.Crypto
import Types.BranchState
import Types.TrustLevel
import Types.Group
import Types.Messages
import Types.UUID
import Types.FileMatcher
import qualified Utility.Matcher
import qualified Data.Map as M
import qualified Data.Set as S
{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.
- This allows modifying the state in an exception-safe fashion.
- The MVar is not exposed outside this module.
-}
newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
deriving (
Monad,
MonadIO,
MonadReader (MVar AnnexState),
MonadCatchIO,
Functor,
Applicative
)
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FileInfo -> Annex Bool))
-- internal state storage
data AnnexState = AnnexState
{ repo :: Git.Repo
, gitconfig :: GitConfig
, backends :: [BackendA Annex]
, remotes :: [Types.Remote.RemoteA Annex]
, output :: MessageState
, force :: Bool
, fast :: Bool
, auto :: Bool
, daemon :: Bool
, branchstate :: BranchState
, repoqueue :: Maybe Git.Queue.Queue
, catfilehandles :: M.Map FilePath CatFileHandle
, checkattrhandle :: Maybe CheckAttrHandle
, checkignorehandle :: Maybe (Maybe CheckIgnoreHandle)
, forcebackend :: Maybe String
, forcenumcopies :: Maybe Int
, limit :: Matcher (FileInfo -> Annex Bool)
, uuidmap :: Maybe UUIDMap
, preferredcontentmap :: Maybe PreferredContentMap
, shared :: Maybe SharedRepository
, forcetrust :: TrustMap
, trustmap :: Maybe TrustMap
, groupmap :: Maybe GroupMap
, ciphers :: M.Map StorableCipher Cipher
, lockpool :: M.Map FilePath Fd
, flags :: M.Map String Bool
, fields :: M.Map String String
, cleanup :: M.Map String (Annex ())
, inodeschanged :: Maybe Bool
}
newState :: Git.Repo -> AnnexState
newState gitrepo = AnnexState
{ repo = gitrepo
, gitconfig = extractGitConfig gitrepo
, backends = []
, remotes = []
, output = defaultMessageState
, force = False
, fast = False
, auto = False
, daemon = False
, branchstate = startBranchState
, repoqueue = Nothing
, catfilehandles = M.empty
, checkattrhandle = Nothing
, checkignorehandle = Nothing
, forcebackend = Nothing
, forcenumcopies = Nothing
, limit = Left []
, uuidmap = Nothing
, preferredcontentmap = Nothing
, shared = Nothing
, forcetrust = M.empty
, trustmap = Nothing
, groupmap = Nothing
, ciphers = M.empty
, lockpool = M.empty
, flags = M.empty
, fields = M.empty
, cleanup = M.empty
, inodeschanged = Nothing
}
{- Makes an Annex state object for the specified git repo.
- Ensures the config is read, if it was not already. -}
new :: Git.Repo -> IO AnnexState
new = newState <$$> Git.Config.read
{- Performs an action in the Annex monad from a starting state,
- returning a new state. -}
run :: AnnexState -> Annex a -> IO (a, AnnexState)
run s a = do
mvar <- newMVar s
r <- runReaderT (runAnnex a) mvar
s' <- takeMVar mvar
return (r, s')
{- Performs an action in the Annex monad from a starting state,
- and throws away the new state. -}
eval :: AnnexState -> Annex a -> IO a
eval s a = do
mvar <- newMVar s
runReaderT (runAnnex a) mvar
getState :: (AnnexState -> v) -> Annex v
getState selector = do
mvar <- ask
s <- liftIO $ readMVar mvar
return $ selector s
changeState :: (AnnexState -> AnnexState) -> Annex ()
changeState modifier = do
mvar <- ask
liftIO $ modifyMVar_ mvar $ return . modifier
{- Sets a flag to True -}
setFlag :: String -> Annex ()
setFlag flag = changeState $ \s ->
s { flags = M.insertWith' const flag True $ flags s }
{- Sets a field to a value -}
setField :: String -> String -> Annex ()
setField field value = changeState $ \s ->
s { fields = M.insertWith' const field value $ fields s }
{- Adds a cleanup action to perform. -}
addCleanup :: String -> Annex () -> Annex ()
addCleanup uid a = changeState $ \s ->
s { cleanup = M.insertWith' const uid a $ cleanup s }
{- Sets the type of output to emit. -}
setOutput :: OutputType -> Annex ()
setOutput o = changeState $ \s ->
s { output = (output s) { outputType = o } }
{- Checks if a flag was set. -}
getFlag :: String -> Annex Bool
getFlag flag = fromMaybe False . M.lookup flag <$> getState flags
{- Gets the value of a field. -}
getField :: String -> Annex (Maybe String)
getField field = M.lookup field <$> getState fields
{- Returns the annex's git repository. -}
gitRepo :: Annex Git.Repo
gitRepo = getState repo
{- Runs an IO action in the annex's git repository. -}
inRepo :: (Git.Repo -> IO a) -> Annex a
inRepo a = liftIO . a =<< gitRepo
{- Extracts a value from the annex's git repisitory. -}
fromRepo :: (Git.Repo -> a) -> Annex a
fromRepo a = a <$> gitRepo
{- Calculates a value from an annex's git repository and its GitConfig. -}
calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a
calcRepo a = do
s <- getState id
liftIO $ a (repo s) (gitconfig s)
{- Gets the GitConfig settings. -}
getGitConfig :: Annex GitConfig
getGitConfig = getState gitconfig
{- Modifies a GitConfig setting. -}
changeGitConfig :: (GitConfig -> GitConfig) -> Annex ()
changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) }
{- Changing the git Repo data also involves re-extracting its GitConfig. -}
changeGitRepo :: Git.Repo -> Annex ()
changeGitRepo r = changeState $ \s -> s
{ repo = r
, gitconfig = extractGitConfig r
}
{- Converts an Annex action into an IO action, that runs with a copy
- of the current Annex state.
-
- Use with caution; the action should not rely on changing the
- state, as it will be thrown away. -}
withCurrentState :: Annex a -> Annex (IO a)
withCurrentState a = do
s <- getState id
return $ eval s a

363
Annex/Branch.hs Normal file
View file

@ -0,0 +1,363 @@
{- management of the git-annex branch
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Branch (
fullname,
name,
hasOrigin,
hasSibling,
siblingBranches,
create,
update,
forceUpdate,
updateTo,
get,
change,
commit,
files,
withIndex,
) where
import qualified Data.ByteString.Lazy.Char8 as L
import Common.Annex
import Annex.BranchState
import Annex.Journal
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import qualified Git.Branch
import qualified Git.UnionMerge
import qualified Git.UpdateIndex
import Git.HashObject
import Git.Types
import Git.FilePath
import Annex.CatFile
import Annex.Perms
import qualified Annex
import Utility.Env
{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
name = Git.Ref "git-annex"
{- Fully qualified name of the branch. -}
fullname :: Git.Ref
fullname = Git.Ref $ "refs/heads/" ++ show name
{- Branch's name in origin. -}
originname :: Git.Ref
originname = Git.Ref $ "origin/" ++ show name
{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
hasOrigin = inRepo $ Git.Ref.exists originname
{- Does the git-annex branch or a sibling foo/git-annex branch exist? -}
hasSibling :: Annex Bool
hasSibling = not . null <$> siblingBranches
{- List of git-annex (refs, branches), including the main one and any
- from remotes. Duplicate refs are filtered out. -}
siblingBranches :: Annex [(Git.Ref, Git.Branch)]
siblingBranches = inRepo $ Git.Ref.matchingUniq [name]
{- Creates the branch, if it does not already exist. -}
create :: Annex ()
create = void getBranch
{- Returns the ref of the branch, creating it first if necessary. -}
getBranch :: Annex Git.Ref
getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
where
go True = do
inRepo $ Git.Command.run
[Param "branch", Param $ show name, Param $ show originname]
fromMaybe (error $ "failed to create " ++ show name)
<$> branchsha
go False = withIndex' True $
inRepo $ Git.Branch.commit "branch created" fullname []
use sha = do
setIndexSha sha
return sha
branchsha = inRepo $ Git.Ref.sha fullname
{- Ensures that the branch and index are up-to-date; should be
- called before data is read from it. Runs only once per git-annex run. -}
update :: Annex ()
update = runUpdateOnce $ void $ updateTo =<< siblingBranches
{- Forces an update even if one has already been run. -}
forceUpdate :: Annex Bool
forceUpdate = updateTo =<< siblingBranches
{- Merges the specified Refs into the index, if they have any changes not
- already in it. The Branch names are only used in the commit message;
- it's even possible that the provided Branches have not been updated to
- point to the Refs yet.
-
- The branch is fast-forwarded if possible, otherwise a merge commit is
- made.
-
- Before Refs are merged into the index, it's important to first stage the
- journal into the index. Otherwise, any changes in the journal would
- later get staged, and might overwrite changes made during the merge.
- This is only done if some of the Refs do need to be merged.
-
- Returns True if any refs were merged in, False otherwise.
-}
updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool
updateTo pairs = do
-- ensure branch exists, and get its current ref
branchref <- getBranch
dirty <- journalDirty
(refs, branches) <- unzip <$> filterM isnewer pairs
if null refs
{- Even when no refs need to be merged, the index
- may still be updated if the branch has gotten ahead
- of the index. -}
then whenM (needUpdateIndex branchref) $ lockJournal $ do
forceUpdateIndex branchref
{- When there are journalled changes
- as well as the branch being updated,
- a commit needs to be done. -}
when dirty $
go branchref True [] []
else lockJournal $ go branchref dirty refs branches
return $ not $ null refs
where
isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
go branchref dirty refs branches = withIndex $ do
cleanjournal <- if dirty then stageJournal else return noop
let merge_desc = if null branches
then "update"
else "merging " ++
unwords (map Git.Ref.describe branches) ++
" into " ++ show name
unless (null branches) $ do
showSideAction merge_desc
mergeIndex refs
ff <- if dirty
then return False
else inRepo $ Git.Branch.fastForward fullname refs
if ff
then updateIndex branchref
else commitBranch branchref merge_desc
(nub $ fullname:refs)
liftIO cleanjournal
{- Gets the content of a file, which may be in the journal, or in the index
- (and committed to the branch).
-
- Updates the branch if necessary, to ensure the most up-to-date available
- content is available.
-
- Returns an empty string if the file doesn't exist yet. -}
get :: FilePath -> Annex String
get file = do
update
get' file
{- Like get, but does not merge the branch, so the info returned may not
- reflect changes in remotes.
- (Changing the value this returns, and then merging is always the
- same as using get, and then changing its value.) -}
getStale :: FilePath -> Annex String
getStale = get'
get' :: FilePath -> Annex String
get' file = go =<< getJournalFile file
where
go (Just journalcontent) = return journalcontent
go Nothing = withIndex $ L.unpack <$> catFile fullname file
{- Applies a function to modifiy the content of a file.
-
- Note that this does not cause the branch to be merged, it only
- modifes the current content of the file on the branch.
-}
change :: FilePath -> (String -> String) -> Annex ()
change file a = lockJournal $ a <$> getStale file >>= set file
{- Records new content of a file into the journal -}
set :: FilePath -> String -> Annex ()
set = setJournalFile
{- Stages the journal, and commits staged changes to the branch. -}
commit :: String -> Annex ()
commit message = whenM journalDirty $ lockJournal $ do
cleanjournal <- stageJournal
ref <- getBranch
withIndex $ commitBranch ref message [fullname]
liftIO cleanjournal
{- Commits the staged changes in the index to the branch.
-
- Ensures that the branch's index file is first updated to the state
- of the branch at branchref, before running the commit action. This
- is needed because the branch may have had changes pushed to it, that
- are not yet reflected in the index.
-
- Also safely handles a race that can occur if a change is being pushed
- into the branch at the same time. When the race happens, the commit will
- be made on top of the newly pushed change, but without the index file
- being updated to include it. The result is that the newly pushed
- change is reverted. This race is detected and another commit made
- to fix it.
-
- The branchref value can have been obtained using getBranch at any
- previous point, though getting it a long time ago makes the race
- more likely to occur.
-}
commitBranch :: Git.Ref -> String -> [Git.Ref] -> Annex ()
commitBranch branchref message parents = do
showStoringStateAction
commitBranch' branchref message parents
commitBranch' :: Git.Ref -> String -> [Git.Ref] -> Annex ()
commitBranch' branchref message parents = do
updateIndex branchref
committedref <- inRepo $ Git.Branch.commit message fullname parents
setIndexSha committedref
parentrefs <- commitparents <$> catObject committedref
when (racedetected branchref parentrefs) $
fixrace committedref parentrefs
where
-- look for "parent ref" lines and return the refs
commitparents = map (Git.Ref . snd) . filter isparent .
map (toassoc . L.unpack) . L.lines
toassoc = separate (== ' ')
isparent (k,_) = k == "parent"
{- The race can be detected by checking the commit's
- parent, which will be the newly pushed branch,
- instead of the expected ref that the index was updated to. -}
racedetected expectedref parentrefs
| expectedref `elem` parentrefs = False -- good parent
| otherwise = True -- race!
{- To recover from the race, union merge the lost refs
- into the index, and recommit on top of the bad commit. -}
fixrace committedref lostrefs = do
mergeIndex lostrefs
commitBranch committedref racemessage [committedref]
racemessage = message ++ " (recovery from race)"
{- Lists all files on the branch. There may be duplicates in the list. -}
files :: Annex [FilePath]
files = do
update
withIndex $ do
bfiles <- inRepo $ Git.Command.pipeNullSplitZombie
[ Params "ls-tree --name-only -r -z"
, Param $ show fullname
]
jfiles <- getJournalledFiles
return $ jfiles ++ bfiles
{- Populates the branch's index file with the current branch contents.
-
- This is only done when the index doesn't yet exist, and the index
- is used to build up changes to be commited to the branch, and merge
- in changes from other branches.
-}
genIndex :: Git.Repo -> IO ()
genIndex g = Git.UpdateIndex.streamUpdateIndex g
[Git.UpdateIndex.lsTree fullname g]
{- Merges the specified refs into the index.
- Any changes staged in the index will be preserved. -}
mergeIndex :: [Git.Ref] -> Annex ()
mergeIndex branches = do
h <- catFileHandle
inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches
{- Runs an action using the branch's index file. -}
withIndex :: Annex a -> Annex a
withIndex = withIndex' False
withIndex' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do
f <- fromRepo gitAnnexIndex
g <- gitRepo
#ifdef __ANDROID__
{- This should not be necessary on Android, but there is some
- weird getEnvironment breakage. See
- https://github.com/neurocyte/ghc-android/issues/7
- Use getEnv to get some key environment variables that
- git expects to have. -}
let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
#else
e <- liftIO getEnvironment
#endif
let g' = g { gitEnv = Just $ ("GIT_INDEX_FILE", f):e }
Annex.changeState $ \s -> s { Annex.repo = g' }
checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
unless bootstrapping create
liftIO $ createDirectoryIfMissing True $ takeDirectory f
unless bootstrapping $ inRepo genIndex
r <- a
Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
return r
{- Updates the branch's index to reflect the current contents of the branch.
- Any changes staged in the index will be preserved.
-
- Compares the ref stored in the lock file with the current
- ref of the branch to see if an update is needed.
-}
updateIndex :: Git.Ref -> Annex ()
updateIndex branchref = whenM (needUpdateIndex branchref) $
forceUpdateIndex branchref
forceUpdateIndex :: Git.Ref -> Annex ()
forceUpdateIndex branchref = do
withIndex $ mergeIndex [fullname]
setIndexSha branchref
{- Checks if the index needs to be updated. -}
needUpdateIndex :: Git.Ref -> Annex Bool
needUpdateIndex branchref = do
lock <- fromRepo gitAnnexIndexLock
lockref <- Git.Ref . firstLine <$>
liftIO (catchDefaultIO "" $ readFileStrict lock)
return (lockref /= branchref)
{- Record that the branch's index has been updated to correspond to a
- given ref of the branch. -}
setIndexSha :: Git.Ref -> Annex ()
setIndexSha ref = do
lock <- fromRepo gitAnnexIndexLock
liftIO $ writeFile lock $ show ref ++ "\n"
setAnnexPerm lock
{- Stages the journal into the index and returns an action that will
- clean up the staged journal files, which should only be run once
- the index has been committed to the branch. Should be run within
- lockJournal, to prevent others from modifying the journal. -}
stageJournal :: Annex (IO ())
stageJournal = withIndex $ do
g <- gitRepo
let dir = gitAnnexJournalDir g
fs <- getJournalFiles
liftIO $ do
h <- hashObjectStart g
Git.UpdateIndex.streamUpdateIndex g
[genstream dir h fs]
hashObjectStop h
return $ liftIO $ mapM_ (removeFile . (dir </>)) fs
where
genstream dir h fs streamer = forM_ fs $ \file -> do
let path = dir </> file
sha <- hashFile h path
streamer $ Git.UpdateIndex.updateIndexLine
sha FileBlob (asTopFilePath $ fileJournal file)

43
Annex/BranchState.hs Normal file
View file

@ -0,0 +1,43 @@
{- git-annex branch state management
-
- Runtime state about the git-annex branch.
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.BranchState where
import Common.Annex
import Types.BranchState
import qualified Annex
getState :: Annex BranchState
getState = Annex.getState Annex.branchstate
setState :: BranchState -> Annex ()
setState state = Annex.changeState $ \s -> s { Annex.branchstate = state }
changeState :: (BranchState -> BranchState) -> Annex ()
changeState changer = setState =<< changer <$> getState
{- Runs an action to check that the index file exists, if it's not been
- checked before in this run of git-annex. -}
checkIndexOnce :: Annex () -> Annex ()
checkIndexOnce a = unlessM (indexChecked <$> getState) $ do
a
changeState $ \s -> s { indexChecked = True }
{- Runs an action to update the branch, if it's not been updated before
- in this run of git-annex. -}
runUpdateOnce :: Annex () -> Annex ()
runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do
a
disableUpdate
{- Avoids updating the branch. A useful optimisation when the branch
- is known to have not changed, or git-annex won't be relying on info
- from it. -}
disableUpdate :: Annex ()
disableUpdate = changeState $ \s -> s { branchUpdated = True }

92
Annex/CatFile.hs Normal file
View file

@ -0,0 +1,92 @@
{- git cat-file interface, with handle automatically stored in the Annex monad
-
- Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.CatFile (
catFile,
catObject,
catObjectDetails,
catFileHandle,
catKey,
catKeyFile,
) where
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Common.Annex
import qualified Git
import qualified Git.CatFile
import qualified Annex
import Git.Types
import Git.FilePath
catFile :: Git.Branch -> FilePath -> Annex L.ByteString
catFile branch file = do
h <- catFileHandle
liftIO $ Git.CatFile.catFile h branch file
catObject :: Git.Ref -> Annex L.ByteString
catObject ref = do
h <- catFileHandle
liftIO $ Git.CatFile.catObject h ref
catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha))
catObjectDetails ref = do
h <- catFileHandle
liftIO $ Git.CatFile.catObjectDetails h ref
{- There can be multiple index files, and a different cat-file is needed
- for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -}
catFileHandle :: Annex Git.CatFile.CatFileHandle
catFileHandle = do
m <- Annex.getState Annex.catfilehandles
indexfile <- fromMaybe "" . maybe Nothing (lookup "GIT_INDEX_FILE")
<$> fromRepo gitEnv
case M.lookup indexfile m of
Just h -> return h
Nothing -> do
h <- inRepo Git.CatFile.catFileStart
let m' = M.insert indexfile h m
Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
return h
{- From the Sha or Ref of a symlink back to the key. -}
catKey :: Ref -> Annex (Maybe Key)
catKey ref = do
l <- fromInternalGitPath . encodeW8 . L.unpack <$> catObject ref
return $ if isLinkToAnnex l
then fileKey $ takeFileName l
else Nothing
{- From a file in the repository back to the key.
-
- Prefixing the file with ./ makes this work even if in a subdirectory
- of a repo.
-
- Ideally, this should reflect the key that's staged in the index,
- not the key that's committed to HEAD. Unfortunately, git cat-file
- does not refresh the index file after it's started up, so things
- newly staged in the index won't show up. It does, however, notice
- when branches change.
-
- For command-line git-annex use, that doesn't matter. It's perfectly
- reasonable for things staged in the index after the currently running
- git-annex process to not be noticed by it.
-
- For the assistant, this is much more of a problem, since it commits
- files and then needs to be able to immediately look up their keys.
- OTOH, the assistant doesn't keep changes staged in the index for very
- long at all before committing them -- and it won't look at the keys
- of files until after committing them.
-
- So, this gets info from the index, unless running as a daemon.
-}
catKeyFile :: FilePath -> Annex (Maybe Key)
catKeyFile f = ifM (Annex.getState Annex.daemon)
( catKey $ Ref $ "HEAD:./" ++ f
, catKey $ Ref $ ":./" ++ f
)

35
Annex/CheckAttr.hs Normal file
View file

@ -0,0 +1,35 @@
{- git check-attr interface, with handle automatically stored in the Annex monad
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.CheckAttr (
checkAttr,
checkAttrHandle
) where
import Common.Annex
import qualified Git.CheckAttr as Git
import qualified Annex
{- All gitattributes used by git-annex. -}
annexAttrs :: [Git.Attr]
annexAttrs =
[ "annex.backend"
, "annex.numcopies"
]
checkAttr :: Git.Attr -> FilePath -> Annex String
checkAttr attr file = do
h <- checkAttrHandle
liftIO $ Git.checkAttr h attr file
checkAttrHandle :: Annex Git.CheckAttrHandle
checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle
where
startup = do
h <- inRepo $ Git.checkAttrStart annexAttrs
Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }
return h

32
Annex/CheckIgnore.hs Normal file
View file

@ -0,0 +1,32 @@
{- git check-ignore interface, with handle automatically stored in
- the Annex monad
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.CheckIgnore (
checkIgnored,
checkIgnoreHandle
) where
import Common.Annex
import qualified Git.CheckIgnore as Git
import qualified Annex
checkIgnored :: FilePath -> Annex Bool
checkIgnored file = go =<< checkIgnoreHandle
where
go Nothing = return False
go (Just h) = liftIO $ Git.checkIgnored h file
checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)
checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle
where
startup = do
v <- inRepo $ Git.checkIgnoreStart
when (isNothing v) $
warning "The installed version of git is too old for .gitignores to be honored by git-annex."
Annex.changeState $ \s -> s { Annex.checkignorehandle = Just v }
return v

511
Annex/Content.hs Normal file
View file

@ -0,0 +1,511 @@
{- git-annex file content managing
-
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Content (
inAnnex,
inAnnexSafe,
inAnnexCheck,
lockContent,
getViaTmp,
getViaTmpChecked,
getViaTmpUnchecked,
withTmp,
checkDiskSpace,
moveAnnex,
sendAnnex,
prepSendAnnex,
removeAnnex,
fromAnnex,
moveBad,
getKeysPresent,
saveState,
downloadUrl,
preseedTmp,
freezeContent,
thawContent,
cleanObjectLoc,
) where
import System.IO.Unsafe (unsafeInterleaveIO)
import System.PosixCompat.Files
import Common.Annex
import Logs.Location
import qualified Git
import qualified Annex
import qualified Annex.Queue
import qualified Annex.Branch
import Utility.DiskFree
import Utility.FileMode
import qualified Utility.Url as Url
import Types.Key
import Utility.DataUnits
import Utility.CopyFile
import Config
import Git.SharedRepository
import Annex.Perms
import Annex.Link
import Annex.Content.Direct
import Annex.ReplaceFile
#ifndef mingw32_HOST_OS
import Annex.Exception
#endif
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
{- Runs an arbitrary check on a key's content. -}
inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
inAnnexCheck key check = inAnnex' id False check key
{- Generic inAnnex, handling both indirect and direct mode.
-
- In direct mode, at least one of the associated files must pass the
- check. Additionally, the file must be unmodified.
-}
inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
where
checkindirect loc = do
whenM (fromRepo Git.repoIsUrl) $
error "inAnnex cannot check remote repo"
check loc
checkdirect [] = return bad
checkdirect (loc:locs) = do
r <- check loc
if isgood r
then ifM (goodContent key loc)
( return r
, checkdirect locs
)
else checkdirect locs
{- A safer check; the key's content must not only be present, but
- is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go
where
go f = liftIO $ openforlock f >>= check
#ifndef mingw32_HOST_OS
openforlock f = catchMaybeIO $
openFd f ReadOnly Nothing defaultFileFlags
#else
openforlock _ = return $ Just ()
#endif
check Nothing = return is_missing
#ifndef mingw32_HOST_OS
check (Just h) = do
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
closeFd h
return $ case v of
Just _ -> is_locked
Nothing -> is_unlocked
#else
check (Just _) = return is_unlocked
#endif
#ifndef mingw32_HOST_OS
is_locked = Nothing
#endif
is_unlocked = Just True
is_missing = Just False
{- Content is exclusively locked while running an action that might remove
- it. (If the content is not present, no locking is done.) -}
lockContent :: Key -> Annex a -> Annex a
#ifndef mingw32_HOST_OS
lockContent key a = do
file <- calcRepo $ gitAnnexLocation key
bracketIO (openforlock file >>= lock) unlock (const a)
where
{- Since files are stored with the write bit disabled, have
- to fiddle with permissions to open for an exclusive lock. -}
openforlock f = catchMaybeIO $ ifM (doesFileExist f)
( withModifiedFileMode f
(`unionFileModes` ownerWriteMode)
open
, open
)
where
open = openFd f ReadWrite Nothing defaultFileFlags
lock Nothing = return Nothing
lock (Just fd) = do
v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of
Left _ -> error "content is locked"
Right _ -> return $ Just fd
unlock Nothing = noop
unlock (Just l) = closeFd l
#else
lockContent _key a = a -- no locking for Windows!
#endif
{- Runs an action, passing it a temporary filename to get,
- and if the action succeeds, moves the temp file into
- the annex as a key's content. -}
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmp = getViaTmpChecked (return True)
{- Like getViaTmp, but does not check that there is enough disk space
- for the incoming key. For use when the key content is already on disk
- and not being copied into place. -}
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked = finishGetViaTmp (return True)
getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpChecked check key action = do
tmp <- fromRepo $ gitAnnexTmpLocation key
-- Check that there is enough free disk space.
-- When the temp file already exists, count the space
-- it is using as free.
e <- liftIO $ doesFileExist tmp
alreadythere <- if e
then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
else return 0
ifM (checkDiskSpace Nothing key alreadythere)
( do
when e $ thawContent tmp
finishGetViaTmp check key action
, return False
)
finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
finishGetViaTmp check key action = do
tmpfile <- prepTmp key
ifM (action tmpfile <&&> check)
( do
moveAnnex key tmpfile
logStatus key InfoPresent
return True
, do
-- the tmp file is left behind, in case caller wants
-- to resume its transfer
return False
)
prepTmp :: Key -> Annex FilePath
prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpLocation key
createAnnexDirectory (parentDir tmp)
return tmp
{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
withTmp key action = do
tmp <- prepTmp key
res <- action tmp
liftIO $ nukeFile tmp
return res
{- Checks that there is disk space available to store a given key,
- in a destination (or the annex) printing a warning if not. -}
checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
checkDiskSpace destination key alreadythere = do
reserve <- annexDiskReserve <$> Annex.getGitConfig
free <- liftIO . getDiskFree =<< dir
force <- Annex.getState Annex.force
case (free, keySize key) of
(Just have, Just need) -> do
let ok = (need + reserve <= have + alreadythere) || force
unless ok $
needmorespace (need + reserve - have - alreadythere)
return ok
_ -> return True
where
dir = maybe (fromRepo gitAnnexDir) return destination
needmorespace n =
warning $ "not enough free space, need " ++
roughSize storageUnits True n ++
" more" ++ forcemsg
forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
{- Moves a key's content into .git/annex/objects/
-
- In direct mode, moves it to the associated file, or files.
-
- What if the key there already has content? This could happen for
- various reasons; perhaps the same content is being annexed again.
- Perhaps there has been a hash collision generating the keys.
-
- The current strategy is to assume that in this case it's safe to delete
- one of the two copies of the content; and the one already in the annex
- is left there, assuming it's the original, canonical copy.
-
- I considered being more paranoid, and checking that both files had
- the same content. Decided against it because A) users explicitly choose
- a backend based on its hashing properties and so if they're dealing
- with colliding files it's their own fault and B) adding such a check
- would not catch all cases of colliding keys. For example, perhaps
- a remote has a key; if it's then added again with different content then
- the overall system now has two different peices of content for that
- key, and one of them will probably get deleted later. So, adding the
- check here would only raise expectations that git-annex cannot truely
- meet.
-}
moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = withObjectLoc key storeobject storedirect
where
storeobject dest = ifM (liftIO $ doesFileExist dest)
( alreadyhave
, do
createContentDir dest
liftIO $ moveFile src dest
freezeContent dest
freezeContentDir dest
)
storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
{- In direct mode, the associated file's content may be locally
- modified. In that case, it's preserved. However, the content
- we're moving into the annex may be the only extant copy, so
- it's important we not lose it. So, when the key's content
- cannot be moved to any associated file, it's stored in indirect
- mode.
-}
storedirect = storedirect' storeindirect
storedirect' fallback [] = fallback
storedirect' fallback (f:fs) = do
thawContentDir =<< calcRepo (gitAnnexLocation key)
thawContent src
v <- isAnnexLink f
if (Just key == v)
then do
updateInodeCache key src
replaceFile f $ liftIO . moveFile src
forM_ fs $
addContentWhenNotPresent key f
else ifM (goodContent key f)
( storedirect' alreadyhave fs
, storedirect' fallback fs
)
alreadyhave = liftIO $ removeFile src
{- Runs an action to transfer an object's content.
-
- In direct mode, it's possible for the file to change as it's being sent.
- If this happens, runs the rollback action and returns False. The
- rollback action should remove the data that was transferred.
-}
sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool
sendAnnex key rollback sendobject = go =<< prepSendAnnex key
where
go Nothing = return False
go (Just (f, checksuccess)) = do
r <- sendobject f
ifM checksuccess
( return r
, do
rollback
return False
)
{- Returns a file that contains an object's content,
- and an check to run after the transfer is complete.
-
- In direct mode, it's possible for the file to change as it's being sent,
- and the check detects this case and returns False.
-
- Note that the returned check action is, in some cases, run in the
- Annex monad of the remote that is receiving the object, rather than
- the sender. So it cannot rely on Annex state.
-}
prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
prepSendAnnex key = withObjectLoc key indirect direct
where
indirect f = return $ Just (f, return True)
direct [] = return Nothing
direct (f:fs) = do
cache <- recordedInodeCache key
-- check that we have a good file
ifM (sameInodeCache f cache)
( return $ Just (f, sameInodeCache f cache)
, direct fs
)
{- Performs an action, passing it the location to use for a key's content.
-
- In direct mode, the associated files will be passed. But, if there are
- no associated files for a key, the indirect mode action will be
- performed instead. -}
withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
withObjectLoc key indirect direct = ifM isDirect
( do
fs <- associatedFiles key
if null fs
then goindirect
else direct fs
, goindirect
)
where
goindirect = indirect =<< calcRepo (gitAnnexLocation key)
cleanObjectLoc :: Key -> Annex ()
cleanObjectLoc key = do
file <- calcRepo $ gitAnnexLocation key
unlessM crippledFileSystem $
void $ liftIO $ catchMaybeIO $ allowWrite $ parentDir file
liftIO $ removeparents file (3 :: Int)
where
removeparents _ 0 = noop
removeparents file n = do
let dir = parentDir file
maybe noop (const $ removeparents dir (n-1))
<=< catchMaybeIO $ removeDirectory dir
{- Removes a key's file from .git/annex/objects/
-
- In direct mode, deletes the associated files or files, and replaces
- them with symlinks. -}
removeAnnex :: Key -> Annex ()
removeAnnex key = withObjectLoc key remove removedirect
where
remove file = do
thawContentDir file
liftIO $ nukeFile file
removeInodeCache key
cleanObjectLoc key
removedirect fs = do
thawContentDir =<< calcRepo (gitAnnexLocation key)
cache <- recordedInodeCache key
removeInodeCache key
mapM_ (resetfile cache) fs
resetfile cache f = whenM (sameInodeCache f cache) $ do
l <- inRepo $ gitAnnexLink f key
top <- fromRepo Git.repoPath
cwd <- liftIO getCurrentDirectory
let top' = fromMaybe top $ absNormPath cwd top
let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l)
replaceFile f $ makeAnnexLink l'
{- Moves a key's file out of .git/annex/objects/ -}
fromAnnex :: Key -> FilePath -> Annex ()
fromAnnex key dest = do
file <- calcRepo $ gitAnnexLocation key
thawContentDir file
thawContent file
liftIO $ moveFile file dest
cleanObjectLoc key
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
- returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath
moveBad key = do
src <- calcRepo $ gitAnnexLocation key
bad <- fromRepo gitAnnexBadDir
let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest)
thawContentDir src
liftIO $ moveFile src dest
cleanObjectLoc key
logStatus key InfoMissing
return dest
{- List of keys whose content exists in the annex. -}
getKeysPresent :: Annex [Key]
getKeysPresent = do
direct <- isDirect
dir <- fromRepo gitAnnexObjectDir
liftIO $ traverse direct (2 :: Int) dir
where
traverse direct depth dir = do
contents <- catchDefaultIO [] (dirContents dir)
if depth == 0
then do
contents' <- filterM (present direct) contents
let keys = mapMaybe (fileKey . takeFileName) contents'
continue keys []
else do
let deeper = traverse direct (depth - 1)
continue [] (map deeper contents)
continue keys [] = return keys
continue keys (a:as) = do
{- Force lazy traversal with unsafeInterleaveIO. -}
morekeys <- unsafeInterleaveIO a
continue (morekeys++keys) as
{- In indirect mode, look for the key. In direct mode,
- the inode cache file is only present when a key's content
- is present. -}
present False d = doesFileExist $ contentfile d
present True d = doesFileExist $ contentfile d ++ ".cache"
contentfile d = d </> takeFileName d
{- Things to do to record changes to content when shutting down.
-
- It's acceptable to avoid committing changes to the branch,
- especially if performing a short-lived action.
-}
saveState :: Bool -> Annex ()
saveState nocommit = doSideAction $ do
Annex.Queue.flush
unless nocommit $
whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
Annex.Branch.commit "update"
{- Downloads content from any of a list of urls. -}
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
where
go Nothing = do
opts <- map Param . annexWebOptions <$> Annex.getGitConfig
headers <- getHttpHeaders
liftIO $ anyM (\u -> Url.download u headers opts file) urls
go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
downloadcmd basecmd url =
boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]
<&&> doesFileExist file
gencmd url = massReplace
[ ("%file", shellEscape file)
, ("%url", shellEscape url)
]
{- Copies a key's content, when present, to a temp file.
- This is used to speed up some rsyncs. -}
preseedTmp :: Key -> FilePath -> Annex Bool
preseedTmp key file = go =<< inAnnex key
where
go False = return False
go True = do
ok <- copy
when ok $ thawContent file
return ok
copy = ifM (liftIO $ doesFileExist file)
( return True
, do
s <- calcRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file
)
{- Blocks writing to an annexed file, and modifies file permissions to
- allow reading it, per core.sharedRepository setting. -}
freezeContent :: FilePath -> Annex ()
freezeContent file = unlessM crippledFileSystem $
liftIO . go =<< fromRepo getSharedRepository
where
go GroupShared = modifyFileMode file $
removeModes writeModes .
addModes [ownerReadMode, groupReadMode]
go AllShared = modifyFileMode file $
removeModes writeModes .
addModes readModes
go _ = modifyFileMode file $
removeModes writeModes .
addModes [ownerReadMode]
{- Allows writing to an annexed file that freezeContent was called on
- before. -}
thawContent :: FilePath -> Annex ()
thawContent file = unlessM crippledFileSystem $
liftIO . go =<< fromRepo getSharedRepository
where
go GroupShared = groupWriteRead file
go AllShared = groupWriteRead file
go _ = allowWrite file

251
Annex/Content/Direct.hs Normal file
View file

@ -0,0 +1,251 @@
{- git-annex file content managing for direct mode
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Content.Direct (
associatedFiles,
associatedFilesRelative,
removeAssociatedFile,
removeAssociatedFileUnchecked,
addAssociatedFile,
goodContent,
recordedInodeCache,
updateInodeCache,
addInodeCache,
writeInodeCache,
compareInodeCaches,
compareInodeCachesWith,
sameInodeCache,
elemInodeCaches,
sameFileStatus,
removeInodeCache,
toInodeCache,
inodesChanged,
createInodeSentinalFile,
addContentWhenNotPresent,
) where
import Common.Annex
import qualified Annex
import Annex.Perms
import qualified Git
import Utility.Tmp
import Logs.Location
import Utility.InodeCache
import Utility.CopyFile
import Annex.ReplaceFile
import Annex.Link
{- Absolute FilePaths of Files in the tree that are associated with a key. -}
associatedFiles :: Key -> Annex [FilePath]
associatedFiles key = do
files <- associatedFilesRelative key
top <- fromRepo Git.repoPath
return $ map (top </>) files
{- List of files in the tree that are associated with a key, relative to
- the top of the repo. -}
associatedFilesRelative :: Key -> Annex [FilePath]
associatedFilesRelative key = do
mapping <- calcRepo $ gitAnnexMapping key
liftIO $ catchDefaultIO [] $ do
h <- openFile mapping ReadMode
fileEncoding h
lines <$> hGetContents h
{- Changes the associated files information for a key, applying a
- transformation to the list. Returns new associatedFiles value. -}
changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
changeAssociatedFiles key transform = do
mapping <- calcRepo $ gitAnnexMapping key
files <- associatedFilesRelative key
let files' = transform files
when (files /= files') $ do
createContentDir mapping
liftIO $ viaTmp write mapping $ unlines files'
top <- fromRepo Git.repoPath
return $ map (top </>) files'
where
write file content = do
h <- openFile file WriteMode
fileEncoding h
hPutStr h content
hClose h
{- Removes an associated file. Returns new associatedFiles value.
- Checks if this was the last copy of the object, and updates location
- log. -}
removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
removeAssociatedFile key file = do
fs <- removeAssociatedFileUnchecked key file
when (null fs) $
logStatus key InfoMissing
return fs
{- Removes an associated file. Returns new associatedFiles value. -}
removeAssociatedFileUnchecked :: Key -> FilePath -> Annex [FilePath]
removeAssociatedFileUnchecked key file = do
file' <- normaliseAssociatedFile file
changeAssociatedFiles key $ filter (/= file')
{- Adds an associated file. Returns new associatedFiles value. -}
addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
addAssociatedFile key file = do
file' <- normaliseAssociatedFile file
changeAssociatedFiles key $ \files ->
if file' `elem` files
then files
else file':files
{- Associated files are always stored relative to the top of the repository.
- The input FilePath is relative to the CWD. -}
normaliseAssociatedFile :: FilePath -> Annex FilePath
normaliseAssociatedFile file = do
top <- fromRepo Git.repoPath
liftIO $ relPathDirToFile top <$> absPath file
{- Checks if a file in the tree, associated with a key, has not been modified.
-
- To avoid needing to fsck the file's content, which can involve an
- expensive checksum, this relies on a cache that contains the file's
- expected mtime and inode.
-}
goodContent :: Key -> FilePath -> Annex Bool
goodContent key file = sameInodeCache file =<< recordedInodeCache key
{- Gets the recorded inode cache for a key.
-
- A key can be associated with multiple files, so may return more than
- one. -}
recordedInodeCache :: Key -> Annex [InodeCache]
recordedInodeCache key = withInodeCacheFile key $ \f ->
liftIO $ catchDefaultIO [] $
mapMaybe readInodeCache . lines <$> readFileStrict f
{- Caches an inode for a file.
-
- Anything else already cached is preserved.
-}
updateInodeCache :: Key -> FilePath -> Annex ()
updateInodeCache key file = maybe noop (addInodeCache key)
=<< liftIO (genInodeCache file)
{- Adds another inode to the cache for a key. -}
addInodeCache :: Key -> InodeCache -> Annex ()
addInodeCache key cache = do
oldcaches <- recordedInodeCache key
unlessM (elemInodeCaches cache oldcaches) $
writeInodeCache key (cache:oldcaches)
{- Writes inode cache for a key. -}
writeInodeCache :: Key -> [InodeCache] -> Annex ()
writeInodeCache key caches = withInodeCacheFile key $ \f -> do
createContentDir f
liftIO $ writeFile f $
unlines $ map showInodeCache caches
{- Removes an inode cache. -}
removeInodeCache :: Key -> Annex ()
removeInodeCache key = withInodeCacheFile key $ \f -> do
createContentDir f -- also thaws directory
liftIO $ nukeFile f
withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
{- Checks if a InodeCache matches the current version of a file. -}
sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
sameInodeCache _ [] = return False
sameInodeCache file old = go =<< liftIO (genInodeCache file)
where
go Nothing = return False
go (Just curr) = elemInodeCaches curr old
{- Checks if a FileStatus matches the recorded InodeCache of a file. -}
sameFileStatus :: Key -> FileStatus -> Annex Bool
sameFileStatus key status = do
old <- recordedInodeCache key
let curr = toInodeCache status
case (old, curr) of
(_, Just c) -> elemInodeCaches c old
([], Nothing) -> return True
_ -> return False
{- If the inodes have changed, only the size and mtime are compared. -}
compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
compareInodeCaches x y
| compareStrong x y = return True
| otherwise = ifM inodesChanged
( return $ compareWeak x y
, return False
)
elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
elemInodeCaches _ [] = return False
elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
( return True
, elemInodeCaches c ls
)
compareInodeCachesWith :: Annex InodeComparisonType
compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
{- Copies the contentfile to the associated file, if the associated
- file has no content. If the associated file does have content,
- even if the content differs, it's left unchanged. -}
addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
addContentWhenNotPresent key contentfile associatedfile = do
v <- isAnnexLink associatedfile
when (Just key == v) $ do
replaceFile associatedfile $
liftIO . void . copyFileExternal contentfile
updateInodeCache key associatedfile
{- Some filesystems get new inodes each time they are mounted.
- In order to work on such a filesystem, a sentinal file is used to detect
- when the inodes have changed.
-
- If the sentinal file does not exist, we have to assume that the
- inodes have changed.
-}
inodesChanged :: Annex Bool
inodesChanged = maybe calc return =<< Annex.getState Annex.inodeschanged
where
calc = do
scache <- liftIO . genInodeCache
=<< fromRepo gitAnnexInodeSentinal
scached <- readInodeSentinalFile
let changed = case (scache, scached) of
(Just c1, Just c2) -> not $ compareStrong c1 c2
_ -> True
Annex.changeState $ \s -> s { Annex.inodeschanged = Just changed }
return changed
readInodeSentinalFile :: Annex (Maybe InodeCache)
readInodeSentinalFile = do
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
liftIO $ catchDefaultIO Nothing $
readInodeCache <$> readFile sentinalcachefile
writeInodeSentinalFile :: Annex ()
writeInodeSentinalFile = do
sentinalfile <- fromRepo gitAnnexInodeSentinal
createAnnexDirectory (parentDir sentinalfile)
sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
liftIO $ writeFile sentinalfile ""
liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache)
=<< genInodeCache sentinalfile
{- The sentinal file is only created when first initializing a repository.
- If there are any annexed objects in the repository already, creating
- the file would invalidate their inode caches. -}
createInodeSentinalFile :: Annex ()
createInodeSentinalFile =
unlessM (alreadyexists <||> hasobjects)
writeInodeSentinalFile
where
alreadyexists = isJust <$> readInodeSentinalFile
hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir

232
Annex/Direct.hs Normal file
View file

@ -0,0 +1,232 @@
{- git-annex direct mode
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Direct where
import Common.Annex
import qualified Git
import qualified Git.LsFiles
import qualified Git.Merge
import qualified Git.DiffTree as DiffTree
import Git.Sha
import Git.Types
import Annex.CatFile
import Utility.FileMode
import qualified Annex.Queue
import Logs.Location
import Backend
import Types.KeySource
import Annex.Content
import Annex.Content.Direct
import Annex.Link
import Utility.InodeCache
import Utility.CopyFile
import Annex.Perms
import Annex.ReplaceFile
import Annex.Exception
{- Uses git ls-files to find files that need to be committed, and stages
- them into the index. Returns True if some changes were staged. -}
stageDirect :: Annex Bool
stageDirect = do
Annex.Queue.flush
top <- fromRepo Git.repoPath
(l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
forM_ l go
void $ liftIO cleanup
staged <- Annex.Queue.size
Annex.Queue.flush
return $ staged /= 0
where
{- Determine what kind of modified or deleted file this is, as
- efficiently as we can, by getting any key that's associated
- with it in git, as well as its stat info. -}
go (file, Just sha) = do
shakey <- catKey sha
mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
filekey <- isAnnexLink file
case (shakey, filekey, mstat, toInodeCache =<< mstat) of
(_, Just key, _, _)
| shakey == filekey -> noop
{- A changed symlink. -}
| otherwise -> stageannexlink file key
(Just key, _, _, Just cache) -> do
{- All direct mode files will show as
- modified, so compare the cache to see if
- it really was. -}
oldcache <- recordedInodeCache key
case oldcache of
[] -> modifiedannexed file key cache
_ -> unlessM (elemInodeCaches cache oldcache) $
modifiedannexed file key cache
(Just key, _, Nothing, _) -> deletedannexed file key
(Nothing, _, Nothing, _) -> deletegit file
(_, _, Just _, _) -> addgit file
go _ = noop
modifiedannexed file oldkey cache = do
void $ removeAssociatedFile oldkey file
void $ addDirect file cache
deletedannexed file key = do
void $ removeAssociatedFile key file
deletegit file
stageannexlink file key = do
l <- inRepo $ gitAnnexLink file key
stageSymlink file =<< hashSymlink l
void $ addAssociatedFile key file
addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]
deletegit file = Annex.Queue.addCommand "rm" [Param "-f"] [file]
{- Adds a file to the annex in direct mode. Can fail, if the file is
- modified or deleted while it's being added. -}
addDirect :: FilePath -> InodeCache -> Annex Bool
addDirect file cache = do
showStart "add" file
let source = KeySource
{ keyFilename = file
, contentLocation = file
, inodeCache = Just cache
}
got =<< genKey source =<< chooseBackend file
where
got Nothing = do
showEndFail
return False
got (Just (key, _)) = ifM (sameInodeCache file [cache])
( do
l <- inRepo $ gitAnnexLink file key
stageSymlink file =<< hashSymlink l
addInodeCache key cache
void $ addAssociatedFile key file
logStatus key InfoPresent
showEndOk
return True
, do
showEndFail
return False
)
{- In direct mode, git merge would usually refuse to do anything, since it
- sees present direct mode files as type changed files. To avoid this,
- merge is run with the work tree set to a temp directory.
-
- This should only be used once any changes to the real working tree have
- already been committed, because it overwrites files in the working tree.
-}
mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool
mergeDirect d branch g = do
createDirectoryIfMissing True d
let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
Git.Merge.mergeNonInteractive branch g'
{- Cleans up after a direct mode merge. The merge must have been committed,
- and the commit sha passed in, along with the old sha of the tree
- before the merge. Uses git diff-tree to find files that changed between
- the two shas, and applies those changes to the work tree.
-}
mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
mergeDirectCleanup d oldsha newsha = do
(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
forM_ items updated
void $ liftIO cleanup
liftIO $ removeDirectoryRecursive d
where
updated item = do
void $ tryAnnex $
go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
void $ tryAnnex $
go DiffTree.dstsha DiffTree.dstmode movein movein_raw
where
go getsha getmode a araw
| getsha item == nullSha = noop
| isSymLink (getmode item) =
maybe (araw f) (\k -> void $ a k f)
=<< catKey (getsha item)
| otherwise = araw f
f = DiffTree.file item
moveout = removeDirect
{- Files deleted by the merge are removed from the work tree.
- Empty work tree directories are removed, per git behavior. -}
moveout_raw f = liftIO $ do
nukeFile f
void $ tryIO $ removeDirectory $ parentDir f
{- If the file is already present, with the right content for the
- key, it's left alone. Otherwise, create the symlink and then
- if possible, replace it with the content. -}
movein k f = unlessM (goodContent k f) $ do
l <- inRepo $ gitAnnexLink f k
replaceFile f $ makeAnnexLink l
toDirect k f
{- Any new, modified, or renamed files were written to the temp
- directory by the merge, and are moved to the real work tree. -}
movein_raw f = liftIO $ do
createDirectoryIfMissing True $ parentDir f
void $ tryIO $ rename (d </> f) f
{- If possible, converts a symlink in the working tree into a direct
- mode file. If the content is not available, leaves the symlink
- unchanged. -}
toDirect :: Key -> FilePath -> Annex ()
toDirect k f = fromMaybe noop =<< toDirectGen k f
toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
toDirectGen k f = do
loc <- calcRepo $ gitAnnexLocation k
ifM (liftIO $ doesFileExist loc)
( return $ Just $ fromindirect loc
, do
{- Copy content from another direct file. -}
absf <- liftIO $ absPath f
dlocs <- filterM (goodContent k) =<<
filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
(filter (/= absf) <$> addAssociatedFile k f)
case dlocs of
[] -> return Nothing
(dloc:_) -> return $ Just $ fromdirect dloc
)
where
fromindirect loc = do
{- Move content from annex to direct file. -}
thawContentDir loc
updateInodeCache k loc
void $ addAssociatedFile k f
thawContent loc
replaceFile f $ liftIO . moveFile loc
fromdirect loc = do
replaceFile f $
liftIO . void . copyFileExternal loc
updateInodeCache k f
{- Removes a direct mode file, while retaining its content in the annex
- (unless its content has already been changed). -}
removeDirect :: Key -> FilePath -> Annex ()
removeDirect k f = do
void $ removeAssociatedFileUnchecked k f
unlessM (inAnnex k) $
ifM (goodContent k f)
( moveAnnex k f
, logStatus k InfoMissing
)
liftIO $ do
nukeFile f
void $ tryIO $ removeDirectory $ parentDir f
{- Called when a direct mode file has been changed. Its old content may be
- lost. -}
changedDirect :: Key -> FilePath -> Annex ()
changedDirect oldk f = do
locs <- removeAssociatedFile oldk f
whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
logStatus oldk InfoMissing

65
Annex/Environment.hs Normal file
View file

@ -0,0 +1,65 @@
{- git-annex environment
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Environment where
import Common.Annex
import Utility.UserInfo
import qualified Git.Config
import Config
import Annex.Exception
#ifndef mingw32_HOST_OS
import Utility.Env
#endif
{- Checks that the system's environment allows git to function.
- Git requires a GECOS username, or suitable git configuration, or
- environment variables.
-
- Git also requires the system have a hostname containing a dot.
- Otherwise, it tries various methods to find a FQDN, and will fail if it
- does not. To avoid replicating that code here, which would break if its
- methods change, this function does not check the hostname is valid.
- Instead, code that commits can use ensureCommit.
-}
checkEnvironment :: Annex ()
checkEnvironment = do
gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
when (gitusername == Nothing || gitusername == Just "") $
liftIO checkEnvironmentIO
checkEnvironmentIO :: IO ()
checkEnvironmentIO =
#ifdef mingw32_HOST_OS
noop
#else
whenM (null <$> myUserGecos) $ do
username <- myUserName
ensureEnv "GIT_AUTHOR_NAME" username
ensureEnv "GIT_COMMITTER_NAME" username
where
#ifndef __ANDROID__
-- existing environment is not overwritten
ensureEnv var val = void $ setEnv var val False
#else
-- Environment setting is broken on Android, so this is dealt with
-- in runshell instead.
ensureEnv _ _ = noop
#endif
#endif
{- Runs an action that commits to the repository, and if it fails,
- sets user.email to a dummy value and tries the action again. -}
ensureCommit :: Annex a -> Annex a
ensureCommit a = either retry return =<< tryAnnex a
where
retry _ = do
setConfig (ConfigKey "user.email") =<< liftIO myUserName
a

39
Annex/Exception.hs Normal file
View file

@ -0,0 +1,39 @@
{- 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.
-}
module Annex.Exception (
bracketIO,
tryAnnex,
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 go = M.bracket (liftIO setup) (liftIO . cleanup) go
{- try in the Annex monad -}
tryAnnex :: Annex a -> Annex (Either SomeException a)
tryAnnex = 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

101
Annex/FileMatcher.hs Normal file
View file

@ -0,0 +1,101 @@
{- git-annex file matching
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.FileMatcher where
import qualified Data.Map as M
import Common.Annex
import Limit
import Utility.Matcher
import Types.Group
import Logs.Group
import Logs.Remote
import Annex.UUID
import qualified Annex
import Types.FileMatcher
import Git.FilePath
import Types.Remote (RemoteConfig)
import Data.Either
import qualified Data.Set as S
type FileMatcher = Matcher MatchFiles
checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool
checkFileMatcher matcher file = checkFileMatcher' matcher file S.empty True
checkFileMatcher' :: FileMatcher -> FilePath -> AssumeNotPresent -> Bool -> Annex Bool
checkFileMatcher' matcher file notpresent def
| isEmpty matcher = return def
| otherwise = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
let fi = FileInfo
{ matchFile = matchfile
, relFile = file
}
matchMrun matcher $ \a -> a notpresent fi
matchAll :: FileMatcher
matchAll = generate []
parsedToMatcher :: [Either String (Token MatchFiles)] -> Either String FileMatcher
parsedToMatcher parsed = case partitionEithers parsed of
([], vs) -> Right $ generate vs
(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
exprParser :: GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)]
exprParser groupmap configmap mu expr =
map parse $ tokenizeMatcher expr
where
parse = parseToken
(limitPresent mu)
(limitInDir preferreddir)
groupmap
preferreddir = fromMaybe "public" $
M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
parseToken :: MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles)
parseToken checkpresent checkpreferreddir groupmap t
| t `elem` tokens = Right $ token t
| t == "present" = use checkpresent
| t == "inpreferreddir" = use checkpreferreddir
| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $
M.fromList
[ ("include", limitInclude)
, ("exclude", limitExclude)
, ("copies", limitCopies)
, ("inbackend", limitInBackend)
, ("largerthan", limitSize (>))
, ("smallerthan", limitSize (<))
, ("inallgroup", limitInAllGroup groupmap)
]
where
(k, v) = separate (== '=') t
use a = Operation <$> a v
{- This is really dumb tokenization; there's no support for quoted values.
- Open and close parens are always treated as standalone tokens;
- otherwise tokens must be separated by whitespace. -}
tokenizeMatcher :: String -> [String]
tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
where
splitparens = segmentDelim (`elem` "()")
{- Generates a matcher for files large enough (or meeting other criteria)
- to be added to the annex, rather than directly to git. -}
largeFilesMatcher :: Annex FileMatcher
largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
where
go Nothing = return matchAll
go (Just expr) = do
gm <- groupMap
rc <- readRemoteLog
u <- getUUID
either badexpr return $
parsedToMatcher $ exprParser gm rc (Just u) expr
badexpr e = error $ "bad annex.largefiles configuration: " ++ e

104
Annex/Journal.hs Normal file
View file

@ -0,0 +1,104 @@
{- management of the git-annex journal
-
- The journal is used to queue up changes before they are committed to the
- git-annex branch. Amoung other things, it ensures that if git-annex is
- interrupted, its recorded data is not lost.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Journal where
import System.IO.Binary
import Common.Annex
import Annex.Exception
import qualified Git
import Annex.Perms
{- Records content for a file in the branch to the journal.
-
- Using the journal, rather than immediatly staging content to the index
- avoids git needing to rewrite the index after every change. -}
setJournalFile :: FilePath -> String -> Annex ()
setJournalFile file content = do
createAnnexDirectory =<< fromRepo gitAnnexJournalDir
createAnnexDirectory =<< fromRepo gitAnnexTmpDir
-- journal file is written atomically
jfile <- fromRepo $ journalFile file
tmp <- fromRepo gitAnnexTmpDir
let tmpfile = tmp </> takeFileName jfile
liftIO $ do
writeBinaryFile tmpfile content
moveFile tmpfile jfile
{- Gets any journalled content for a file in the branch. -}
getJournalFile :: FilePath -> Annex (Maybe String)
getJournalFile file = inRepo $ \g -> catchMaybeIO $
readFileStrict $ journalFile file g
{- List of files that have updated content in the journal. -}
getJournalledFiles :: Annex [FilePath]
getJournalledFiles = map fileJournal <$> getJournalFiles
{- List of existing journal files. -}
getJournalFiles :: Annex [FilePath]
getJournalFiles = do
g <- gitRepo
fs <- liftIO $ catchDefaultIO [] $
getDirectoryContents $ gitAnnexJournalDir g
return $ filter (`notElem` [".", ".."]) fs
{- Checks if there are changes in the journal. -}
journalDirty :: Annex Bool
journalDirty = not . null <$> getJournalFiles
{- Produces a filename to use in the journal for a file on the branch.
-
- The journal typically won't have a lot of files in it, so the hashing
- used in the branch is not necessary, and all the files are put directly
- in the journal directory.
-}
journalFile :: FilePath -> Git.Repo -> FilePath
journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
where
mangle c
| c == pathSeparator = "_"
| c == '_' = "__"
| otherwise = [c]
{- Converts a journal file (relative to the journal dir) back to the
- filename on the branch. -}
fileJournal :: FilePath -> FilePath
fileJournal = replace [pathSeparator, pathSeparator] "_" .
replace "_" [pathSeparator]
{- Runs an action that modifies the journal, using locking to avoid
- contention with other git-annex processes. -}
lockJournal :: Annex a -> Annex a
lockJournal a = do
lockfile <- fromRepo gitAnnexJournalLock
createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
bracketIO (lock lockfile mode) unlock (const a)
where
#ifndef mingw32_HOST_OS
lock lockfile mode = do
l <- noUmask mode $ createFile lockfile mode
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
return l
#else
lock lockfile _mode = do
writeFile lockfile ""
return lockfile
#endif
#ifndef mingw32_HOST_OS
unlock = closeFd
#else
unlock = removeFile
#endif

105
Annex/Link.hs Normal file
View file

@ -0,0 +1,105 @@
{- git-annex links to content
-
- On file systems that support them, symlinks are used.
-
- On other filesystems, git instead stores the symlink target in a regular
- file.
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Link where
import Common.Annex
import qualified Annex
import qualified Git.HashObject
import qualified Git.UpdateIndex
import qualified Annex.Queue
import Git.Types
import Git.FilePath
type LinkTarget = String
{- Checks if a file is a link to a key. -}
isAnnexLink :: FilePath -> Annex (Maybe Key)
isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file
{- Gets the link target of a symlink.
-
- On a filesystem that does not support symlinks, fall back to getting the
- link target by looking inside the file.
-
- Returns Nothing if the file is not a symlink, or not a link to annex
- content.
-}
getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( check readSymbolicLink $
return Nothing
, check readSymbolicLink $
check probefilecontent $
return Nothing
)
where
check getlinktarget fallback = do
v <- liftIO $ catchMaybeIO $ getlinktarget file
case v of
Just l
| isLinkToAnnex (fromInternalGitPath l) -> return v
| otherwise -> return Nothing
Nothing -> fallback
probefilecontent f = do
h <- openFile f ReadMode
fileEncoding h
-- The first 8k is more than enough to read; link
-- files are small.
s <- take 8192 <$> hGetContents h
-- If we got the full 8k, the file is too large
if length s == 8192
then do
hClose h
return ""
else do
hClose h
-- If there are any NUL or newline
-- characters, or whitespace, we
-- certianly don't have a link to a
-- git-annex key.
if any (`elem` s) "\0\n\r \t"
then return ""
else return s
{- Creates a link on disk.
-
- On a filesystem that does not support symlinks, writes the link target
- to a file. Note that git will only treat the file as a symlink if
- it's staged as such, so use addAnnexLink when adding a new file or
- modified link to git.
-}
makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do
void $ tryIO $ removeFile file
createSymbolicLink linktarget file
, liftIO $ writeFile file linktarget
)
{- Creates a link on disk, and additionally stages it in git. -}
addAnnexLink :: LinkTarget -> FilePath -> Annex ()
addAnnexLink linktarget file = do
makeAnnexLink linktarget file
stageSymlink file =<< hashSymlink linktarget
{- Injects a symlink target into git, returning its Sha. -}
hashSymlink :: LinkTarget -> Annex Sha
hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $
toInternalGitPath linktarget
{- Stages a symlink to the annex, using a Sha of its target. -}
stageSymlink :: FilePath -> Sha -> Annex ()
stageSymlink file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file sha)

56
Annex/LockPool.hs Normal file
View file

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

105
Annex/Perms.hs Normal file
View file

@ -0,0 +1,105 @@
{- git-annex file permissions
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Perms (
setAnnexPerm,
annexFileMode,
createAnnexDirectory,
noUmask,
createContentDir,
freezeContentDir,
thawContentDir,
) where
import Common.Annex
import Utility.FileMode
import Git.SharedRepository
import qualified Annex
import Config
import System.Posix.Types
withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = maybe startup a =<< Annex.getState Annex.shared
where
startup = do
shared <- fromRepo getSharedRepository
Annex.changeState $ \s -> s { Annex.shared = Just shared }
a shared
{- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally,
- use the default mode, but with core.sharedRepository set,
- allow the group to write, etc. -}
setAnnexPerm :: FilePath -> Annex ()
setAnnexPerm file = unlessM crippledFileSystem $
withShared $ liftIO . go
where
go GroupShared = groupWriteRead file
go AllShared = modifyFileMode file $ addModes $
[ ownerWriteMode, groupWriteMode ] ++ readModes
go _ = noop
{- Gets the appropriate mode to use for creating a file in the annex
- (other than content files, which are locked down more). -}
annexFileMode :: Annex FileMode
annexFileMode = withShared $ return . go
where
go GroupShared = sharedmode
go AllShared = combineModes (sharedmode:readModes)
go _ = stdFileMode
sharedmode = combineModes
[ ownerWriteMode, groupWriteMode
, ownerReadMode, groupReadMode
]
{- Creates a directory inside the gitAnnexDir, including any parent
- directories. Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top
where
top = parentDir <$> fromRepo gitAnnexDir
traverse d below stop
| d `equalFilePath` stop = done
| otherwise = ifM (liftIO $ doesDirectoryExist d)
( done
, traverse (parentDir d) (d:below) stop
)
where
done = forM_ below $ \p -> do
liftIO $ createDirectoryIfMissing True p
setAnnexPerm p
{- Blocks writing to the directory an annexed file is in, to prevent the
- file accidentially being deleted. However, if core.sharedRepository
- is set, this is not done, since the group must be allowed to delete the
- file.
-}
freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $
liftIO . go =<< fromRepo getSharedRepository
where
dir = parentDir file
go GroupShared = groupWriteRead dir
go AllShared = groupWriteRead dir
go _ = preventWrite dir
thawContentDir :: FilePath -> Annex ()
thawContentDir file = unlessM crippledFileSystem $
liftIO $ allowWrite $ parentDir file
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
createContentDir :: FilePath -> Annex ()
createContentDir dest = do
unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
unlessM crippledFileSystem $
liftIO $ allowWrite dir
where
dir = parentDir dest

62
Annex/Queue.hs Normal file
View file

@ -0,0 +1,62 @@
{- git-annex command queue
-
- Copyright 2011, 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Queue (
addCommand,
addUpdateIndex,
flush,
flushWhenFull,
size
) where
import Common.Annex
import Annex hiding (new)
import qualified Git.Queue
import qualified Git.UpdateIndex
{- Adds a git command to the queue. -}
addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
addCommand command params files = do
q <- get
store <=< inRepo $ Git.Queue.addCommand command params files q
{- Adds an update-index stream to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
addUpdateIndex streamer = do
q <- get
store <=< inRepo $ Git.Queue.addUpdateIndex streamer q
{- Runs the queue if it is full. Should be called periodically. -}
flushWhenFull :: Annex ()
flushWhenFull = do
q <- get
when (Git.Queue.full q) flush
{- Runs (and empties) the queue. -}
flush :: Annex ()
flush = do
q <- get
unless (0 == Git.Queue.size q) $ do
showStoringStateAction
q' <- inRepo $ Git.Queue.flush q
store q'
{- Gets the size of the queue. -}
size :: Annex Int
size = Git.Queue.size <$> get
get :: Annex Git.Queue.Queue
get = maybe new return =<< getState repoqueue
new :: Annex Git.Queue.Queue
new = do
q <- Git.Queue.new . annexQueueSize <$> getGitConfig
store q
return q
store :: Git.Queue.Queue -> Annex ()
store q = changeState $ \s -> s { repoqueue = Just q }

39
Annex/ReplaceFile.hs Normal file
View file

@ -0,0 +1,39 @@
{- git-annex file replacing
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.ReplaceFile where
import Common.Annex
import Annex.Perms
import Annex.Exception
{- Replaces a possibly already existing file with a new version,
- atomically, by running an action.
-
- The action is passed a temp file, which it can write to, and once
- done the temp file is moved into place.
-
- The action can throw an IO exception, in which case the temp file
- will be deleted, and the existing file will be preserved.
-
- Throws an IO exception when it was unable to replace the file.
-}
replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
replaceFile file a = do
tmpdir <- fromRepo gitAnnexTmpDir
void $ createAnnexDirectory tmpdir
bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do
a tmpfile
liftIO $ catchIO (rename tmpfile file) (fallback tmpfile)
where
setup tmpdir = do
(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
hClose h
return tmpfile
fallback tmpfile _ = do
createDirectoryIfMissing True $ parentDir file
rename tmpfile file

177
Annex/Ssh.hs Normal file
View file

@ -0,0 +1,177 @@
{- git-annex ssh interface, with connection caching
-
- Copyright 2012,2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Ssh (
sshCachingOptions,
sshCleanup,
sshCacheDir,
sshReadPort,
) where
import qualified Data.Map as M
import Data.Hash.MD5
import Common.Annex
import Annex.LockPool
import qualified Build.SysConfig as SysConfig
import qualified Annex
import Config
import Utility.Env
#ifndef mingw32_HOST_OS
import Annex.Perms
#endif
{- Generates parameters to ssh to a given host (or user@host) on a given
- port, with connection caching. -}
sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
where
go (Nothing, params) = ret params
go (Just socketfile, params) = do
cleanstale
liftIO $ createDirectoryIfMissing True $ parentDir socketfile
lockFile $ socket2lock socketfile
ret params
ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]
-- If the lock pool is empty, this is the first ssh of this
-- run. There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted.
cleanstale = whenM (not . any isLock . M.keys <$> getPool) $
sshCleanup
{- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -}
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
sshInfo (host, port) = go =<< sshCacheDir
where
go Nothing = return (Nothing, [])
go (Just dir) = do
let socketfile = dir </> hostport2socket host port
if valid_unix_socket_path socketfile
then return (Just socketfile, sshConnectionCachingParams socketfile)
else do
socketfile' <- liftIO $ relPathCwdToFile socketfile
if valid_unix_socket_path socketfile'
then return (Just socketfile', sshConnectionCachingParams socketfile')
else return (Nothing, [])
sshConnectionCachingParams :: FilePath -> [CommandParam]
sshConnectionCachingParams socketfile =
[ Param "-S", Param socketfile
, Params "-o ControlMaster=auto -o ControlPersist=yes"
]
{- ssh connection caching creates sockets, so will not work on a
- crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use
- a different filesystem. -}
sshCacheDir :: Annex (Maybe FilePath)
sshCacheDir
| SysConfig.sshconnectioncaching = ifM crippledFileSystem
( maybe (return Nothing) usetmpdir =<< gettmpdir
, ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)
( Just <$> fromRepo gitAnnexSshDir
, return Nothing
)
)
| otherwise = return Nothing
where
gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
createDirectoryIfMissing True tmpdir
return tmpdir
portParams :: Maybe Integer -> [CommandParam]
portParams Nothing = []
portParams (Just port) = [Param "-p", Param $ show port]
{- Stop any unused ssh processes. -}
sshCleanup :: Annex ()
sshCleanup = go =<< sshCacheDir
where
go Nothing = noop
go (Just dir) = do
sockets <- filter (not . isLock) <$>
liftIO (catchDefaultIO [] $ dirContents dir)
forM_ sockets cleanup
cleanup socketfile = do
#ifndef mingw32_HOST_OS
-- Drop any shared lock we have, and take an
-- exclusive lock, without blocking. If the lock
-- succeeds, nothing is using this ssh, and it can
-- be stopped.
let lockfile = socket2lock socketfile
unlockFile lockfile
mode <- annexFileMode
fd <- liftIO $ noUmask mode $
openFd lockfile ReadWrite (Just mode) defaultFileFlags
v <- liftIO $ tryIO $
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of
Left _ -> noop
Right _ -> stopssh socketfile
liftIO $ closeFd fd
#else
stopssh socketfile
#endif
stopssh socketfile = do
let params = sshConnectionCachingParams socketfile
-- "ssh -O stop" is noisy on stderr even with -q
void $ liftIO $ catchMaybeIO $
withQuietOutput createProcessSuccess $
proc "ssh" $ toCommand $
[ Params "-O stop"
] ++ params ++ [Param "any"]
-- Cannot remove the lock file; other processes may
-- be waiting on our exclusive lock to use it.
{- This needs to be as short as possible, due to limitations on the length
- of the path to a socket file. At the same time, it needs to be unique
- for each host.
-}
hostport2socket :: String -> Maybe Integer -> FilePath
hostport2socket host Nothing = hostport2socket' host
hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
hostport2socket' :: String -> FilePath
hostport2socket' s
| length s > 32 = md5s (Str s)
| otherwise = s
socket2lock :: FilePath -> FilePath
socket2lock socket = socket ++ lockExt
isLock :: FilePath -> Bool
isLock f = lockExt `isSuffixOf` f
lockExt :: String
lockExt = ".lock"
{- This is the size of the sun_path component of sockaddr_un, which
- is the limit to the total length of the filename of a unix socket.
-
- On Linux, this is 108. On OSX, 104. TODO: Probe
-}
sizeof_sockaddr_un_sun_path :: Int
sizeof_sockaddr_un_sun_path = 100
{- Note that this looks at the true length of the path in bytes, as it will
- appear on disk. -}
valid_unix_socket_path :: FilePath -> Bool
valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path
{- Parses the SSH port, and returns the other OpenSSH options. If
- several ports are found, the last one takes precedence. -}
sshReadPort :: [String] -> (Maybe Integer, [String])
sshReadPort params = (port, reverse args)
where
(port,args) = aux (Nothing, []) params
aux (p,ps) [] = (p,ps)
aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest
aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
| otherwise = aux (p,q:ps) rest
readPort p = fmap fst $ listToMaybe $ reads p

57
Annex/TaggedPush.hs Normal file
View file

@ -0,0 +1,57 @@
{- git-annex tagged pushes
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.TaggedPush where
import Common.Annex
import qualified Remote
import qualified Annex.Branch
import qualified Git
import qualified Git.Ref
import qualified Git.Command
import Utility.Base64
{- Converts a git branch into a branch that is tagged with a UUID, typically
- the UUID of the repo that will be pushing it, and possibly with other
- information.
-
- Pushing to branches on the remote that have out uuid in them is ugly,
- but it reserves those branches for pushing by us, and so our pushes will
- never conflict with other pushes.
-
- To avoid cluttering up the branch display, the branch is put under
- refs/synced/, rather than the usual refs/remotes/
-
- Both UUIDs and Base64 encoded data are always legal to be used in git
- refs, per git-check-ref-format.
-}
toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
[ Just "refs/synced"
, Just $ fromUUID u
, toB64 <$> info
, Just $ show $ Git.Ref.base b
]
fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
fromTaggedBranch b = case split "/" $ show b of
("refs":"synced":u:info:_base) ->
Just (toUUID u, fromB64Maybe info)
("refs":"synced":u:_base) ->
Just (toUUID u, Nothing)
_ -> Nothing
where
taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
taggedPush u info branch remote = Git.Command.runBool
[ Param "push"
, Param $ Remote.name remote
, Param $ refspec Annex.Branch.name
, Param $ refspec branch
]
where
refspec b = show b ++ ":" ++ show (toTaggedBranch u info b)

74
Annex/UUID.hs Normal file
View file

@ -0,0 +1,74 @@
{- git-annex uuids
-
- Each git repository used by git-annex has an annex.uuid setting that
- uniquely identifies that repository.
-
- UUIDs of remotes are cached in git config, using keys named
- remote.<name>.annex-uuid
-
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.UUID (
getUUID,
getRepoUUID,
getUncachedUUID,
prepUUID,
genUUID,
removeRepoUUID,
storeUUID,
) where
import Common.Annex
import qualified Git
import qualified Git.Config
import Config
import qualified Data.UUID as U
import System.Random
configkey :: ConfigKey
configkey = annexConfig "uuid"
{- Generates a random UUID, that does not include the MAC address. -}
genUUID :: IO UUID
genUUID = UUID . show <$> (randomIO :: IO U.UUID)
{- Get current repository's UUID. -}
getUUID :: Annex UUID
getUUID = getRepoUUID =<< gitRepo
{- Looks up a repo's UUID, caching it in .git/config if it's not already. -}
getRepoUUID :: Git.Repo -> Annex UUID
getRepoUUID r = do
c <- toUUID <$> getConfig cachekey ""
let u = getUncachedUUID r
if c /= u && u /= NoUUID
then do
updatecache u
return u
else return c
where
updatecache u = do
g <- gitRepo
when (g /= r) $ storeUUID cachekey u
cachekey = remoteConfig r "uuid"
removeRepoUUID :: Annex ()
removeRepoUUID = unsetConfig configkey
getUncachedUUID :: Git.Repo -> UUID
getUncachedUUID = toUUID . Git.Config.get key ""
where
(ConfigKey key) = configkey
{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
prepUUID = whenM ((==) NoUUID <$> getUUID) $
storeUUID configkey =<< liftIO genUUID
storeUUID :: ConfigKey -> UUID -> Annex ()
storeUUID configfield = setConfig configfield . fromUUID

53
Annex/Version.hs Normal file
View file

@ -0,0 +1,53 @@
{- git-annex repository versioning
-
- Copyright 2010,2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.Version where
import Common.Annex
import Config
import qualified Annex
type Version = String
defaultVersion :: Version
defaultVersion = "3"
directModeVersion :: Version
directModeVersion = "4"
supportedVersions :: [Version]
supportedVersions = [defaultVersion, directModeVersion]
upgradableVersions :: [Version]
#ifndef mingw32_HOST_OS
upgradableVersions = ["0", "1", "2"]
#else
upgradableVersions = ["2"]
#endif
versionField :: ConfigKey
versionField = annexConfig "version"
getVersion :: Annex (Maybe Version)
getVersion = annexVersion <$> Annex.getGitConfig
setVersion :: Version -> Annex ()
setVersion = setConfig versionField
removeVersion :: Annex ()
removeVersion = unsetConfig versionField
checkVersion :: Version -> Annex ()
checkVersion v
| v `elem` supportedVersions = noop
| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
| otherwise = err "Upgrade git-annex."
where
err msg = error $ "Repository version " ++ v ++
" is not supported. " ++ msg

32
Annex/Wanted.hs Normal file
View file

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

147
Assistant.hs Normal file
View file

@ -0,0 +1,147 @@
{- git-annex assistant daemon
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant where
import qualified Annex
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.NamedThread
import Assistant.Types.ThreadedMonad
import Assistant.Threads.DaemonStatus
import Assistant.Threads.Watcher
import Assistant.Threads.Committer
import Assistant.Threads.Pusher
import Assistant.Threads.Merger
import Assistant.Threads.TransferWatcher
import Assistant.Threads.Transferrer
import Assistant.Threads.SanityChecker
#ifdef WITH_CLIBS
import Assistant.Threads.MountWatcher
#endif
import Assistant.Threads.NetWatcher
import Assistant.Threads.TransferScanner
import Assistant.Threads.TransferPoller
import Assistant.Threads.ConfigMonitor
import Assistant.Threads.Glacier
#ifdef WITH_WEBAPP
import Assistant.WebApp
import Assistant.Threads.WebApp
#ifdef WITH_PAIRING
import Assistant.Threads.PairListener
#endif
#ifdef WITH_XMPP
import Assistant.Threads.XMPPClient
import Assistant.Threads.XMPPPusher
#endif
#else
#warning Building without the webapp. You probably need to install Yesod..
import Assistant.Types.UrlRenderer
#endif
import qualified Utility.Daemon
import Utility.LogFile
import Utility.ThreadScheduler
import qualified Build.SysConfig as SysConfig
import System.Log.Logger
import Network.Socket (HostName)
stopDaemon :: Annex ()
stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
{- Starts the daemon. If the daemon is run in the foreground, once it's
- running, can start the browser.
-
- startbrowser is passed the url and html shim file, as well as the original
- stdout and stderr descriptors. -}
startDaemon :: Bool -> Bool -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
startDaemon assistant foreground listenhost startbrowser = do
Annex.changeState $ \s -> s { Annex.daemon = True }
pidfile <- fromRepo gitAnnexPidFile
logfile <- fromRepo gitAnnexLogFile
logfd <- liftIO $ openLog logfile
if foreground
then do
origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError
let undaemonize a = do
debugM desc $ "logging to " ++ logfile
Utility.Daemon.lockPidFile pidfile
Utility.LogFile.redirLog logfd
a
start undaemonize $
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a origout origerr
else
start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
where
desc
| assistant = "assistant"
| otherwise = "watch"
start daemonize webappwaiter = withThreadState $ \st -> do
checkCanWatch
dstatus <- startDaemonStatus
logfile <- fromRepo gitAnnexLogFile
liftIO $ debugM desc $ "logging to " ++ logfile
liftIO $ daemonize $
flip runAssistant (go webappwaiter)
=<< newAssistantData st dstatus
#ifdef WITH_WEBAPP
go webappwaiter = do
d <- getAssistant id
#else
go _webappwaiter = do
#endif
notice ["starting", desc, "version", SysConfig.packageversion]
urlrenderer <- liftIO newUrlRenderer
mapM_ (startthread urlrenderer)
[ watch $ commitThread
#ifdef WITH_WEBAPP
, assist $ webAppThread d urlrenderer False listenhost Nothing webappwaiter
#ifdef WITH_PAIRING
, assist $ pairListenerThread urlrenderer
#endif
#ifdef WITH_XMPP
, assist $ xmppClientThread urlrenderer
, assist $ xmppSendPackThread urlrenderer
, assist $ xmppReceivePackThread urlrenderer
#endif
#endif
, assist $ pushThread
, assist $ pushRetryThread
, assist $ mergeThread
, assist $ transferWatcherThread
, assist $ transferPollerThread
, assist $ transfererThread
, assist $ daemonStatusThread
, assist $ sanityCheckerDailyThread
, assist $ sanityCheckerHourlyThread
#ifdef WITH_CLIBS
, assist $ mountWatcherThread
#endif
, assist $ netWatcherThread
, assist $ netWatcherFallbackThread
, assist $ transferScannerThread urlrenderer
, assist $ configMonitorThread
, assist $ glacierThread
, watch $ watchThread
]
liftIO waitForTermination
watch a = (True, a)
assist a = (False, a)
startthread urlrenderer (watcher, t)
| watcher || assistant = startNamedThread urlrenderer t
| otherwise = noop

311
Assistant/Alert.hs Normal file
View file

@ -0,0 +1,311 @@
{- git-annex assistant alerts
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings, CPP #-}
module Assistant.Alert where
import Common.Annex
import Assistant.Types.Alert
import Assistant.Alert.Utility
import qualified Remote
import Utility.Tense
import Logs.Transfer
import Data.String
import qualified Data.Text as T
#ifdef WITH_WEBAPP
import Assistant.Monad
import Assistant.DaemonStatus
import Assistant.WebApp.Types
import Assistant.WebApp
import Yesod
#endif
{- Makes a button for an alert that opens a Route. The button will
- close the alert it's attached to when clicked. -}
#ifdef WITH_WEBAPP
mkAlertButton :: T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
mkAlertButton label urlrenderer route = do
close <- asIO1 removeAlert
url <- liftIO $ renderUrl urlrenderer route []
return $ AlertButton
{ buttonLabel = label
, buttonUrl = url
, buttonAction = Just close
}
#endif
renderData :: Alert -> TenseText
renderData = tenseWords . alertData
baseActivityAlert :: Alert
baseActivityAlert = Alert
{ alertClass = Activity
, alertHeader = Nothing
, alertMessageRender = renderData
, alertData = []
, alertCounter = 0
, alertBlockDisplay = False
, alertClosable = False
, alertPriority = Medium
, alertIcon = Just ActivityIcon
, alertCombiner = Nothing
, alertName = Nothing
, alertButton = Nothing
}
warningAlert :: String -> String -> Alert
warningAlert name msg = Alert
{ alertClass = Warning
, alertHeader = Just $ tenseWords ["warning"]
, alertMessageRender = renderData
, alertData = [UnTensed $ T.pack msg]
, alertCounter = 0
, alertBlockDisplay = True
, alertClosable = True
, alertPriority = High
, alertIcon = Just ErrorIcon
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertName = Just $ WarningAlert name
, alertButton = Nothing
}
activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
activityAlert header dat = baseActivityAlert
{ alertHeader = header
, alertData = dat
}
startupScanAlert :: Alert
startupScanAlert = activityAlert Nothing
[Tensed "Performing" "Performed", "startup scan"]
{- Displayed when a shutdown is occurring, so will be seen after shutdown
- has happened. -}
shutdownAlert :: Alert
shutdownAlert = warningAlert "shutdown" "git-annex has been shut down"
commitAlert :: Alert
commitAlert = activityAlert Nothing
[Tensed "Committing" "Committed", "changes to git"]
showRemotes :: [Remote] -> TenseChunk
showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name)
syncAlert :: [Remote] -> Alert
syncAlert rs = baseActivityAlert
{ alertName = Just SyncAlert
, alertHeader = Just $ tenseWords
[Tensed "Syncing" "Synced", "with", showRemotes rs]
, alertPriority = Low
, alertIcon = Just SyncIcon
}
syncResultAlert :: [Remote] -> [Remote] -> Alert
syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $
baseActivityAlert
{ alertName = Just SyncAlert
, alertHeader = Just $ tenseWords msg
}
where
msg
| null succeeded = ["Failed to sync with", showRemotes failed]
| null failed = ["Synced with", showRemotes succeeded]
| otherwise =
[ "Synced with", showRemotes succeeded
, "but not with", showRemotes failed
]
sanityCheckAlert :: Alert
sanityCheckAlert = activityAlert
(Just $ tenseWords [Tensed "Running" "Ran", "daily sanity check"])
["to make sure everything is ok."]
sanityCheckFixAlert :: String -> Alert
sanityCheckFixAlert msg = Alert
{ alertClass = Warning
, alertHeader = Just $ tenseWords ["Fixed a problem"]
, alertMessageRender = render
, alertData = [UnTensed $ T.pack msg]
, alertCounter = 0
, alertBlockDisplay = True
, alertPriority = High
, alertClosable = True
, alertIcon = Just ErrorIcon
, alertName = Just SanityCheckFixAlert
, alertCombiner = Just $ dataCombiner (++)
, alertButton = Nothing
}
where
render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
alerthead = "The daily sanity check found and fixed a problem:"
alertfoot = "If these problems persist, consider filing a bug report."
pairingAlert :: AlertButton -> Alert
pairingAlert button = baseActivityAlert
{ alertData = [ UnTensed "Pairing in progress" ]
, alertPriority = High
, alertButton = Just button
}
pairRequestReceivedAlert :: String -> AlertButton -> Alert
pairRequestReceivedAlert who button = Alert
{ alertClass = Message
, alertHeader = Nothing
, alertMessageRender = renderData
, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
, alertCounter = 0
, alertBlockDisplay = False
, alertPriority = High
, alertClosable = True
, alertIcon = Just InfoIcon
, alertName = Just $ PairAlert who
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = Just button
}
pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
pairRequestAcknowledgedAlert who button = baseActivityAlert
{ alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"]
, alertPriority = High
, alertName = Just $ PairAlert who
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = button
}
xmppNeededAlert :: AlertButton -> Alert
xmppNeededAlert button = Alert
{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
, alertIcon = Just TheCloud
, alertPriority = High
, alertButton = Just button
, alertClosable = True
, alertClass = Message
, alertMessageRender = renderData
, alertCounter = 0
, alertBlockDisplay = True
, alertName = Just $ XMPPNeededAlert
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertData = []
}
cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert
cloudRepoNeededAlert friendname button = Alert
{ alertHeader = Just $ fromString $ unwords
[ "Unable to download files from"
, (fromMaybe "your other devices" friendname) ++ "."
]
, alertIcon = Just ErrorIcon
, alertPriority = High
, alertButton = Just button
, alertClosable = True
, alertClass = Message
, alertMessageRender = renderData
, alertCounter = 0
, alertBlockDisplay = True
, alertName = Just $ CloudRepoNeededAlert
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertData = []
}
remoteRemovalAlert :: String -> AlertButton -> Alert
remoteRemovalAlert desc button = Alert
{ alertHeader = Just $ fromString $
"The repository \"" ++ desc ++
"\" has been emptied, and can now be removed."
, alertIcon = Just InfoIcon
, alertPriority = High
, alertButton = Just button
, alertClosable = True
, alertClass = Message
, alertMessageRender = renderData
, alertCounter = 0
, alertBlockDisplay = True
, alertName = Just $ RemoteRemovalAlert desc
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertData = []
}
{- Show a message that relates to a list of files.
-
- The most recent several files are shown, and a count of any others. -}
fileAlert :: TenseChunk -> [FilePath] -> Alert
fileAlert msg files = (activityAlert Nothing shortfiles)
{ alertName = Just $ FileAlert msg
, alertMessageRender = renderer
, alertCounter = counter
, alertCombiner = Just $ fullCombiner combiner
}
where
maxfilesshown = 10
(somefiles, counter) = splitcounter (dedupadjacent files)
shortfiles = map (fromString . shortFile . takeFileName) somefiles
renderer alert = tenseWords $ msg : alertData alert ++ showcounter
where
showcounter = case alertCounter alert of
0 -> []
_ -> [fromString $ "and " ++ show (alertCounter alert) ++ " other files"]
dedupadjacent (x:y:rest)
| x == y = dedupadjacent (y:rest)
| otherwise = x : dedupadjacent (y:rest)
dedupadjacent (x:[]) = [x]
dedupadjacent [] = []
{- Note that this ensures the counter is never 1; no need to say
- "1 file" when the filename could be shown. -}
splitcounter l
| length l <= maxfilesshown = (l, 0)
| otherwise =
let (keep, rest) = splitAt (maxfilesshown - 1) l
in (keep, length rest)
combiner new old =
let (fs, n) = splitcounter $
dedupadjacent $ alertData new ++ alertData old
cnt = n + alertCounter new + alertCounter old
in old
{ alertData = fs
, alertCounter = cnt
}
addFileAlert :: [FilePath] -> Alert
addFileAlert = fileAlert (Tensed "Adding" "Added")
{- This is only used as a success alert after a transfer, not during it. -}
transferFileAlert :: Direction -> Bool -> FilePath -> Alert
transferFileAlert direction True file
| direction == Upload = fileAlert "Uploaded" [file]
| otherwise = fileAlert "Downloaded" [file]
transferFileAlert direction False file
| direction == Upload = fileAlert "Upload failed" [file]
| otherwise = fileAlert "Download failed" [file]
dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner
dataCombiner combiner = fullCombiner $
\new old -> old { alertData = alertData new `combiner` alertData old }
fullCombiner :: (Alert -> Alert -> Alert) -> AlertCombiner
fullCombiner combiner new old
| alertClass new /= alertClass old = Nothing
| alertName new == alertName old =
Just $! new `combiner` old
| otherwise = Nothing
shortFile :: FilePath -> String
shortFile f
| len < maxlen = f
| otherwise = take half f ++ ".." ++ drop (len - half) f
where
len = length f
maxlen = 20
half = (maxlen - 2) `div` 2

130
Assistant/Alert/Utility.hs Normal file
View file

@ -0,0 +1,130 @@
{- git-annex assistant alert utilities
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Alert.Utility where
import Common.Annex
import Assistant.Types.Alert
import Utility.Tense
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Map as M
{- This is as many alerts as it makes sense to display at a time.
- A display might be smaller, or larger, the point is to not overwhelm the
- user with a ton of alerts. -}
displayAlerts :: Int
displayAlerts = 6
{- This is not a hard maximum, but there's no point in keeping a great
- many filler alerts in an AlertMap, so when there's more than this many,
- they start being pruned, down toward displayAlerts. -}
maxAlerts :: Int
maxAlerts = displayAlerts * 2
type AlertPair = (AlertId, Alert)
{- The desired order is the reverse of:
-
- - Pinned alerts
- - High priority alerts, newest first
- - Medium priority Activity, newest first (mostly used for Activity)
- - Low priority alerts, newest first
- - Filler priorty alerts, newest first
- - Ties are broken by the AlertClass, with Errors etc coming first.
-}
compareAlertPairs :: AlertPair -> AlertPair -> Ordering
compareAlertPairs
(aid, Alert { alertClass = aclass, alertPriority = aprio })
(bid, Alert { alertClass = bclass, alertPriority = bprio })
= compare aprio bprio
`thenOrd` compare aid bid
`thenOrd` compare aclass bclass
sortAlertPairs :: [AlertPair] -> [AlertPair]
sortAlertPairs = sortBy compareAlertPairs
{- Renders an alert's header for display, if it has one. -}
renderAlertHeader :: Alert -> Maybe Text
renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert
{- Renders an alert's message for display. -}
renderAlertMessage :: Alert -> Text
renderAlertMessage alert = renderTense (alertTense alert) $
(alertMessageRender alert) alert
showAlert :: Alert -> String
showAlert alert = T.unpack $ T.unwords $ catMaybes
[ renderAlertHeader alert
, Just $ renderAlertMessage alert
]
alertTense :: Alert -> Tense
alertTense alert
| alertClass alert == Activity = Present
| otherwise = Past
{- Checks if two alerts display the same. -}
effectivelySameAlert :: Alert -> Alert -> Bool
effectivelySameAlert x y = all id
[ alertClass x == alertClass y
, alertHeader x == alertHeader y
, alertData x == alertData y
, alertBlockDisplay x == alertBlockDisplay y
, alertClosable x == alertClosable y
, alertPriority x == alertPriority y
]
makeAlertFiller :: Bool -> Alert -> Alert
makeAlertFiller success alert
| isFiller alert = alert
| otherwise = alert
{ alertClass = if c == Activity then c' else c
, alertPriority = Filler
, alertClosable = True
, alertButton = Nothing
, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
}
where
c = alertClass alert
c'
| success = Success
| otherwise = Error
isFiller :: Alert -> Bool
isFiller alert = alertPriority alert == Filler
{- Updates the Alertmap, adding or updating an alert.
-
- Any old filler that looks the same as the alert is removed.
-
- Or, if the alert has an alertCombiner that combines it with
- an old alert, the old alert is replaced with the result, and the
- alert is removed.
-
- Old filler alerts are pruned once maxAlerts is reached.
-}
mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap
mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
where
pruneSame k al' = k == i || not (effectivelySameAlert al al')
pruneBloat m'
| bloat > 0 = M.fromList $ pruneold $ M.toList m'
| otherwise = m'
where
bloat = M.size m' - maxAlerts
pruneold l =
let (f, rest) = partition (\(_, a) -> isFiller a) l
in drop bloat f ++ rest
updatePrune = pruneBloat $ M.filterWithKey pruneSame $
M.insertWith' const i al m
updateCombine combiner =
let combined = M.mapMaybe (combiner al) m
in if M.null combined
then updatePrune
else M.delete i $ M.union combined m

19
Assistant/BranchChange.hs Normal file
View file

@ -0,0 +1,19 @@
{- git-annex assistant git-annex branch change tracking
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.BranchChange where
import Assistant.Common
import Assistant.Types.BranchChange
import Control.Concurrent.MSampleVar
branchChanged :: Assistant ()
branchChanged = flip writeSV () <<~ (fromBranchChangeHandle . branchChangeHandle)
waitBranchChange :: Assistant ()
waitBranchChange = readSV <<~ (fromBranchChangeHandle . branchChangeHandle)

47
Assistant/Changes.hs Normal file
View file

@ -0,0 +1,47 @@
{- git-annex assistant change tracking
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Changes where
import Assistant.Common
import Assistant.Types.Changes
import Utility.TList
import Data.Time.Clock
import Control.Concurrent.STM
{- Handlers call this when they made a change that needs to get committed. -}
madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change)
madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t)
noChange :: Assistant (Maybe Change)
noChange = return Nothing
{- Indicates an add needs to be done, but has not started yet. -}
pendingAddChange :: FilePath -> Assistant (Maybe Change)
pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f)
{- Gets all unhandled changes.
- Blocks until at least one change is made. -}
getChanges :: Assistant [Change]
getChanges = (atomically . getTList) <<~ changePool
{- Gets all unhandled changes, without blocking. -}
getAnyChanges :: Assistant [Change]
getAnyChanges = (atomically . takeTList) <<~ changePool
{- Puts unhandled changes back into the pool.
- Note: Original order is not preserved. -}
refillChanges :: [Change] -> Assistant ()
refillChanges cs = (atomically . flip appendTList cs) <<~ changePool
{- Records a change to the pool. -}
recordChange :: Change -> Assistant ()
recordChange c = (atomically . flip snocTList c) <<~ changePool
recordChanges :: [Change] -> Assistant ()
recordChanges = refillChanges

23
Assistant/Commits.hs Normal file
View file

@ -0,0 +1,23 @@
{- git-annex assistant commit tracking
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Commits where
import Assistant.Common
import Assistant.Types.Commits
import Utility.TList
import Control.Concurrent.STM
{- Gets all unhandled commits.
- Blocks until at least one commit is made. -}
getCommits :: Assistant [Commit]
getCommits = (atomically . getTList) <<~ commitChan
{- Records a commit in the channel. -}
recordCommit :: Assistant ()
recordCommit = (atomically . flip consTList Commit) <<~ commitChan

14
Assistant/Common.hs Normal file
View file

@ -0,0 +1,14 @@
{- Common infrastructure for the git-annex assistant.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Common (module X) where
import Common.Annex as X
import Assistant.Monad as X
import Assistant.Types.DaemonStatus as X
import Assistant.Types.NamedThread as X
import Assistant.Types.Alert as X

259
Assistant/DaemonStatus.hs Normal file
View file

@ -0,0 +1,259 @@
{- git-annex assistant daemon status
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.DaemonStatus where
import Assistant.Common
import Assistant.Alert.Utility
import Utility.Tmp
import Assistant.Types.NetMessager
import Utility.NotificationBroadcaster
import Logs.Transfer
import Logs.Trust
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git
import Control.Concurrent.STM
import System.Posix.Types
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import qualified Data.Map as M
import qualified Data.Text as T
getDaemonStatus :: Assistant DaemonStatus
getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
modifyDaemonStatus a = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ do
(s, b) <- atomically $ do
r@(s, _) <- a <$> takeTMVar dstatus
putTMVar dstatus s
return r
sendNotification $ changeNotifier s
return b
{- Returns a function that updates the lists of syncable remotes
- and other associated information. -}
calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
calcSyncRemotes = do
rs <- filter (remoteAnnexSync . Remote.gitconfig) .
concat . Remote.byCost <$> Remote.remoteList
alive <- trustExclude DeadTrusted (map Remote.uuid rs)
let good r = Remote.uuid r `elem` alive
let syncable = filter good rs
let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $
filter (not . isXMPPRemote) syncable
return $ \dstatus -> dstatus
{ syncRemotes = syncable
, syncGitRemotes =
filter (not . Remote.specialRemote) syncable
, syncDataRemotes = syncdata
, syncingToCloudRemote = any iscloud syncdata
}
where
iscloud r = not (Remote.readonly r) && Remote.globallyAvailable r
{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant ()
updateSyncRemotes = do
modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
status <- getDaemonStatus
liftIO $ sendNotification $ syncRemotesNotifier status
when (syncingToCloudRemote status) $
updateAlertMap $
M.filter $ \alert ->
alertName alert /= Just CloudRepoNeededAlert
{- Load any previous daemon status file, and store it in a MVar for this
- process to use as its DaemonStatus. Also gets current transfer status. -}
startDaemonStatus :: Annex DaemonStatusHandle
startDaemonStatus = do
file <- fromRepo gitAnnexDaemonStatusFile
status <- liftIO $
flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
transfers <- M.fromList <$> getTransfers
addsync <- calcSyncRemotes
liftIO $ atomically $ newTMVar $ addsync $ status
{ scanComplete = False
, sanityCheckRunning = False
, currentTransfers = transfers
}
{- Don't just dump out the structure, because it will change over time,
- and parts of it are not relevant. -}
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
writeDaemonStatusFile file status =
viaTmp writeFile file =<< serialized <$> getPOSIXTime
where
serialized now = unlines
[ "lastRunning:" ++ show now
, "scanComplete:" ++ show (scanComplete status)
, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
]
readDaemonStatusFile :: FilePath -> IO DaemonStatus
readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
where
parse status = foldr parseline status . lines
parseline line status
| key == "lastRunning" = parseval readtime $ \v ->
status { lastRunning = Just v }
| key == "scanComplete" = parseval readish $ \v ->
status { scanComplete = v }
| key == "sanityCheckRunning" = parseval readish $ \v ->
status { sanityCheckRunning = v }
| key == "lastSanityCheck" = parseval readtime $ \v ->
status { lastSanityCheck = Just v }
| otherwise = status -- unparsable line
where
(key, value) = separate (== ':') line
parseval parser a = maybe status a (parser value)
readtime s = do
d <- parseTime defaultTimeLocale "%s%Qs" s
Just $ utcTimeToPOSIXSeconds d
{- Checks if a time stamp was made after the daemon was lastRunning.
-
- Some slop is built in; this really checks if the time stamp was made
- at least ten minutes after the daemon was lastRunning. This is to
- ensure the daemon shut down cleanly, and deal with minor clock skew.
-
- If the daemon has never ran before, this always returns False.
-}
afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
where
t = realToFrac (timestamp + slop) :: POSIXTime
slop = fromIntegral tenMinutes
tenMinutes :: Int
tenMinutes = 10 * 60
{- Mutates the transfer map. Runs in STM so that the transfer map can
- be modified in the same transaction that modifies the transfer queue.
- Note that this does not send a notification of the change; that's left
- to the caller. -}
adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
adjustTransfersSTM dstatus a = do
s <- takeTMVar dstatus
putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
{- Checks if a transfer is currently running. -}
checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
checkRunningTransferSTM dstatus t = M.member t . currentTransfers
<$> readTMVar dstatus
{- Alters a transfer's info, if the transfer is in the map. -}
alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
{- Updates a transfer's info. Adds the transfer to the map if necessary,
- or if already present, updates it while preserving the old transferTid,
- transferPaused, and bytesComplete values, which are not written to disk. -}
updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
where
merge new old = new
{ transferTid = maybe (transferTid new) Just (transferTid old)
, transferPaused = transferPaused new || transferPaused old
, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
}
updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
where
update s = s { currentTransfers = a (currentTransfers s) }
{- Removes a transfer from the map, and returns its info. -}
removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
where
remove s =
let (info, ts) = M.updateLookupWithKey
(\_k _v -> Nothing)
t (currentTransfers s)
in (s { currentTransfers = ts }, info)
{- Send a notification when a transfer is changed. -}
notifyTransfer :: Assistant ()
notifyTransfer = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ sendNotification
=<< transferNotifier <$> atomically (readTMVar dstatus)
{- Send a notification when alerts are changed. -}
notifyAlert :: Assistant ()
notifyAlert = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ sendNotification
=<< alertNotifier <$> atomically (readTMVar dstatus)
{- Returns the alert's identifier, which can be used to remove it. -}
addAlert :: Alert -> Assistant AlertId
addAlert alert = do
notice [showAlert alert]
notifyAlert `after` modifyDaemonStatus add
where
add s = (s { lastAlertId = i, alertMap = m }, i)
where
i = nextAlertId $ lastAlertId s
m = mergeAlert i alert (alertMap s)
removeAlert :: AlertId -> Assistant ()
removeAlert i = updateAlert i (const Nothing)
updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
updateAlert i a = updateAlertMap $ \m -> M.update a i m
updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
where
update s = s { alertMap = a (alertMap s) }
{- Displays an alert while performing an activity that returns True on
- success.
-
- The alert is left visible afterwards, as filler.
- Old filler is pruned, to prevent the map growing too large. -}
alertWhile :: Alert -> Assistant Bool -> Assistant Bool
alertWhile alert a = alertWhile' alert $ do
r <- a
return (r, r)
{- Like alertWhile, but allows the activity to return a value too. -}
alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
alertWhile' alert a = do
let alert' = alert { alertClass = Activity }
i <- addAlert alert'
(ok, r) <- a
updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
return r
{- Displays an alert while performing an activity, then removes it. -}
alertDuring :: Alert -> Assistant a -> Assistant a
alertDuring alert a = do
i <- addAlert $ alert { alertClass = Activity }
removeAlert i `after` a
{- Remotes using the XMPP transport have urls like xmpp::user@host -}
isXMPPRemote :: Remote -> Bool
isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
where
r = Remote.repo remote
getXMPPClientID :: Remote -> ClientID
getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

98
Assistant/DeleteRemote.hs Normal file
View file

@ -0,0 +1,98 @@
{- git-annex assistant remote deletion utilities
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.DeleteRemote where
import Assistant.Common
import Assistant.Types.UrlRenderer
import Assistant.TransferQueue
import Logs.Transfer
import Logs.Location
import Assistant.DaemonStatus
import qualified Remote
import Remote.List
import qualified Git.Command
import qualified Git.BuildVersion
import Logs.Trust
import qualified Annex
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import Assistant.Alert
import qualified Data.Text as T
#endif
{- Removes a remote (but leave the repository as-is), and returns the old
- Remote data. -}
disableRemote :: UUID -> Assistant Remote
disableRemote uuid = do
remote <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
liftAnnex $ do
inRepo $ Git.Command.run
[ Param "remote"
-- name of this subcommand changed
, Param $
if Git.BuildVersion.older "1.8.0"
then "rm"
else "remove"
, Param (Remote.name remote)
]
void $ remoteListRefresh
updateSyncRemotes
return remote
{- Removes a remote, marking it dead .-}
removeRemote :: UUID -> Assistant Remote
removeRemote uuid = do
liftAnnex $ trustSet uuid DeadTrusted
disableRemote uuid
{- Called when a Remote is probably empty, to remove it.
-
- This does one last check for any objects remaining in the Remote,
- and if there are any, queues Downloads of them, and defers removing
- the remote for later. This is to catch any objects not referred to
- in keys in the current branch.
-}
removableRemote :: UrlRenderer -> UUID -> Assistant ()
removableRemote urlrenderer uuid = do
keys <- getkeys
if null keys
then finishRemovingRemote urlrenderer uuid
else do
r <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
mapM_ (queueremaining r) keys
where
queueremaining r k =
queueTransferWhenSmall "remaining object in unwanted remote"
Nothing (Transfer Download uuid k) r
{- Scanning for keys can take a long time; do not tie up
- the Annex monad while doing it, so other threads continue to
- run. -}
getkeys = do
a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid
liftIO a
{- With the webapp, this asks the user to click on a button to finish
- removing the remote.
-
- Without the webapp, just do the removal now.
-}
finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
#ifdef WITH_WEBAPP
finishRemovingRemote urlrenderer uuid = do
desc <- liftAnnex $ Remote.prettyUUID uuid
button <- mkAlertButton (T.pack "Finish deletion process") urlrenderer $
FinishDeleteRepositoryR uuid
void $ addAlert $ remoteRemovalAlert desc button
#else
finishRemovingRemote _ uuid = void $ removeRemote uuid
#endif

112
Assistant/Drop.hs Normal file
View file

@ -0,0 +1,112 @@
{- git-annex assistant dropping of unwanted content
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Drop where
import Assistant.Common
import Assistant.DaemonStatus
import Logs.Location
import Logs.Trust
import Types.Remote (uuid)
import qualified Remote
import qualified Command.Drop
import Command
import Annex.Wanted
import Annex.Exception
import Config
import Annex.Content.Direct
import qualified Data.Set as S
type Reason = String
{- Drop from local and/or remote when allowed by the preferred content and
- numcopies settings. -}
handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
handleDrops _ _ _ Nothing _ = noop
handleDrops reason fromhere key f knownpresentremote = do
syncrs <- syncDataRemotes <$> getDaemonStatus
locs <- liftAnnex $ loggedLocations key
handleDropsFrom locs syncrs reason fromhere key f knownpresentremote
{- The UUIDs are ones where the content is believed to be present.
- The Remote list can include other remotes that do not have the content;
- only ones that match the UUIDs will be dropped from.
- If allowed to drop fromhere, that drop will be tried first.
-
- In direct mode, all associated files are checked, and only if all
- of them are unwanted are they dropped.
-}
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
handleDropsFrom _ _ _ _ _ Nothing _ = noop
handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
fs <- liftAnnex $ ifM isDirect
( do
l <- associatedFilesRelative key
if null l
then return [afile]
else return l
, return [afile]
)
n <- getcopies fs
if fromhere && checkcopies n Nothing
then go fs rs =<< dropl fs n
else go fs rs n
where
getcopies fs = liftAnnex $ do
(untrusted, have) <- trustPartition UnTrusted locs
numcopies <- maximum <$> mapM (getNumCopies <=< numCopies) fs
return (length have, numcopies, S.fromList untrusted)
{- Check that we have enough copies still to drop the content.
- When the remote being dropped from is untrusted, it was not
- counted as a copy, so having only numcopies suffices. Otherwise,
- we need more than numcopies to safely drop. -}
checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
checkcopies (have, numcopies, untrusted) (Just u)
| S.member u untrusted = have >= numcopies
| otherwise = have > numcopies
decrcopies (have, numcopies, untrusted) Nothing =
(have - 1, numcopies, untrusted)
decrcopies v@(_have, _numcopies, untrusted) (Just u)
| S.member u untrusted = v
| otherwise = decrcopies v Nothing
go _ [] _ = noop
go fs (r:rest) n
| uuid r `S.notMember` slocs = go fs rest n
| checkcopies n (Just $ Remote.uuid r) =
dropr fs r n >>= go fs rest
| otherwise = noop
checkdrop fs n@(have, numcopies, _untrusted) u a =
ifM (liftAnnex $ allM (wantDrop True u . Just) fs)
( ifM (liftAnnex $ safely $ doCommand $ a (Just numcopies))
( do
debug
[ "dropped"
, afile
, "(from " ++ maybe "here" show u ++ ")"
, "(copies now " ++ show (have - 1) ++ ")"
, ": " ++ reason
]
return $ decrcopies n u
, return n
)
, return n
)
dropl fs n = checkdrop fs n Nothing $ \numcopies ->
Command.Drop.startLocal afile numcopies key knownpresentremote
dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
Command.Drop.startRemote afile numcopies key r
safely a = either (const False) id <$> tryAnnex a
slocs = S.fromList locs

101
Assistant/Install.hs Normal file
View file

@ -0,0 +1,101 @@
{- Assistant installation
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Install where
import Assistant.Common
import Assistant.Install.AutoStart
import Assistant.Install.Menu
import Assistant.Ssh
import Config.Files
import Utility.FileMode
import Utility.Shell
import Utility.Tmp
import Utility.Env
#ifdef darwin_HOST_OS
import Utility.OSX
#else
import Utility.FreeDesktop
#endif
standaloneAppBase :: IO (Maybe FilePath)
standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant
- daemon, as well as writing the programFile, and putting a
- git-annex-shell wrapper into ~/.ssh
-
- Note that this is done every time it's started, so if the user moves
- it around, the paths this sets up won't break.
-}
ensureInstalled :: IO ()
ensureInstalled = go =<< standaloneAppBase
where
go Nothing = noop
go (Just base) = do
let program = base </> "git-annex"
programfile <- programFile
createDirectoryIfMissing True (parentDir programfile)
writeFile programfile program
#ifdef darwin_HOST_OS
autostartfile <- userAutoStart osxAutoStartLabel
#else
menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
icondir <- iconDir <$> userDataDir
installMenu program menufile base icondir
autostartfile <- autoStartPath "git-annex" <$> userConfigDir
#endif
installAutoStart program autostartfile
{- This shim is only updated if it doesn't
- already exist with the right content. -}
sshdir <- sshDir
let shim = sshdir </> "git-annex-shell"
let runshell var = "exec " ++ base </> "runshell" ++
" git-annex-shell -c \"" ++ var ++ "\""
let content = unlines
[ shebang_local
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, runshell "$SSH_ORIGINAL_COMMAND"
, "else"
, runshell "$@"
, "fi"
]
curr <- catchDefaultIO "" $ readFileStrict shim
when (curr /= content) $ do
createDirectoryIfMissing True (parentDir shim)
viaTmp writeFile shim content
modifyFileMode shim $ addModes [ownerExecuteMode]
{- Returns a cleaned up environment that lacks settings used to make the
- standalone builds use their bundled libraries and programs.
- Useful when calling programs not included in the standalone builds.
-
- For a non-standalone build, returns Nothing.
-}
cleanEnvironment :: IO (Maybe [(String, String)])
cleanEnvironment = clean <$> getEnvironment
where
clean env
| null vars = Nothing
| otherwise = Just $ catMaybes $ map (restoreorig env) env
| otherwise = Nothing
where
vars = words $ fromMaybe "" $
lookup "GIT_ANNEX_STANDLONE_ENV" env
restoreorig oldenv p@(k, _v)
| k `elem` vars = case lookup ("ORIG_" ++ k) oldenv of
Nothing -> Nothing
(Just v') -> Just (k, v')
| otherwise = Just p

View file

@ -0,0 +1,39 @@
{- Assistant autostart file installation
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Install.AutoStart where
import Utility.FreeDesktop
#ifdef darwin_HOST_OS
import Utility.OSX
import Utility.Path
import System.Directory
#endif
installAutoStart :: FilePath -> FilePath -> IO ()
installAutoStart command file = do
#ifdef darwin_HOST_OS
createDirectoryIfMissing True (parentDir file)
writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
["assistant", "--autostart"]
#else
writeDesktopMenuFile (fdoAutostart command) file
#endif
osxAutoStartLabel :: String
osxAutoStartLabel = "com.branchable.git-annex.assistant"
fdoAutostart :: FilePath -> DesktopEntry
fdoAutostart command = genDesktopEntry
"Git Annex Assistant"
"Autostart"
False
(command ++ " assistant --autostart")
Nothing
[]

47
Assistant/Install/Menu.hs Normal file
View file

@ -0,0 +1,47 @@
{- Assistant menu installation.
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Install.Menu where
import Common
import Utility.FreeDesktop
installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
installMenu command menufile iconsrcdir icondir = do
#ifdef darwin_HOST_OS
return ()
#else
writeDesktopMenuFile (fdoDesktopMenu command) menufile
installIcon (iconsrcdir </> "logo.svg") $
iconFilePath (iconBaseName ++ ".svg") "scalable" icondir
installIcon (iconsrcdir </> "favicon.png") $
iconFilePath (iconBaseName ++ ".png") "16x16" icondir
#endif
{- The command can be either just "git-annex", or the full path to use
- to run it. -}
fdoDesktopMenu :: FilePath -> DesktopEntry
fdoDesktopMenu command = genDesktopEntry
"Git Annex"
"Track and sync the files in your Git Annex"
False
(command ++ " webapp")
(Just iconBaseName)
["Network", "FileTransfer"]
installIcon :: FilePath -> FilePath -> IO ()
installIcon src dest = do
createDirectoryIfMissing True (parentDir dest)
withBinaryFile src ReadMode $ \hin ->
withBinaryFile dest WriteMode $ \hout ->
hGetContents hin >>= hPutStr hout
iconBaseName :: String
iconBaseName = "git-annex"

175
Assistant/MakeRemote.hs Normal file
View file

@ -0,0 +1,175 @@
{- git-annex assistant remote creation utilities
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.MakeRemote where
import Assistant.Common
import Assistant.Ssh
import Assistant.Sync
import qualified Types.Remote as R
import qualified Remote
import Remote.List
import qualified Remote.Rsync as Rsync
import qualified Git
import qualified Git.Command
import qualified Command.InitRemote
import Logs.UUID
import Logs.Remote
import Git.Remote
import Config
import Config.Cost
import Creds
import qualified Data.Text as T
import qualified Data.Map as M
type RemoteName = String
{- Sets up and begins syncing with a new ssh or rsync remote. -}
makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
makeSshRemote forcersync sshdata mcost = do
r <- liftAnnex $
addRemote $ maker (sshRepoName sshdata) sshurl
liftAnnex $ maybe noop (setRemoteCost r) mcost
syncRemote r
return r
where
rsync = forcersync || rsyncOnly sshdata
maker
| rsync = makeRsyncRemote
| otherwise = makeGitRemote
sshurl = T.unpack $ T.concat $
if rsync
then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
else [T.pack "ssh://", u, h, d, T.pack "/"]
where
u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
h = sshHostName sshdata
d
| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata
| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]
| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
{- Runs an action that returns a name of the remote, and finishes adding it. -}
addRemote :: Annex RemoteName -> Annex Remote
addRemote a = do
name <- a
void remoteListRefresh
maybe (error "failed to add remote") return
=<< Remote.byName (Just name)
{- Inits a rsync special remote, and returns its name. -}
makeRsyncRemote :: RemoteName -> String -> Annex String
makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Command.InitRemote.findExisting name
where
go Nothing = setupSpecialRemote name Rsync.remote config
=<< Command.InitRemote.generateNew name
go (Just v) = setupSpecialRemote name Rsync.remote config v
config = M.fromList
[ ("encryption", "shared")
, ("rsyncurl", location)
, ("type", "rsync")
]
type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
{- Inits a new special remote. The name is used as a suggestion, but
- will be changed if there is already a special remote with that name. -}
initSpecialRemote :: SpecialRemoteMaker
initSpecialRemote name remotetype config = go 0
where
go :: Int -> Annex RemoteName
go n = do
let fullname = if n == 0 then name else name ++ show n
r <- Command.InitRemote.findExisting fullname
case r of
Nothing -> setupSpecialRemote fullname remotetype config
=<< Command.InitRemote.generateNew fullname
Just _ -> go (n + 1)
{- Enables an existing special remote. -}
enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype config = do
r <- Command.InitRemote.findExisting name
case r of
Nothing -> error $ "Cannot find a special remote named " ++ name
Just v -> setupSpecialRemote name remotetype config v
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config (u, c) = do
{- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user
- to perform IO actions to refill the pool. -}
c' <- R.setup remotetype u $
M.insert "highRandomQuality" "false" $ M.union config c
describeUUID u name
configSet u c'
return name
{- Returns the name of the git remote it created. If there's already a
- remote at the location, returns its name. -}
makeGitRemote :: String -> String -> Annex RemoteName
makeGitRemote basename location = makeRemote basename location $ \name ->
void $ inRepo $ Git.Command.runBool
[Param "remote", Param "add", Param name, Param location]
{- If there's not already a remote at the location, adds it using the
- action, which is passed the name of the remote to make.
-
- Returns the name of the remote. -}
makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
makeRemote basename location a = do
g <- gitRepo
if not (any samelocation $ Git.remotes g)
then do
let name = uniqueRemoteName basename 0 g
a name
return name
else return basename
where
samelocation x = Git.repoLocation x == location
{- Generate an unused name for a remote, adding a number if
- necessary.
-
- Ensures that the returned name is a legal git remote name. -}
uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
uniqueRemoteName basename n r
| null namecollision = name
| otherwise = uniqueRemoteName legalbasename (succ n) r
where
namecollision = filter samename (Git.remotes r)
samename x = Git.remoteName x == Just name
name
| n == 0 = legalbasename
| otherwise = legalbasename ++ show n
legalbasename = makeLegalName basename
{- Finds a CredPair belonging to any Remote that is of a given type
- and matches some other criteria.
-
- This can be used as a default when another repository is being set up
- using the same service.
-
- A function must be provided that returns the CredPairStorage
- to use for a particular Remote's uuid.
-}
previouslyUsedCredPair
:: (UUID -> CredPairStorage)
-> RemoteType
-> (Remote -> Bool)
-> Annex (Maybe CredPair)
previouslyUsedCredPair getstorage remotetype criteria =
getM fromstorage =<< filter criteria . filter sametype <$> remoteList
where
sametype r = R.typename (R.remotetype r) == R.typename remotetype
fromstorage r = do
let storage = getstorage (R.uuid r)
getRemoteCredPair (R.config r) storage

141
Assistant/Monad.hs Normal file
View file

@ -0,0 +1,141 @@
{- git-annex assistant monad
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
module Assistant.Monad (
Assistant,
AssistantData(..),
newAssistantData,
runAssistant,
getAssistant,
LiftAnnex,
liftAnnex,
(<~>),
(<<~),
asIO,
asIO1,
asIO2,
ThreadName,
debug,
notice
) where
import "mtl" Control.Monad.Reader
import System.Log.Logger
import Common.Annex
import Assistant.Types.ThreadedMonad
import Assistant.Types.DaemonStatus
import Assistant.Types.ScanRemotes
import Assistant.Types.TransferQueue
import Assistant.Types.TransferSlots
import Assistant.Types.TransferrerPool
import Assistant.Types.Pushes
import Assistant.Types.BranchChange
import Assistant.Types.Commits
import Assistant.Types.Changes
import Assistant.Types.Buddies
import Assistant.Types.NetMessager
import Assistant.Types.ThreadName
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving (
Monad,
MonadIO,
MonadReader AssistantData,
Functor,
Applicative
)
data AssistantData = AssistantData
{ threadName :: ThreadName
, threadState :: ThreadState
, daemonStatusHandle :: DaemonStatusHandle
, scanRemoteMap :: ScanRemoteMap
, transferQueue :: TransferQueue
, transferSlots :: TransferSlots
, transferrerPool :: TransferrerPool
, failedPushMap :: FailedPushMap
, commitChan :: CommitChan
, changePool :: ChangePool
, branchChangeHandle :: BranchChangeHandle
, buddyList :: BuddyList
, netMessager :: NetMessager
}
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
newAssistantData st dstatus = AssistantData
<$> pure (ThreadName "main")
<*> pure st
<*> pure dstatus
<*> newScanRemoteMap
<*> newTransferQueue
<*> newTransferSlots
<*> newTransferrerPool
<*> newFailedPushMap
<*> newCommitChan
<*> newChangePool
<*> newBranchChangeHandle
<*> newBuddyList
<*> newNetMessager
runAssistant :: AssistantData -> Assistant a -> IO a
runAssistant d a = runReaderT (mkAssistant a) d
getAssistant :: (AssistantData -> a) -> Assistant a
getAssistant = reader
{- Using a type class for lifting into the annex monad allows
- easily lifting to it from multiple different monads. -}
class LiftAnnex m where
liftAnnex :: Annex a -> m a
{- Runs an action in the git-annex monad. Note that the same monad state
- is shared amoung all assistant threads, so only one of these can run at
- a time. Therefore, long-duration actions should be avoided. -}
instance LiftAnnex Assistant where
liftAnnex a = do
st <- reader threadState
liftIO $ runThreadState st a
{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
io <~> a = do
d <- reader id
liftIO $ io $ runAssistant d a
{- Creates an IO action that will run an Assistant action when run. -}
asIO :: Assistant a -> Assistant (IO a)
asIO a = do
d <- reader id
return $ runAssistant d a
asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
asIO1 a = do
d <- reader id
return $ \v -> runAssistant d $ a v
asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
asIO2 a = do
d <- reader id
return $ \v1 v2 -> runAssistant d (a v1 v2)
{- Runs an IO action on a selected field of the AssistantData. -}
(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
io <<~ v = reader v >>= liftIO . io
debug :: [String] -> Assistant ()
debug = logaction debugM
notice :: [String] -> Assistant ()
notice = logaction noticeM
logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
logaction a ws = do
ThreadName name <- getAssistant threadName
liftIO $ a name $ unwords $ (name ++ ":") : ws

91
Assistant/NamedThread.hs Normal file
View file

@ -0,0 +1,91 @@
{- git-annex assistant named threads.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.NamedThread where
import Common.Annex
import Assistant.Types.NamedThread
import Assistant.Types.ThreadName
import Assistant.Types.DaemonStatus
import Assistant.Types.UrlRenderer
import Assistant.DaemonStatus
import Assistant.Monad
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Map as M
import qualified Control.Exception as E
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import Assistant.Types.Alert
import Assistant.Alert
import qualified Data.Text as T
#endif
{- Starts a named thread, if it's not already running.
-
- Named threads are run by a management thread, so if they crash
- an alert is displayed, allowing the thread to be restarted. -}
startNamedThread :: UrlRenderer -> NamedThread -> Assistant ()
startNamedThread urlrenderer namedthread@(NamedThread name a) = do
m <- startedThreads <$> getDaemonStatus
case M.lookup name m of
Nothing -> start
Just (aid, _) -> do
r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ()))))
case r of
Right Nothing -> noop
_ -> start
where
start = do
d <- getAssistant id
aid <- liftIO $ runmanaged $ d { threadName = name }
restart <- asIO $ startNamedThread urlrenderer namedthread
modifyDaemonStatus_ $ \s -> s
{ startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) }
runmanaged d = do
aid <- async $ runAssistant d a
void $ forkIO $ manager d aid
return aid
manager d aid = do
r <- E.try (wait aid) :: IO (Either E.SomeException ())
case r of
Right _ -> noop
Left e -> do
let msg = unwords
[ fromThreadName $ threadName d
, "crashed:", show e
]
hPutStrLn stderr msg
#ifdef WITH_WEBAPP
button <- runAssistant d $ mkAlertButton
(T.pack "Restart Thread")
urlrenderer
(RestartThreadR name)
runAssistant d $ void $ addAlert $
(warningAlert (fromThreadName name) msg)
{ alertButton = Just button }
#endif
namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
namedThreadId (NamedThread name _) = do
m <- startedThreads <$> getDaemonStatus
return $ asyncThreadId . fst <$> M.lookup name m
{- Waits for all named threads that have been started to finish.
-
- Note that if a named thread crashes, it will probably
- cause this to crash as well. Also, named threads that are started
- after this is called will not be waited on. -}
waitNamedThreads :: Assistant ()
waitNamedThreads = do
m <- startedThreads <$> getDaemonStatus
liftIO $ mapM_ (wait . fst) $ M.elems m

176
Assistant/NetMessager.hs Normal file
View file

@ -0,0 +1,176 @@
{- git-annex assistant out of band network messager interface
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Assistant.NetMessager where
import Assistant.Common
import Assistant.Types.NetMessager
import Control.Concurrent.STM
import Control.Concurrent.MSampleVar
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.DList as D
sendNetMessage :: NetMessage -> Assistant ()
sendNetMessage m =
(atomically . flip writeTChan m) <<~ (netMessages . netMessager)
waitNetMessage :: Assistant (NetMessage)
waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager)
notifyNetMessagerRestart :: Assistant ()
notifyNetMessagerRestart =
flip writeSV () <<~ (netMessagerRestart . netMessager)
waitNetMessagerRestart :: Assistant ()
waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)
{- Store a new important NetMessage for a client, and if an equivilant
- older message is already stored, remove it from both importantNetMessages
- and sentImportantNetMessages. -}
storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()
storeImportantNetMessage m client matchingclient = go <<~ netMessager
where
go nm = atomically $ do
q <- takeTMVar $ importantNetMessages nm
sent <- takeTMVar $ sentImportantNetMessages nm
putTMVar (importantNetMessages nm) $
M.alter (Just . maybe (S.singleton m) (S.insert m)) client $
M.mapWithKey removematching q
putTMVar (sentImportantNetMessages nm) $
M.mapWithKey removematching sent
removematching someclient s
| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s
| otherwise = s
{- Indicates that an important NetMessage has been sent to a client. -}
sentImportantNetMessage :: NetMessage -> ClientID -> Assistant ()
sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager)
where
go v = atomically $ do
sent <- takeTMVar v
putTMVar v $
M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent
{- Checks for important NetMessages that have been stored for a client, and
- sent to a client. Typically the same client for both, although
- a modified or more specific client may need to be used. -}
checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage)
checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
where
go nm = atomically $ do
stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm)
sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)
return (fromMaybe S.empty stored, fromMaybe S.empty sent)
{- Queues a push initiation message in the queue for the appropriate
- side of the push but only if there is not already an initiation message
- from the same client in the queue. -}
queuePushInitiation :: NetMessage -> Assistant ()
queuePushInitiation msg@(Pushing clientid stage) = do
tv <- getPushInitiationQueue side
liftIO $ atomically $ do
r <- tryTakeTMVar tv
case r of
Nothing -> putTMVar tv [msg]
Just l -> do
let !l' = msg : filter differentclient l
putTMVar tv l'
where
side = pushDestinationSide stage
differentclient (Pushing cid _) = cid /= clientid
differentclient _ = True
queuePushInitiation _ = noop
{- Waits for a push inititation message to be received, and runs
- function to select a message from the queue. -}
waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage
waitPushInitiation side selector = do
tv <- getPushInitiationQueue side
liftIO $ atomically $ do
q <- takeTMVar tv
if null q
then retry
else do
let (msg, !q') = selector q
unless (null q') $
putTMVar tv q'
return msg
{- Stores messages for a push into the appropriate inbox.
-
- To avoid overflow, only 1000 messages max are stored in any
- inbox, which should be far more than necessary.
-
- TODO: If we have more than 100 inboxes for different clients,
- discard old ones that are not currently being used by any push.
-}
storeInbox :: NetMessage -> Assistant ()
storeInbox msg@(Pushing clientid stage) = do
inboxes <- getInboxes side
stored <- liftIO $ atomically $ do
m <- readTVar inboxes
let update = \v -> do
writeTVar inboxes $
M.insertWith' const clientid v m
return True
case M.lookup clientid m of
Nothing -> update (1, tostore)
Just (sz, l)
| sz > 1000 -> return False
| otherwise ->
let !sz' = sz + 1
!l' = D.append l tostore
in update (sz', l')
if stored
then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]
else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]
where
side = pushDestinationSide stage
tostore = D.singleton msg
storeInbox _ = noop
{- Gets the new message for a push from its inbox.
- Blocks until a message has been received. -}
waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)
waitInbox clientid side = do
inboxes <- getInboxes side
liftIO $ atomically $ do
m <- readTVar inboxes
case M.lookup clientid m of
Nothing -> retry
Just (sz, dl)
| sz < 1 -> retry
| otherwise -> do
let msg = D.head dl
let dl' = D.tail dl
let !sz' = sz - 1
writeTVar inboxes $
M.insertWith' const clientid (sz', dl') m
return msg
emptyInbox :: ClientID -> PushSide -> Assistant ()
emptyInbox clientid side = do
inboxes <- getInboxes side
liftIO $ atomically $
modifyTVar' inboxes $
M.delete clientid
getInboxes :: PushSide -> Assistant Inboxes
getInboxes side =
getSide side . netMessagerInboxes <$> getAssistant netMessager
getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])
getPushInitiationQueue side =
getSide side . netMessagerPushInitiations <$> getAssistant netMessager
netMessagerDebug :: ClientID -> [String] -> Assistant ()
netMessagerDebug clientid l = debug $
"NetMessager" : l ++ [show $ logClientID clientid]

92
Assistant/Pairing.hs Normal file
View file

@ -0,0 +1,92 @@
{- git-annex assistant repo pairing, core data types
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Pairing where
import Common.Annex
import Utility.Verifiable
import Assistant.Ssh
import Control.Concurrent
import Network.Socket
import Data.Char
import qualified Data.Text as T
data PairStage
{- "I'll pair with anybody who shares the secret that can be used
- to verify this request." -}
= PairReq
{- "I've verified your request, and you can verify this to see
- that I know the secret. I set up your ssh key already.
- Here's mine for you to set up." -}
| PairAck
{- "I saw your PairAck; you can stop sending them." -}
| PairDone
deriving (Eq, Read, Show, Ord)
newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
deriving (Eq, Read, Show)
verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip
fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
fromPairMsg (PairMsg m) = m
pairMsgStage :: PairMsg -> PairStage
pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s
pairMsgData :: PairMsg -> PairData
pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d
pairMsgAddr :: PairMsg -> SomeAddr
pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a
data PairData = PairData
-- uname -n output, not a full domain name
{ remoteHostName :: Maybe HostName
, remoteUserName :: UserName
, remoteDirectory :: FilePath
, remoteSshPubKey :: SshPubKey
, pairUUID :: UUID
}
deriving (Eq, Read, Show)
type UserName = String
{- A pairing that is in progress has a secret, a thread that is
- broadcasting pairing messages, and a SshKeyPair that has not yet been
- set up on disk. -}
data PairingInProgress = PairingInProgress
{ inProgressSecret :: Secret
, inProgressThreadId :: Maybe ThreadId
, inProgressSshKeyPair :: SshKeyPair
, inProgressPairData :: PairData
, inProgressPairStage :: PairStage
}
deriving (Show)
data SomeAddr = IPv4Addr HostAddress
{- My Android build of the Network library does not currently have IPV6
- support. -}
#ifndef __ANDROID__
| IPv6Addr HostAddress6
#endif
deriving (Ord, Eq, Read, Show)
{- This contains the whole secret, just lightly obfuscated to make it not
- too obvious. It's only displayed in the user's web browser. -}
newtype SecretReminder = SecretReminder [Int]
deriving (Show, Eq, Ord, Read)
toSecretReminder :: T.Text -> SecretReminder
toSecretReminder = SecretReminder . map ord . T.unpack
fromSecretReminder :: SecretReminder -> T.Text
fromSecretReminder (SecretReminder s) = T.pack $ map chr s

View file

@ -0,0 +1,91 @@
{- git-annex assistant pairing remote creation
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Pairing.MakeRemote where
import Assistant.Common
import Assistant.Ssh
import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.MakeRemote
import Config.Cost
import Network.Socket
import qualified Data.Text as T
{- Authorized keys are set up before pairing is complete, so that the other
- side can immediately begin syncing. -}
setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = do
validateSshPubKey pubkey
unlessM (liftIO $ addAuthorizedKeys False repodir pubkey) $
error "failed setting up ssh authorized keys"
where
pubkey = remoteSshPubKey $ pairMsgData msg
{- When local pairing is complete, this is used to set up the remote for
- the host we paired with. -}
finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
finishedLocalPairing msg keypair = do
sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
{- Ensure that we know the ssh host key for the host we paired with.
- If we don't, ssh over to get it. -}
liftIO $ unlessM (knownHost $ sshHostName sshdata) $
void $ sshTranscript
[ sshOpt "StrictHostKeyChecking" "no"
, sshOpt "NumberOfPasswordPrompts" "0"
, "-n"
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
]
Nothing
void $ makeSshRemote False sshdata (Just semiExpensiveRemoteCost)
{- Mostly a straightforward conversion. Except:
- * Determine the best hostname to use to contact the host.
- * Strip leading ~/ from the directory name.
-}
pairMsgToSshData :: PairMsg -> IO SshData
pairMsgToSshData msg = do
let d = pairMsgData msg
hostname <- liftIO $ bestHostName msg
let dir = case remoteDirectory d of
('~':'/':v) -> v
v -> v
return SshData
{ sshHostName = T.pack hostname
, sshUserName = Just (T.pack $ remoteUserName d)
, sshDirectory = T.pack dir
, sshRepoName = genSshRepoName hostname dir
, sshPort = 22
, needsPubKey = True
, rsyncOnly = False
}
{- Finds the best hostname to use for the host that sent the PairMsg.
-
- If remoteHostName is set, tries to use a .local address based on it.
- That's the most robust, if this system supports .local.
- Otherwise, looks up the hostname in the DNS for the remoteAddress,
- if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
bestHostName :: PairMsg -> IO HostName
bestHostName msg = case remoteHostName $ pairMsgData msg of
Just h -> do
let localname = h ++ ".local"
addrs <- catchDefaultIO [] $
getAddrInfo Nothing (Just localname) Nothing
maybe fallback (const $ return localname) (headMaybe addrs)
Nothing -> fallback
where
fallback = do
let a = pairMsgAddr msg
let sockaddr = case a of
IPv4Addr addr -> SockAddrInet (PortNum 0) addr
IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
fromMaybe (showAddr a)
<$> catchDefaultIO Nothing
(fst <$> getNameInfo [] True False sockaddr)

View file

@ -0,0 +1,130 @@
{- git-annex assistant pairing network code
-
- All network traffic is sent over multicast UDP. For reliability,
- each message is repeated until acknowledged. This is done using a
- thread, that gets stopped before the next message is sent.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Pairing.Network where
import Assistant.Common
import Assistant.Pairing
import Assistant.DaemonStatus
import Utility.ThreadScheduler
import Utility.Verifiable
import Network.Multicast
import Network.Info
import Network.Socket
import Control.Exception (bracket)
import qualified Data.Map as M
import Control.Concurrent
{- This is an arbitrary port in the dynamic port range, that could
- conceivably be used for some other broadcast messages.
- If so, hope they ignore the garbage from us; we'll certianly
- ignore garbage from them. Wild wild west. -}
pairingPort :: PortNumber
pairingPort = 55556
{- Goal: Reach all hosts on the same network segment.
- Method: Use same address that avahi uses. Other broadcast addresses seem
- to not be let through some routers. -}
multicastAddress :: SomeAddr -> HostName
multicastAddress (IPv4Addr _) = "224.0.0.251"
multicastAddress (IPv6Addr _) = "ff02::fb"
{- Multicasts a message repeatedly on all interfaces, with a 2 second
- delay between each transmission. The message is repeated forever
- unless a number of repeats is specified.
-
- The remoteHostAddress is set to the interface's IP address.
-
- Note that new sockets are opened each time. This is hardly efficient,
- but it allows new network interfaces to be used as they come up.
- On the other hand, the expensive DNS lookups are cached.
-}
multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()
multicastPairMsg repeats secret pairdata stage = go M.empty repeats
where
go _ (Just 0) = noop
go cache n = do
addrs <- activeNetworkAddresses
let cache' = updatecache cache addrs
mapM_ (sendinterface cache') addrs
threadDelaySeconds (Seconds 2)
go cache' $ pred <$> n
{- The multicast library currently chokes on ipv6 addresses. -}
sendinterface _ (IPv6Addr _) = noop
sendinterface cache i = void $ tryIO $
withSocketsDo $ bracket setup cleanup use
where
setup = multicastSender (multicastAddress i) pairingPort
cleanup (sock, _) = sClose sock -- FIXME does not work
use (sock, addr) = do
setInterface sock (showAddr i)
maybe noop (\s -> void $ sendTo sock s addr)
(M.lookup i cache)
updatecache cache [] = cache
updatecache cache (i:is)
| M.member i cache = updatecache cache is
| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
mkmsg addr = PairMsg $
mkVerifiable (stage, pairdata, addr) secret
startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()
startSending pip stage sender = do
a <- asIO start
void $ liftIO $ forkIO a
where
start = do
tid <- liftIO myThreadId
let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
oldpip <- modifyDaemonStatus $
\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
maybe noop stopold oldpip
liftIO $ sender stage
stopold = maybe noop (liftIO . killThread) . inProgressThreadId
stopSending :: PairingInProgress -> Assistant ()
stopSending pip = do
maybe noop (liftIO . killThread) $ inProgressThreadId pip
modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing }
class ToSomeAddr a where
toSomeAddr :: a -> SomeAddr
instance ToSomeAddr IPv4 where
toSomeAddr (IPv4 a) = IPv4Addr a
instance ToSomeAddr IPv6 where
toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)
showAddr :: SomeAddr -> HostName
showAddr (IPv4Addr a) = show $ IPv4 a
showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
activeNetworkAddresses :: IO [SomeAddr]
activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
<$> getNetworkInterfaces
{- A human-visible description of the repository being paired with.
- Note that the repository's description is not shown to the user, because
- it could be something like "my repo", which is confusing when pairing
- with someone else's repo. However, this has the same format as the
- default decription of a repo. -}
pairRepo :: PairMsg -> String
pairRepo msg = concat
[ remoteUserName d
, "@"
, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
, ":"
, remoteDirectory d
]
where
d = pairMsgData msg

40
Assistant/Pushes.hs Normal file
View file

@ -0,0 +1,40 @@
{- git-annex assistant push tracking
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Pushes where
import Assistant.Common
import Assistant.Types.Pushes
import Control.Concurrent.STM
import Data.Time.Clock
import qualified Data.Map as M
{- Blocks until there are failed pushes.
- Returns Remotes whose pushes failed a given time duration or more ago.
- (This may be an empty list.) -}
getFailedPushesBefore :: NominalDiffTime -> Assistant [Remote]
getFailedPushesBefore duration = do
v <- getAssistant failedPushMap
liftIO $ do
m <- atomically $ readTMVar v
now <- getCurrentTime
return $ M.keys $ M.filter (not . toorecent now) m
where
toorecent now time = now `diffUTCTime` time < duration
{- Modifies the map. -}
changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()
changeFailedPushMap a = do
v <- getAssistant failedPushMap
liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
where
{- tryTakeTMVar empties the TMVar; refill it only if
- the modified map is not itself empty -}
store v m
| m == M.empty = noop
| otherwise = putTMVar v $! m

41
Assistant/ScanRemotes.hs Normal file
View file

@ -0,0 +1,41 @@
{- git-annex assistant remotes needing scanning
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.ScanRemotes where
import Assistant.Common
import Assistant.Types.ScanRemotes
import qualified Types.Remote as Remote
import Data.Function
import Control.Concurrent.STM
import qualified Data.Map as M
{- Blocks until there is a remote or remotes that need to be scanned.
-
- The list has higher priority remotes listed first. -}
getScanRemote :: Assistant [(Remote, ScanInfo)]
getScanRemote = do
v <- getAssistant scanRemoteMap
liftIO $ atomically $
reverse . sortBy (compare `on` scanPriority . snd) . M.toList
<$> takeTMVar v
{- Adds new remotes that need scanning. -}
addScanRemotes :: Bool -> [Remote] -> Assistant ()
addScanRemotes _ [] = noop
addScanRemotes full rs = do
v <- getAssistant scanRemoteMap
liftIO $ atomically $ do
m <- fromMaybe M.empty <$> tryTakeTMVar v
putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
where
info r = ScanInfo (-1 * Remote.cost r) full
merge x y = ScanInfo
{ scanPriority = max (scanPriority x) (scanPriority y)
, fullScan = fullScan x || fullScan y
}

293
Assistant/Ssh.hs Normal file
View file

@ -0,0 +1,293 @@
{- git-annex assistant ssh utilities
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Ssh where
import Common.Annex
import Utility.Tmp
import Utility.UserInfo
import Utility.Shell
import Git.Remote
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char
import Network.URI
data SshData = SshData
{ sshHostName :: Text
, sshUserName :: Maybe Text
, sshDirectory :: Text
, sshRepoName :: String
, sshPort :: Int
, needsPubKey :: Bool
, rsyncOnly :: Bool
}
deriving (Read, Show, Eq)
data SshKeyPair = SshKeyPair
{ sshPubKey :: String
, sshPrivKey :: String
}
instance Show SshKeyPair where
show = sshPubKey
type SshPubKey = String
{- ssh -ofoo=bar command-line option -}
sshOpt :: String -> String -> String
sshOpt k v = concat ["-o", k, "=", v]
sshDir :: IO FilePath
sshDir = do
home <- myHomeDir
return $ home </> ".ssh"
{- user@host or host -}
genSshHost :: Text -> Maybe Text -> String
genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
{- Generates a git remote name, like host_dir or host -}
genSshRepoName :: String -> FilePath -> String
genSshRepoName host dir
| null dir = makeLegalName host
| otherwise = makeLegalName $ host ++ "_" ++ dir
{- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
sshTranscript opts input = processTranscript "ssh" opts input
{- Ensure that the ssh public key doesn't include any ssh options, like
- command=foo, or other weirdness -}
validateSshPubKey :: SshPubKey -> IO ()
validateSshPubKey pubkey
| length (lines pubkey) == 1 =
either error return $ check $ words pubkey
| otherwise = error "too many lines in ssh public key"
where
check [prefix, _key, comment] = do
checkprefix prefix
checkcomment comment
check [prefix, _key] =
checkprefix prefix
check _ = err "wrong number of words in ssh public key"
ok = Right ()
err msg = Left $ unwords [msg, pubkey]
checkprefix prefix
| ssh == "ssh" && all isAlphaNum keytype = ok
| otherwise = err "bad ssh public key prefix"
where
(ssh, keytype) = separate (== '-') prefix
checkcomment comment = case filter (not . safeincomment) comment of
[] -> ok
badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")"
safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
addAuthorizedKeys rsynconly dir pubkey = boolSystem "sh"
[ Param "-c" , Param $ addAuthorizedKeysCommand rsynconly dir pubkey ]
removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
removeAuthorizedKeys rsynconly dir pubkey = do
let keyline = authorizedKeysLine rsynconly dir pubkey
sshdir <- sshDir
let keyfile = sshdir </> "authorized_keys"
ls <- lines <$> readFileStrict keyfile
writeFile keyfile $ unlines $ filter (/= keyline) ls
{- Implemented as a shell command, so it can be run on remote servers over
- ssh.
-
- The ~/.ssh/git-annex-shell wrapper script is created if not already
- present.
-}
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
[ "mkdir -p ~/.ssh"
, intercalate "; "
[ "if [ ! -e " ++ wrapper ++ " ]"
, "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper
, "fi"
]
, "chmod 700 " ++ wrapper
, "touch ~/.ssh/authorized_keys"
, "chmod 600 ~/.ssh/authorized_keys"
, unwords
[ "echo"
, shellEscape $ authorizedKeysLine rsynconly dir pubkey
, ">>~/.ssh/authorized_keys"
]
]
where
echoval v = "echo " ++ shellEscape v
wrapper = "~/.ssh/git-annex-shell"
script =
[ shebang_portable
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, runshell "$SSH_ORIGINAL_COMMAND"
, "else"
, runshell "$@"
, "fi"
]
runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
authorizedKeysLine rsynconly dir pubkey
{- TODO: Locking down rsync is difficult, requiring a rather
- long perl script. -}
| rsynconly = pubkey
| otherwise = limitcommand ++ pubkey
where
limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password
, Param "-f", File $ dir </> "key"
]
unless ok $
error "ssh-keygen failed"
SshKeyPair
<$> readFile (dir </> "key.pub")
<*> readFile (dir </> "key")
{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
- that will enable use of the key. This way we avoid changing the user's
- regular ssh experience at all. Returns a modified SshData containing the
- mangled hostname.
-
- Note that the key files are put in ~/.ssh/git-annex/, rather than directly
- in ssh because of an **INSANE** behavior of gnome-keyring: It loads
- ~/.ssh/ANYTHING.pub, and uses them indiscriminately. But using this key
- for a normal login to the server will force git-annex-shell to run,
- and locks the user out. Luckily, it does not recurse into subdirectories.
-
- Similarly, IdentitiesOnly is set in the ssh config to prevent the
- ssh-agent from forcing use of a different key.
-}
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
setupSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir
createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do
h <- fdToHandle =<<
createFile (sshdir </> sshprivkeyfile)
(unionFileModes ownerWriteMode ownerReadMode)
hPutStr h (sshPrivKey sshkeypair)
hClose h
unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
setSshConfig sshdata
[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
, ("IdentitiesOnly", "yes")
]
where
sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
sshpubkeyfile = sshprivkeyfile ++ ".pub"
{- Fixes git-annex ssh key pairs configured in .ssh/config
- by old versions to set IdentitiesOnly. -}
fixSshKeyPair :: IO ()
fixSshKeyPair = do
sshdir <- sshDir
let configfile = sshdir </> "config"
whenM (doesFileExist configfile) $ do
ls <- lines <$> readFileStrict configfile
let ls' = fixSshKeyPair' ls
when (ls /= ls') $
viaTmp writeFile configfile $ unlines ls'
{- Strategy: Search for IdentityFile lines in for files with key.git-annex
- in their names. These are for git-annex ssh key pairs.
- Add the IdentitiesOnly line immediately after them, if not already
- present. -}
fixSshKeyPair' :: [String] -> [String]
fixSshKeyPair' = go []
where
go c [] = reverse c
go c (l:[])
| all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
| otherwise = go (l:c) []
go c (l:next:rest)
| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) =
go (fixedline l:l:c) (next:rest)
| otherwise = go (l:c) (next:rest)
indicators = ["IdentityFile", "key.git-annex"]
fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
{- Setups up a ssh config with a mangled hostname.
- Returns a modified SshData containing the mangled hostname. -}
setSshConfig :: SshData -> [(String, String)] -> IO SshData
setSshConfig sshdata config = do
sshdir <- sshDir
createDirectoryIfMissing True sshdir
let configfile = sshdir </> "config"
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
appendFile configfile $ unlines $
[ ""
, "# Added automatically by git-annex"
, "Host " ++ mangledhost
] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
(settings ++ config)
return $ sshdata { sshHostName = T.pack mangledhost }
where
mangledhost = mangleSshHostName sshdata
settings =
[ ("Hostname", T.unpack $ sshHostName sshdata)
, ("Port", show $ sshPort sshdata)
]
{- This hostname is specific to a given repository on the ssh host,
- so it is based on the real hostname, the username, and the directory.
-
- The mangled hostname has the form "git-annex-realhostname-username_dir".
- The only use of "-" is to separate the parts shown; this is necessary
- to allow unMangleSshHostName to work. Any unusual characters in the
- username or directory are url encoded, except using "." rather than "%"
- (the latter has special meaning to ssh).
-}
mangleSshHostName :: SshData -> String
mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
++ "-" ++ escape extra
where
extra = intercalate "_" $ map T.unpack $ catMaybes
[ sshUserName sshdata
, Just $ sshDirectory sshdata
]
safe c
| isAlphaNum c = True
| c == '_' = True
| otherwise = False
escape s = replace "%" "." $ escapeURIString safe s
{- Extracts the real hostname from a mangled ssh hostname. -}
unMangleSshHostName :: String -> String
unMangleSshHostName h = case split "-" h of
("git":"annex":rest) -> intercalate "-" (beginning rest)
_ -> h
{- Does ssh have known_hosts data for a hostname? -}
knownHost :: Text -> IO Bool
knownHost hostname = do
sshdir <- sshDir
ifM (doesFileExist $ sshdir </> "known_hosts")
( not . null <$> checkhost
, return False
)
where
{- ssh-keygen -F can crash on some old known_hosts file -}
checkhost = catchDefaultIO "" $
readProcess "ssh-keygen" ["-F", T.unpack hostname]

222
Assistant/Sync.hs Normal file
View file

@ -0,0 +1,222 @@
{- git-annex assistant repo syncing
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Sync where
import Assistant.Common
import Assistant.Pushes
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import qualified Command.Sync
import Utility.Parallel
import qualified Git
import qualified Git.Branch
import qualified Git.Command
import qualified Git.Ref
import qualified Remote
import qualified Types.Remote as Remote
import qualified Annex.Branch
import Annex.UUID
import Annex.TaggedPush
import Data.Time.Clock
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Concurrent
{- Syncs with remotes that may have been disconnected for a while.
-
- First gets git in sync, and then prepares any necessary file transfers.
-
- An expensive full scan is queued when the git-annex branches of some of
- the remotes have diverged from the local git-annex branch. Otherwise,
- it's sufficient to requeue failed transfers.
-
- XMPP remotes are also signaled that we can push to them, and we request
- they push to us. Since XMPP pushes run ansynchronously, any scan of the
- XMPP remotes has to be deferred until they're done pushing to us, so
- all XMPP remotes are marked as possibly desynced.
-}
reconnectRemotes :: Bool -> [Remote] -> Assistant ()
reconnectRemotes _ [] = noop
reconnectRemotes notifypushes rs = void $ do
modifyDaemonStatus_ $ \s -> s
{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
syncAction rs (const go)
where
gitremotes = filter (notspecialremote . Remote.repo) rs
(xmppremotes, nonxmppremotes) = partition isXMPPRemote rs
notspecialremote r
| Git.repoIsUrl r = True
| Git.repoIsLocal r = True
| Git.repoIsLocalUnknown r = True
| otherwise = False
sync (Just branch) = do
(failedpull, diverged) <- manualPull (Just branch) gitremotes
now <- liftIO getCurrentTime
failedpush <- pushToRemotes' now notifypushes gitremotes
return (nub $ failedpull ++ failedpush, diverged)
{- No local branch exists yet, but we can try pulling. -}
sync Nothing = manualPull Nothing gitremotes
go = do
(failed, diverged) <- sync
=<< liftAnnex (inRepo Git.Branch.current)
addScanRemotes diverged $
filter (not . remoteAnnexIgnore . Remote.gitconfig)
nonxmppremotes
return failed
{- Updates the local sync branch, then pushes it to all remotes, in
- parallel, along with the git-annex branch. This is the same
- as "git annex sync", except in parallel, and will co-exist with use of
- "git annex sync".
-
- After the pushes to normal git remotes, also signals XMPP clients that
- they can request an XMPP push.
-
- Avoids running possibly long-duration commands in the Annex monad, so
- as not to block other threads.
-
- This can fail, when the remote's sync branch (or git-annex branch) has
- been updated by some other remote pushing into it, or by the remote
- itself. To handle failure, a manual pull and merge is done, and the push
- is retried.
-
- When there's a lot of activity, we may fail more than once.
- On the other hand, we may fail because the remote is not available.
- Rather than retrying indefinitely, after the first retry we enter a
- fallback mode, where our push is guarenteed to succeed if the remote is
- reachable. If the fallback fails, the push is queued to be retried
- later.
-
- Returns any remotes that it failed to push to.
-}
pushToRemotes :: Bool -> [Remote] -> Assistant [Remote]
pushToRemotes notifypushes remotes = do
now <- liftIO getCurrentTime
syncAction remotes (pushToRemotes' now notifypushes)
pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
pushToRemotes' now notifypushes remotes = do
(g, branch, u) <- liftAnnex $ do
Annex.Branch.commit "update"
(,,)
<$> gitRepo
<*> inRepo Git.Branch.current
<*> getUUID
let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
ret <- go True branch g u normalremotes
unless (null xmppremotes) $ do
shas <- liftAnnex $ map fst <$>
inRepo (Git.Ref.matchingWithHEAD
[Annex.Branch.fullname, Git.Ref.headRef])
forM_ xmppremotes $ \r -> sendNetMessage $
Pushing (getXMPPClientID r) (CanPush u shas)
return ret
where
go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
go _ _ _ _ [] = return [] -- no remotes, so nothing to do
go shouldretry (Just branch) g u rs = do
debug ["pushing to", show rs]
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
(succeeded, failed) <- liftIO $ inParallel (push g branch) rs
updatemap succeeded []
if null failed
then do
when notifypushes $
sendNetMessage $ NotifyPush $
map Remote.uuid succeeded
return failed
else if shouldretry
then retry branch g u failed
else fallback branch g u failed
updatemap succeeded failed = changeFailedPushMap $ \m ->
M.union (makemap failed) $
M.difference m (makemap succeeded)
makemap l = M.fromList $ zip l (repeat now)
retry branch g u rs = do
debug ["trying manual pull to resolve failed pushes"]
void $ manualPull (Just branch) rs
go False (Just branch) g u rs
fallback branch g u rs = do
debug ["fallback pushing to", show rs]
(succeeded, failed) <- liftIO $
inParallel (\r -> taggedPush u Nothing branch r g) rs
updatemap succeeded failed
when (notifypushes && (not $ null succeeded)) $
sendNetMessage $ NotifyPush $
map Remote.uuid succeeded
return failed
push g branch remote = Command.Sync.pushBranch remote branch g
{- Displays an alert while running an action that syncs with some remotes,
- and returns any remotes that it failed to sync with.
-
- XMPP remotes are handled specially; since the action can only start
- an async process for them, they are not included in the alert, but are
- still passed to the action.
-
- Readonly remotes are also hidden (to hide the web special remote).
-}
syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
syncAction rs a
| null visibleremotes = a rs
| otherwise = do
i <- addAlert $ syncAlert visibleremotes
failed <- a rs
let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed
let succeeded = filter (`notElem` failed) visibleremotes
if null succeeded && null failed'
then removeAlert i
else updateAlertMap $ mergeAlert i $
syncResultAlert succeeded failed'
return failed
where
visibleremotes = filter (not . Remote.readonly) $
filter (not . isXMPPRemote) rs
{- Manually pull from remotes and merge their branches. Returns any
- remotes that it failed to pull from, and a Bool indicating
- whether the git-annex branches of the remotes and local had
- diverged before the pull.
-
- After pulling from the normal git remotes, requests pushes from any
- XMPP remotes. However, those pushes will run asynchronously, so their
- results are not included in the return data.
-}
manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
g <- liftAnnex gitRepo
let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
failed <- liftIO $ forM normalremotes $ \r ->
ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g)
( return Nothing
, return $ Just r
)
haddiverged <- liftAnnex Annex.Branch.forceUpdate
forM_ normalremotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r currentbranch
u <- liftAnnex getUUID
forM_ xmppremotes $ \r ->
sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
return (catMaybes failed, haddiverged)
{- Start syncing a remote, using a background thread. -}
syncRemote :: Remote -> Assistant ()
syncRemote remote = do
updateSyncRemotes
thread <- asIO $ do
reconnectRemotes False [remote]
addScanRemotes True [remote]
void $ liftIO $ forkIO $ thread

View file

@ -0,0 +1,492 @@
{- git-annex assistant commit thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Threads.Committer where
import Assistant.Common
import Assistant.Changes
import Assistant.Types.Changes
import Assistant.Commits
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.Drop
import Logs.Transfer
import Logs.Location
import qualified Annex.Queue
import qualified Git.Command
import qualified Git.LsFiles
import qualified Git.BuildVersion
import qualified Command.Add
import Utility.ThreadScheduler
import qualified Utility.Lsof as Lsof
import qualified Utility.DirWatcher as DirWatcher
import Types.KeySource
import Config
import Annex.Exception
import Annex.Content
import Annex.Link
import Annex.CatFile
import qualified Annex
import Utility.InodeCache
import Annex.Content.Direct
import Data.Time.Clock
import Data.Tuple.Utils
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Either
import Control.Concurrent
{- This thread makes git commits at appropriate times. -}
commitThread :: NamedThread
commitThread = namedThread "Committer" $ do
delayadd <- liftAnnex $
maybe delayaddDefault (return . Just . Seconds)
=<< annexDelayAdd <$> Annex.getGitConfig
waitChangeTime $ \(changes, time) -> do
readychanges <- handleAdds delayadd changes
if shouldCommit time (length readychanges) readychanges
then do
debug
[ "committing"
, show (length readychanges)
, "changes"
]
void $ alertWhile commitAlert $
liftAnnex commitStaged
recordCommit
let numchanges = length readychanges
mapM_ checkChangeContent readychanges
return numchanges
else do
refill readychanges
return 0
refill :: [Change] -> Assistant ()
refill [] = noop
refill cs = do
debug ["delaying commit of", show (length cs), "changes"]
refillChanges cs
{- Wait for one or more changes to arrive to be committed, and then
- runs an action to commit them. If more changes arrive while this is
- going on, they're handled intelligently, batching up changes into
- large commits where possible, doing rename detection, and
- commiting immediately otherwise. -}
waitChangeTime :: (([Change], UTCTime) -> Assistant Int) -> Assistant ()
waitChangeTime a = waitchanges 0
where
waitchanges lastcommitsize = do
-- Wait one one second as a simple rate limiter.
liftIO $ threadDelaySeconds (Seconds 1)
-- Now, wait until at least one change is available for
-- processing.
cs <- getChanges
handlechanges cs lastcommitsize
handlechanges changes lastcommitsize = do
let len = length changes
-- See if now's a good time to commit.
now <- liftIO getCurrentTime
case (lastcommitsize >= maxCommitSize, shouldCommit now len changes, possiblyrename changes) of
(True, True, _)
| len > maxCommitSize ->
waitchanges =<< a (changes, now)
| otherwise -> aftermaxcommit changes
(_, True, False) ->
waitchanges =<< a (changes, now)
(_, True, True) -> do
morechanges <- getrelatedchanges changes
waitchanges =<< a (changes ++ morechanges, now)
_ -> do
refill changes
waitchanges lastcommitsize
{- Did we perhaps only get one of the AddChange and RmChange pair
- that make up a file rename? Or some of the pairs that make up
- a directory rename?
-}
possiblyrename cs = all renamepart cs
renamepart (PendingAddChange _ _) = True
renamepart c = isRmChange c
{- Gets changes related to the passed changes, without blocking
- very long.
-
- If there are multiple RmChanges, this is probably a directory
- rename, in which case it may be necessary to wait longer to get
- all the Changes involved.
-}
getrelatedchanges oldchanges
| length (filter isRmChange oldchanges) > 1 =
concat <$> getbatchchanges []
| otherwise = do
liftIO humanImperceptibleDelay
getAnyChanges
getbatchchanges cs = do
liftIO $ threadDelay $ fromIntegral $ oneSecond `div` 10
cs' <- getAnyChanges
if null cs'
then return cs
else getbatchchanges (cs':cs)
{- The last commit was maximum size, so it's very likely there
- are more changes and we'd like to ensure we make another commit
- of maximum size if possible.
-
- But, it can take a while for the Watcher to wake back up
- after a commit. It can get blocked by another thread
- that is using the Annex state, such as a git-annex branch
- commit. Especially after such a large commit, this can
- take several seconds. When this happens, it defeats the
- normal commit batching, which sees some old changes the
- Watcher found while the commit was being prepared, and sees
- no recent ones, and wants to commit immediately.
-
- All that we need to do, then, is wait for the Watcher to
- wake up, and queue up one more change.
-
- However, it's also possible that we're at the end of changes for
- now. So to avoid waiting a really long time before committing
- those changes we have, poll for up to 30 seconds, and then
- commit them.
-
- Also, try to run something in Annex, to ensure we block
- longer if the Annex state is indeed blocked.
-}
aftermaxcommit oldchanges = loop (30 :: Int)
where
loop 0 = continue oldchanges
loop n = do
liftAnnex noop -- ensure Annex state is free
liftIO $ threadDelaySeconds (Seconds 1)
changes <- getAnyChanges
if null changes
then loop (n - 1)
else continue (oldchanges ++ changes)
continue cs
| null cs = waitchanges 0
| otherwise = handlechanges cs 0
isRmChange :: Change -> Bool
isRmChange (Change { changeInfo = i }) | i == RmChange = True
isRmChange _ = False
{- An amount of time that is hopefully imperceptably short for humans,
- while long enough for a computer to get some work done.
- Note that 0.001 is a little too short for rename change batching to
- work. -}
humanImperceptibleInterval :: NominalDiffTime
humanImperceptibleInterval = 0.01
humanImperceptibleDelay :: IO ()
humanImperceptibleDelay = threadDelay $
truncate $ humanImperceptibleInterval * fromIntegral oneSecond
maxCommitSize :: Int
maxCommitSize = 5000
{- Decide if now is a good time to make a commit.
- Note that the list of changes has an undefined order.
-
- Current strategy: If there have been 10 changes within the past second,
- a batch activity is taking place, so wait for later.
-}
shouldCommit :: UTCTime -> Int -> [Change] -> Bool
shouldCommit now len changes
| len == 0 = False
| len >= maxCommitSize = True
| length recentchanges < 10 = True
| otherwise = False -- batch activity
where
thissecond c = timeDelta c <= 1
recentchanges = filter thissecond changes
timeDelta c = now `diffUTCTime` changeTime c
commitStaged :: Annex Bool
commitStaged = do
{- This could fail if there's another commit being made by
- something else. -}
v <- tryAnnex Annex.Queue.flush
case v of
Left _ -> return False
Right _ -> do
{- Empty commits may be made if tree changes cancel
- each other out, etc. Git returns nonzero on those,
- so don't propigate out commit failures. -}
void $ inRepo $ catchMaybeIO .
Git.Command.runQuiet
(Param "commit" : nomessage params)
return True
where
params =
[ Param "--quiet"
{- Avoid running the usual pre-commit hook;
- the Watcher does the same symlink fixing,
- and direct mode bookkeeping updating. -}
, Param "--no-verify"
]
nomessage ps
| Git.BuildVersion.older "1.7.2" =
Param "-m" : Param "autocommit" : ps
| Git.BuildVersion.older "1.7.8" =
Param "--allow-empty-message" :
Param "-m" : Param "" : ps
| otherwise =
Param "--allow-empty-message" :
Param "--no-edit" : Param "-m" : Param "" : ps
{- OSX needs a short delay after a file is added before locking it down,
- when using a non-direct mode repository, as pasting a file seems to
- try to set file permissions or otherwise access the file after closing
- it. -}
delayaddDefault :: Annex (Maybe Seconds)
#ifdef darwin_HOST_OS
delayaddDefault = ifM isDirect
( return Nothing
, return $ Just $ Seconds 1
)
#else
delayaddDefault = return Nothing
#endif
{- If there are PendingAddChanges, or InProcessAddChanges, the files
- have not yet actually been added to the annex, and that has to be done
- now, before committing.
-
- Deferring the adds to this point causes batches to be bundled together,
- which allows faster checking with lsof that the files are not still open
- for write by some other process, and faster checking with git-ls-files
- that the files are not already checked into git.
-
- When a file is added, Inotify will notice the new symlink. So this waits
- for additional Changes to arrive, so that the symlink has hopefully been
- staged before returning, and will be committed immediately.
-
- OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly
- created and staged.
-
- Returns a list of all changes that are ready to be committed.
- Any pending adds that are not ready yet are put back into the ChangeChan,
- where they will be retried later.
-}
handleAdds :: Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete
direct <- liftAnnex isDirect
(pending', cleanup) <- if direct
then return (pending, noop)
else findnew pending
(postponed, toadd) <- partitionEithers <$> safeToAdd delayadd pending' inprocess
cleanup
unless (null postponed) $
refillChanges postponed
returnWhen (null toadd) $ do
added <- addaction toadd $
catMaybes <$> if direct
then adddirect toadd
else forM toadd add
if DirWatcher.eventsCoalesce || null added || direct
then return $ added ++ otherchanges
else do
r <- handleAdds delayadd =<< getChanges
return $ r ++ added ++ otherchanges
where
(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs
findnew [] = return ([], noop)
findnew pending@(exemplar:_) = do
(newfiles, cleanup) <- liftAnnex $
inRepo (Git.LsFiles.notInRepo False $ map changeFile pending)
-- note: timestamp info is lost here
let ts = changeTime exemplar
return (map (PendingAddChange ts) newfiles, void $ liftIO $ cleanup)
returnWhen c a
| c = return otherchanges
| otherwise = a
add :: Change -> Assistant (Maybe Change)
add change@(InProcessAddChange { keySource = ks }) =
catchDefaultIO Nothing <~> do
sanitycheck ks $ do
key <- liftAnnex $ do
showStart "add" $ keyFilename ks
Command.Add.ingest $ Just ks
maybe (failedingest change) (done change $ keyFilename ks) key
add _ = return Nothing
{- In direct mode, avoid overhead of re-injesting a renamed
- file, by examining the other Changes to see if a removed
- file has the same InodeCache as the new file. If so,
- we can just update bookkeeping, and stage the file in git.
-}
adddirect :: [Change] -> Assistant [Maybe Change]
adddirect toadd = do
ct <- liftAnnex compareInodeCachesWith
m <- liftAnnex $ removedKeysMap ct cs
if M.null m
then forM toadd add
else forM toadd $ \c -> do
mcache <- liftIO $ genInodeCache $ changeFile c
case mcache of
Nothing -> add c
Just cache ->
case M.lookup (inodeCacheToKey ct cache) m of
Nothing -> add c
Just k -> fastadd c k
fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd change key = do
let source = keySource change
liftAnnex $ Command.Add.finishIngestDirect key source
done change (keyFilename source) key
removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c ->
catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
recordedInodeCache k
failedingest change = do
refill [retryChange change]
liftAnnex showEndFail
return Nothing
done change file key = liftAnnex $ do
logStatus key InfoPresent
link <- ifM isDirect
( inRepo $ gitAnnexLink file key
, Command.Add.link file key True
)
whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do
stageSymlink file =<< hashSymlink link
showEndOk
return $ Just $ finishedChange change key
{- Check that the keysource's keyFilename still exists,
- and is still a hard link to its contentLocation,
- before ingesting it. -}
sanitycheck keysource a = do
fs <- liftIO $ getSymbolicLinkStatus $ keyFilename keysource
ks <- liftIO $ getSymbolicLinkStatus $ contentLocation keysource
if deviceID ks == deviceID fs && fileID ks == fileID fs
then a
else do
-- remove the hard link
when (contentLocation keysource /= keyFilename keysource) $
void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
return Nothing
{- Shown an alert while performing an action to add a file or
- files. When only a few files are added, their names are shown
- in the alert. When it's a batch add, the number of files added
- is shown.
-
- Add errors tend to be transient and will be
- automatically dealt with, so the alert is always told
- the add succeeded.
-}
addaction [] a = a
addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
(,)
<$> pure True
<*> a
{- Files can Either be Right to be added now,
- or are unsafe, and must be Left for later.
-
- Check by running lsof on the repository.
-}
safeToAdd :: Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ [] [] = return []
safeToAdd delayadd pending inprocess = do
maybe noop (liftIO . threadDelaySeconds) delayadd
liftAnnex $ do
keysources <- mapM Command.Add.lockDown (map changeFile pending)
let inprocess' = inprocess ++ catMaybes (map mkinprocess $ zip pending keysources)
openfiles <- S.fromList . map fst3 . filter openwrite <$>
findopenfiles (map keySource inprocess')
let checked = map (check openfiles) inprocess'
{- If new events are received when files are closed,
- there's no need to retry any changes that cannot
- be done now. -}
if DirWatcher.closingTracked
then do
mapM_ canceladd $ lefts checked
allRight $ rights checked
else return checked
where
check openfiles change@(InProcessAddChange { keySource = ks })
| S.member (contentLocation ks) openfiles = Left change
check _ change = Right change
mkinprocess (c, Just ks) = Just $ InProcessAddChange
{ changeTime = changeTime c
, keySource = ks
}
mkinprocess (_, Nothing) = Nothing
canceladd (InProcessAddChange { keySource = ks }) = do
warning $ keyFilename ks
++ " still has writers, not adding"
-- remove the hard link
when (contentLocation ks /= keyFilename ks) $
void $ liftIO $ tryIO $ removeFile $ contentLocation ks
canceladd _ = noop
openwrite (_file, mode, _pid)
| mode == Lsof.OpenWriteOnly = True
| mode == Lsof.OpenReadWrite = True
| mode == Lsof.OpenUnknown = True
| otherwise = False
allRight = return . map Right
{- Normally the KeySources are locked down inside the temp directory,
- so can just lsof that, which is quite efficient.
-
- In crippled filesystem mode, there is no lock down, so must run lsof
- on each individual file.
-}
findopenfiles keysources = ifM crippledFileSystem
( liftIO $ do
let segments = segmentXargs $ map keyFilename keysources
concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
, do
tmpdir <- fromRepo gitAnnexTmpDir
liftIO $ Lsof.queryDir tmpdir
)
{- After a Change is committed, queue any necessary transfers or drops
- of the content of the key.
-
- This is not done during the startup scan, because the expensive
- transfer scan does the same thing then.
-}
checkChangeContent :: Change -> Assistant ()
checkChangeContent change@(Change { changeInfo = i }) =
case changeInfoKey i of
Nothing -> noop
Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
present <- liftAnnex $ inAnnex k
if present
then queueTransfers "new file created" Next k (Just f) Upload
else queueTransfers "new or renamed file wanted" Next k (Just f) Download
handleDrops "file renamed" present k (Just f) Nothing
where
f = changeFile change
checkChangeContent _ = noop

View file

@ -0,0 +1,86 @@
{- git-annex assistant config monitor thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.ConfigMonitor where
import Assistant.Common
import Assistant.BranchChange
import Assistant.DaemonStatus
import Assistant.Commits
import Utility.ThreadScheduler
import Logs.UUID
import Logs.Trust
import Logs.Remote
import Logs.PreferredContent
import Logs.Group
import Remote.List (remoteListRefresh)
import qualified Git.LsTree as LsTree
import qualified Annex.Branch
import qualified Data.Set as S
{- This thread detects when configuration changes have been made to the
- git-annex branch and reloads cached configuration.
-
- If the branch is frequently changing, it's checked for configuration
- changes no more often than once every 60 seconds. On the other hand,
- if the branch has not changed in a while, configuration changes will
- be detected immediately.
-}
configMonitorThread :: NamedThread
configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
where
loop old = do
waitBranchChange
new <- getConfigs
when (old /= new) $ do
let changedconfigs = new `S.difference` old
debug $ "reloading config" :
map fst (S.toList changedconfigs)
reloadConfigs new
{- Record a commit to get this config
- change pushed out to remotes. -}
recordCommit
liftIO $ threadDelaySeconds (Seconds 60)
loop new
{- Config files, and their checksums. -}
type Configs = S.Set (FilePath, String)
{- All git-annex's config files, and actions to run when they change. -}
configFilesActions :: [(FilePath, Annex ())]
configFilesActions =
[ (uuidLog, void $ uuidMapLoad)
, (remoteLog, void remoteListRefresh)
, (trustLog, void trustMapLoad)
, (groupLog, void groupMapLoad)
-- Preferred content settings depend on most of the other configs,
-- so will be reloaded whenever any configs change.
, (preferredContentLog, noop)
]
reloadConfigs :: Configs -> Assistant ()
reloadConfigs changedconfigs = do
liftAnnex $ do
sequence_ as
void preferredContentMapLoad
{- Changes to the remote log, or the trust log, can affect the
- syncRemotes list. Changes to the uuid log may affect its
- display so are also included. -}
when (any (`elem` fs) [remoteLog, trustLog, uuidLog]) $
updateSyncRemotes
where
(fs, as) = unzip $ filter (flip S.member changedfiles . fst)
configFilesActions
changedfiles = S.map fst changedconfigs
getConfigs :: Assistant Configs
getConfigs = S.fromList . map extract
<$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files)
where
files = map fst configFilesActions
extract treeitem = (LsTree.file treeitem, LsTree.sha treeitem)

View file

@ -0,0 +1,29 @@
{- git-annex assistant daemon status thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.DaemonStatus where
import Assistant.Common
import Assistant.DaemonStatus
import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
{- This writes the daemon status to disk, when it changes, but no more
- frequently than once every ten minutes.
-}
daemonStatusThread :: NamedThread
daemonStatusThread = namedThread "DaemonStatus" $ do
notifier <- liftIO . newNotificationHandle False
=<< changeNotifier <$> getDaemonStatus
checkpoint
runEvery (Seconds tenMinutes) <~> do
liftIO $ waitNotification notifier
checkpoint
where
checkpoint = do
file <- liftAnnex $ fromRepo gitAnnexDaemonStatusFile
liftIO . writeDaemonStatusFile file =<< getDaemonStatus

View file

@ -0,0 +1,43 @@
{- git-annex assistant Amazon Glacier retrieval
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Threads.Glacier where
import Assistant.Common
import Utility.ThreadScheduler
import qualified Types.Remote as Remote
import qualified Remote.Glacier as Glacier
import Logs.Transfer
import Assistant.DaemonStatus
import Assistant.TransferQueue
import qualified Data.Set as S
{- Wakes up every half hour and checks if any glacier remotes have failed
- downloads. If so, runs glacier-cli to check if the files are now
- available, and queues the downloads. -}
glacierThread :: NamedThread
glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go
where
isglacier r = Remote.remotetype r == Glacier.remote
go = do
rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus
forM_ rs $ \r ->
check r =<< (liftAnnex $ getFailedTransfers $ Remote.uuid r)
check _ [] = noop
check r l = do
let keys = map getkey l
(availkeys, failedkeys) <- liftAnnex $ Glacier.jobList r keys
let s = S.fromList (failedkeys ++ availkeys)
let l' = filter (\p -> S.member (getkey p) s) l
forM_ l' $ \(t, info) -> do
liftAnnex $ removeFailedTransfer t
queueTransferWhenSmall "object available from glacier" (associatedFile info) t r
getkey = transferKey . fst

118
Assistant/Threads/Merger.hs Normal file
View file

@ -0,0 +1,118 @@
{- git-annex assistant git merge thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.TransferQueue
import Assistant.BranchChange
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Annex.Branch
import qualified Git
import qualified Git.Branch
import qualified Command.Sync
import Annex.TaggedPush
import Remote (remoteFromUUID)
import qualified Data.Set as S
import qualified Data.Text as T
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let dir = Git.localGitDir g </> "refs"
liftIO $ createDirectoryIfMissing True dir
let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange
errhook <- hook onErr
let hooks = mkWatchHooks
{ addHook = changehook
, modifyHook = changehook
, errHook = errhook
}
void $ liftIO $ watchDir dir (const False) hooks id
debug ["watching", dir]
type Handler = FilePath -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
onErr :: Handler
onErr msg = error msg
{- Called when a new branch ref is written, or a branch ref is modified.
-
- At startup, synthetic add events fire, causing this to run, but that's
- ok; it ensures that any changes pushed since the last time the assistant
- ran are merged in.
-}
onChange :: Handler
onChange file
| ".lock" `isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate
when diverged $
unlessM handleDesynced $
queueDeferredDownloads "retrying deferred download" Later
| "/synced/" `isInfixOf` file =
mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
| otherwise = noop
where
changedbranch = fileToBranch file
mergecurrent (Just current)
| equivBranches changedbranch current = do
debug
[ "merging", show changedbranch
, "into", show current
]
void $ liftAnnex $ Command.Sync.mergeFrom changedbranch
mergecurrent _ = noop
handleDesynced = case fromTaggedBranch changedbranch of
Nothing -> return False
Just (u, info) -> do
mr <- liftAnnex $ remoteFromUUID u
case mr of
Nothing -> return False
Just r -> do
s <- desynced <$> getDaemonStatus
if S.member u s || Just (T.unpack $ getXMPPClientID r) == info
then do
modifyDaemonStatus_ $ \st -> st
{ desynced = S.delete u s }
addScanRemotes True [r]
return True
else return False
equivBranches :: Git.Ref -> Git.Ref -> Bool
equivBranches x y = base x == base y
where
base = takeFileName . show
isAnnexBranch :: FilePath -> Bool
isAnnexBranch f = n `isSuffixOf` f
where
n = "/" ++ show Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref
fileToBranch f = Git.Ref $ "refs" </> base
where
base = Prelude.last $ split "/refs/" f

View file

@ -0,0 +1,192 @@
{- git-annex assistant mount watcher, using either dbus or mtab polling
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Threads.MountWatcher where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Sync
import qualified Annex
import qualified Git
import Utility.ThreadScheduler
import Utility.Mounts
import Remote.List
import qualified Types.Remote as Remote
import qualified Data.Set as S
#if WITH_DBUS
import Utility.DBus
import DBus.Client
import DBus
import Data.Word (Word32)
import Control.Concurrent
import qualified Control.Exception as E
#else
#warning Building without dbus support; will use mtab polling
#endif
mountWatcherThread :: NamedThread
mountWatcherThread = namedThread "MountWatcher" $
#if WITH_DBUS
dbusThread
#else
pollingThread
#endif
#if WITH_DBUS
dbusThread :: Assistant ()
dbusThread = do
runclient <- asIO1 go
r <- liftIO $ E.try $ runClient getSessionAddress runclient
either onerr (const noop) r
where
go client = ifM (checkMountMonitor client)
( do
{- Store the current mount points in an MVar, to be
- compared later. We could in theory work out the
- mount point from the dbus message, but this is
- easier. -}
mvar <- liftIO $ newMVar =<< currentMountPoints
handleevent <- asIO1 $ \_event -> do
nowmounted <- liftIO $ currentMountPoints
wasmounted <- liftIO $ swapMVar mvar nowmounted
handleMounts wasmounted nowmounted
liftIO $ forM_ mountChanged $ \matcher ->
listen client matcher handleevent
, do
liftAnnex $
warning "No known volume monitor available through dbus; falling back to mtab polling"
pollingThread
)
onerr :: E.SomeException -> Assistant ()
onerr e = do
{- If the session dbus fails, the user probably
- logged out of their desktop. Even if they log
- back in, we won't have access to the dbus
- session key, so polling is the best that can be
- done in this situation. -}
liftAnnex $
warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
pollingThread
{- Examine the list of services connected to dbus, to see if there
- are any we can use to monitor mounts. If not, will attempt to start one. -}
checkMountMonitor :: Client -> Assistant Bool
checkMountMonitor client = do
running <- filter (`elem` usableservices)
<$> liftIO (listServiceNames client)
case running of
[] -> startOneService client startableservices
(service:_) -> do
debug [ "Using running DBUS service"
, service
, "to monitor mount events."
]
return True
where
startableservices = [gvfs, gvfsgdu]
usableservices = startableservices ++ [kde]
gvfs = "org.gtk.Private.UDisks2VolumeMonitor"
gvfsgdu = "org.gtk.Private.GduVolumeMonitor"
kde = "org.kde.DeviceNotifications"
startOneService :: Client -> [ServiceName] -> Assistant Bool
startOneService _ [] = return False
startOneService client (x:xs) = do
_ <- liftIO $ tryNonAsync $ callDBus client "StartServiceByName"
[toVariant x, toVariant (0 :: Word32)]
ifM (liftIO $ elem x <$> listServiceNames client)
( do
debug
[ "Started DBUS service", x
, "to monitor mount events."
]
return True
, startOneService client xs
)
{- Filter matching events recieved when drives are mounted and unmounted. -}
mountChanged :: [MatchRule]
mountChanged = [gvfs True, gvfs False, kde, kdefallback]
where
{- gvfs reliably generates this event whenever a
- drive is mounted/unmounted, whether automatically, or manually -}
gvfs mount = matchAny
{ matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor"
, matchMember = Just $ if mount then "MountAdded" else "MountRemoved"
}
{- This event fires when KDE prompts the user what to do with a drive,
- but maybe not at other times. And it's not received -}
kde = matchAny
{ matchInterface = Just "org.kde.Solid.Device"
, matchMember = Just "setupDone"
}
{- This event may not be closely related to mounting a drive, but it's
- observed reliably when a drive gets mounted or unmounted. -}
kdefallback = matchAny
{ matchInterface = Just "org.kde.KDirNotify"
, matchMember = Just "enteredDirectory"
}
#endif
pollingThread :: Assistant ()
pollingThread = go =<< liftIO currentMountPoints
where
go wasmounted = do
liftIO $ threadDelaySeconds (Seconds 10)
nowmounted <- liftIO currentMountPoints
handleMounts wasmounted nowmounted
go nowmounted
handleMounts :: MountPoints -> MountPoints -> Assistant ()
handleMounts wasmounted nowmounted =
mapM_ (handleMount . mnt_dir) $
S.toList $ newMountPoints wasmounted nowmounted
handleMount :: FilePath -> Assistant ()
handleMount dir = do
debug ["detected mount of", dir]
rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
reconnectRemotes True rs
{- Finds remotes located underneath the mount point.
-
- Updates state to include the remotes.
-
- The config of git remotes is re-read, as it may not have been available
- at startup time, or may have changed (it could even be a different
- repository at the same remote location..)
-}
remotesUnder :: FilePath -> Assistant [Remote]
remotesUnder dir = do
repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList
pairs <- liftAnnex $ mapM (checkremote repotop) rs
let (waschanged, rs') = unzip pairs
when (any id waschanged) $ do
liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' }
updateSyncRemotes
return $ map snd $ filter fst pairs
where
checkremote repotop r = case Remote.localpath r of
Just p | dirContains dir (absPathFrom repotop p) ->
(,) <$> pure True <*> updateRemote r
_ -> return (False, r)
type MountPoints = S.Set Mntent
currentMountPoints :: IO MountPoints
currentMountPoints = S.fromList <$> getMounts
newMountPoints :: MountPoints -> MountPoints -> MountPoints
newMountPoints old new = S.difference new old

View file

@ -0,0 +1,131 @@
{- git-annex assistant network connection watcher, using dbus
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Threads.NetWatcher where
import Assistant.Common
import Assistant.Sync
import Utility.ThreadScheduler
import qualified Types.Remote as Remote
import Assistant.DaemonStatus
#if WITH_DBUS
import Utility.DBus
import DBus.Client
import DBus
import Data.Word (Word32)
import Assistant.NetMessager
#else
#warning Building without dbus support; will poll for network connection changes
#endif
netWatcherThread :: NamedThread
#if WITH_DBUS
netWatcherThread = thread dbusThread
#else
netWatcherThread = thread noop
#endif
where
thread = namedThread "NetWatcher"
{- This is a fallback for when dbus cannot be used to detect
- network connection changes, but it also ensures that
- any networked remotes that may have not been routable for a
- while (despite the local network staying up), are synced with
- periodically. -}
netWatcherFallbackThread :: NamedThread
netWatcherFallbackThread = namedThread "NetWatcherFallback" $
runEvery (Seconds 3600) <~> handleConnection
#if WITH_DBUS
dbusThread :: Assistant ()
dbusThread = do
handleerr <- asIO2 onerr
runclient <- asIO1 go
liftIO $ persistentClient getSystemAddress () handleerr runclient
where
go client = ifM (checkNetMonitor client)
( do
listenNMConnections client <~> handleconn
listenWicdConnections client <~> handleconn
, do
liftAnnex $
warning "No known network monitor available through dbus; falling back to polling"
)
handleconn = do
debug ["detected network connection"]
notifyNetMessagerRestart
handleConnection
onerr e _ = do
liftAnnex $
warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
{- Wait, in hope that dbus will come back -}
liftIO $ threadDelaySeconds (Seconds 60)
{- Examine the list of services connected to dbus, to see if there
- are any we can use to monitor network connections. -}
checkNetMonitor :: Client -> Assistant Bool
checkNetMonitor client = do
running <- liftIO $ filter (`elem` [networkmanager, wicd])
<$> listServiceNames client
case running of
[] -> return False
(service:_) -> do
debug [ "Using running DBUS service"
, service
, "to monitor network connection events."
]
return True
where
networkmanager = "org.freedesktop.NetworkManager"
wicd = "org.wicd.daemon"
{- Listens for new NetworkManager connections. -}
listenNMConnections :: Client -> IO () -> IO ()
listenNMConnections client callback =
listen client matcher $ \event ->
when (Just True == anyM activeconnection (signalBody event)) $
callback
where
matcher = matchAny
{ matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active"
, matchMember = Just "PropertiesChanged"
}
nm_connection_activated = toVariant (2 :: Word32)
nm_state_key = toVariant ("State" :: String)
activeconnection v = do
m <- fromVariant v
vstate <- lookup nm_state_key $ dictionaryItems m
state <- fromVariant vstate
return $ state == nm_connection_activated
{- Listens for new Wicd connections. -}
listenWicdConnections :: Client -> IO () -> IO ()
listenWicdConnections client callback =
listen client matcher $ \event ->
when (any (== wicd_success) (signalBody event)) $
callback
where
matcher = matchAny
{ matchInterface = Just "org.wicd.daemon"
, matchMember = Just "ConnectResultsSent"
}
wicd_success = toVariant ("success" :: String)
#endif
handleConnection :: Assistant ()
handleConnection = reconnectRemotes True =<< networkRemotes
{- Network remotes to sync with. -}
networkRemotes :: Assistant [Remote]
networkRemotes = filter (isNothing . Remote.localpath) . syncRemotes
<$> getDaemonStatus

View file

@ -0,0 +1,148 @@
{- git-annex assistant thread to listen for incoming pairing traffic
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.PairListener where
import Assistant.Common
import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.Pairing.MakeRemote
import Assistant.WebApp (UrlRenderer)
import Assistant.WebApp.Types
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.ThreadScheduler
import Git
import Network.Multicast
import Network.Socket
import qualified Data.Text as T
import Data.Char
pairListenerThread :: UrlRenderer -> NamedThread
pairListenerThread urlrenderer = namedThread "PairListener" $ do
listener <- asIO1 $ go [] []
liftIO $ withSocketsDo $
runEvery (Seconds 1) $ void $ tryIO $
listener =<< getsock
where
{- Note this can crash if there's no network interface,
- or only one like lo that doesn't support multicast. -}
getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of
Nothing -> go reqs cache sock
Just m -> do
debug ["received", show msg]
sane <- checkSane msg
(pip, verified) <- verificationCheck m
=<< (pairingInProgress <$> getDaemonStatus)
let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
case (wrongstage, sane, pairMsgStage m) of
-- ignore our own messages, and
-- out of order messages
(True, _, _) -> go reqs cache sock
(_, False, _) -> go reqs cache sock
(_, _, PairReq) -> if m `elem` reqs
then go reqs (invalidateCache m cache) sock
else do
pairReqReceived verified urlrenderer m
go (m:take 10 reqs) (invalidateCache m cache) sock
(_, _, PairAck) -> do
cache' <- pairAckReceived verified pip m cache
go reqs cache' sock
(_, _, PairDone) -> do
pairDoneReceived verified pip m
go reqs cache sock
{- As well as verifying the message using the shared secret,
- check its UUID against the UUID we have stored. If
- they're the same, someone is sending bogus messages,
- which could be an attempt to brute force the shared secret. -}
verificationCheck _ Nothing = return (Nothing, False)
verificationCheck m (Just pip)
| not verified && sameuuid = do
liftAnnex $ warning
"detected possible pairing brute force attempt; disabled pairing"
stopSending pip
return (Nothing, False)
|otherwise = return (Just pip, verified && sameuuid)
where
verified = verifiedPairMsg m pip
sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
{- Various sanity checks on the content of the message. -}
checkSane msg
{- Control characters could be used in a
- console poisoning attack. -}
| any isControl msg || any (`elem` "\r\n") msg = do
liftAnnex $ warning
"illegal control characters in pairing message; ignoring"
return False
| otherwise = return True
{- PairReqs invalidate the cache of recently finished pairings.
- This is so that, if a new pairing is started with the
- same secret used before, a bogus PairDone is not sent. -}
invalidateCache msg = filter (not . verifiedPairMsg msg)
getmsg sock c = do
(msg, n, _) <- recvFrom sock chunksz
if n < chunksz
then return $ c ++ msg
else getmsg sock $ c ++ msg
where
chunksz = 1024
{- Show an alert when a PairReq is seen. -}
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
pairReqReceived True _ _ = noop -- ignore our own PairReq
pairReqReceived False urlrenderer msg = do
button <- mkAlertButton (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
void $ addAlert $ pairRequestReceivedAlert repo button
where
repo = pairRepo msg
{- When a verified PairAck is seen, a host is ready to pair with us, and has
- already configured our ssh key. Stop sending PairReqs, finish the pairing,
- and send a single PairDone. -}
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
pairAckReceived True (Just pip) msg cache = do
stopSending pip
repodir <- repoPath <$> liftAnnex gitRepo
liftIO $ setupAuthorizedKeys msg repodir
finishedLocalPairing msg (inProgressSshKeyPair pip)
startSending pip PairDone $ multicastPairMsg
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
return $ pip : take 10 cache
{- A stale PairAck might also be seen, after we've finished pairing.
- Perhaps our PairDone was not received. To handle this, we keep
- a cache of recently finished pairings, and re-send PairDone in
- response to stale PairAcks for them. -}
pairAckReceived _ _ msg cache = do
let pips = filter (verifiedPairMsg msg) cache
unless (null pips) $
forM_ pips $ \pip ->
startSending pip PairDone $ multicastPairMsg
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
return cache
{- If we get a verified PairDone, the host has accepted our PairAck, and
- has paired with us. Stop sending PairAcks, and finish pairing with them.
-
- TODO: Should third-party hosts remove their pair request alert when they
- see a PairDone?
- Complication: The user could have already clicked on the alert and be
- entering the secret. Would be better to start a fresh pair request in this
- situation.
-}
pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()
pairDoneReceived False _ _ = noop -- not verified
pairDoneReceived True Nothing _ = noop -- not in progress
pairDoneReceived True (Just pip) msg = do
stopSending pip
finishedLocalPairing msg (inProgressSshKeyPair pip)

View file

@ -0,0 +1,48 @@
{- git-annex assistant git pushing thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Pusher where
import Assistant.Common
import Assistant.Commits
import Assistant.Pushes
import Assistant.DaemonStatus
import Assistant.Sync
import Utility.ThreadScheduler
import qualified Types.Remote as Remote
{- This thread retries pushes that failed before. -}
pushRetryThread :: NamedThread
pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
-- We already waited half an hour, now wait until there are failed
-- pushes to retry.
topush <- getFailedPushesBefore (fromIntegral halfhour)
unless (null topush) $ do
debug ["retrying", show (length topush), "failed pushes"]
void $ pushToRemotes True topush
where
halfhour = 1800
{- This thread pushes git commits out to remotes soon after they are made. -}
pushThread :: NamedThread
pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do
-- We already waited two seconds as a simple rate limiter.
-- Next, wait until at least one commit has been made
void getCommits
-- Now see if now's a good time to push.
void $ pushToRemotes True =<< pushTargets
{- We want to avoid pushing to remotes that are marked readonly.
-
- Also, avoid pushing to local remotes we can easily tell are not available,
- to avoid ugly messages when a removable drive is not attached.
-}
pushTargets :: Assistant [Remote]
pushTargets = liftIO . filterM available =<< candidates <$> getDaemonStatus
where
candidates = filter (not . Remote.readonly) . syncGitRemotes
available = maybe (return True) doesDirectoryExist . Remote.localpath

View file

@ -0,0 +1,138 @@
{- git-annex assistant sanity checker
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.SanityChecker (
sanityCheckerDailyThread,
sanityCheckerHourlyThread
) where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Alert
import qualified Git.LsFiles
import qualified Git.Command
import qualified Git.Config
import Utility.ThreadScheduler
import qualified Assistant.Threads.Watcher as Watcher
import Utility.LogFile
import Utility.Batch
import Config
import Data.Time.Clock.POSIX
{- This thread wakes up hourly for inxepensive frequent sanity checks. -}
sanityCheckerHourlyThread :: NamedThread
sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
liftIO $ threadDelaySeconds $ Seconds oneHour
hourlyCheck
{- This thread wakes up daily to make sure the tree is in good shape. -}
sanityCheckerDailyThread :: NamedThread
sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do
waitForNextCheck
debug ["starting sanity check"]
void $ alertWhile sanityCheckAlert go
debug ["sanity check complete"]
where
go = do
modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
now <- liftIO $ getPOSIXTime -- before check started
r <- either showerr return =<< (tryIO . batch) <~> dailyCheck
modifyDaemonStatus_ $ \s -> s
{ sanityCheckRunning = False
, lastSanityCheck = Just now
}
return r
showerr e = do
liftAnnex $ warning $ show e
return False
{- Only run one check per day, from the time of the last check. -}
waitForNextCheck :: Assistant ()
waitForNextCheck = do
v <- lastSanityCheck <$> getDaemonStatus
now <- liftIO getPOSIXTime
liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v
where
calcdelay _ Nothing = oneDay
calcdelay now (Just lastcheck)
| lastcheck < now = max oneDay $
oneDay - truncate (now - lastcheck)
| otherwise = oneDay
{- It's important to stay out of the Annex monad as much as possible while
- running potentially expensive parts of this check, since remaining in it
- will block the watcher. -}
dailyCheck :: Assistant Bool
dailyCheck = do
g <- liftAnnex gitRepo
-- Find old unstaged symlinks, and add them to git.
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
now <- liftIO $ getPOSIXTime
forM_ unstaged $ \file -> do
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
case ms of
Just s | toonew (statusChangeTime s) now -> noop
| isSymbolicLink s -> addsymlink file ms
_ -> noop
liftIO $ void cleanup
{- Allow git-gc to run once per day. More frequent gc is avoided
- by default to avoid slowing things down. Only run repacks when 100x
- the usual number of loose objects are present; we tend
- to have a lot of small objects and they should not be a
- significant size. -}
when (Git.Config.getMaybe "gc.auto" g == Just "0") $
liftIO $ void $ Git.Command.runBool
[ Param "-c", Param "gc.auto=670000"
, Param "gc"
, Param "--auto"
] g
return True
where
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
slop = fromIntegral tenMinutes
insanity msg = do
liftAnnex $ warning msg
void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do
isdirect <- liftAnnex isDirect
Watcher.runHandler (Watcher.onAddSymlink isdirect) file s
insanity $ "found unstaged symlink: " ++ file
hourlyCheck :: Assistant ()
hourlyCheck = checkLogSize 0
{- Rotate logs until log file size is < 1 mb. -}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
f <- liftAnnex $ fromRepo gitAnnexLogFile
logs <- liftIO $ listLogs f
totalsize <- liftIO $ sum <$> mapM filesize logs
when (totalsize > oneMegabyte) $ do
notice ["Rotated logs due to size:", show totalsize]
liftIO $ openLog f >>= redirLog
when (n < maxLogs + 1) $
checkLogSize $ n + 1
where
filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f)
oneMegabyte :: Int
oneMegabyte = 1000000
oneHour :: Int
oneHour = 60 * 60
oneDay :: Int
oneDay = 24 * oneHour

View file

@ -0,0 +1,56 @@
{- git-annex assistant transfer polling thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.TransferPoller where
import Assistant.Common
import Assistant.DaemonStatus
import Logs.Transfer
import Utility.NotificationBroadcaster
import qualified Assistant.Threads.TransferWatcher as TransferWatcher
import Control.Concurrent
import qualified Data.Map as M
{- This thread polls the status of ongoing transfers, determining how much
- of each transfer is complete. -}
transferPollerThread :: NamedThread
transferPollerThread = namedThread "TransferPoller" $ do
g <- liftAnnex gitRepo
tn <- liftIO . newNotificationHandle True =<<
transferNotifier <$> getDaemonStatus
forever $ do
liftIO $ threadDelay 500000 -- 0.5 seconds
ts <- currentTransfers <$> getDaemonStatus
if M.null ts
-- block until transfers running
then liftIO $ waitNotification tn
else mapM_ (poll g) $ M.toList ts
where
poll g (t, info)
{- Downloads are polled by checking the size of the
- temp file being used for the transfer. -}
| transferDirection t == Download = do
let f = gitAnnexTmpLocation (transferKey t) g
sz <- liftIO $ catchMaybeIO $
fromIntegral . fileSize <$> getFileStatus f
newsize t info sz
{- Uploads don't need to be polled for when the TransferWatcher
- thread can track file modifications. -}
| TransferWatcher.watchesTransferSize = noop
{- Otherwise, this code polls the upload progress
- by reading the transfer info file. -}
| otherwise = do
let f = transferFile t g
mi <- liftIO $ catchDefaultIO Nothing $
readTransferInfoFile Nothing f
maybe noop (newsize t info . bytesComplete) mi
newsize t info sz
| bytesComplete info /= sz && isJust sz =
alterTransferInfo t $ \i -> i { bytesComplete = sz }
| otherwise = noop

View file

@ -0,0 +1,180 @@
{- git-annex assistant thread to scan remotes to find needed transfers
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.TransferScanner where
import Assistant.Common
import Assistant.Types.ScanRemotes
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.DaemonStatus
import Assistant.Drop
import Assistant.Sync
import Assistant.DeleteRemote
import Assistant.Types.UrlRenderer
import Logs.Transfer
import Logs.Location
import Logs.Group
import Logs.Web (webUUID)
import qualified Remote
import qualified Types.Remote as Remote
import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
import Utility.Batch
import qualified Git.LsFiles as LsFiles
import qualified Backend
import Annex.Content
import Annex.Wanted
import qualified Data.Set as S
{- This thread waits until a remote needs to be scanned, to find transfers
- that need to be made, to keep data in sync.
-}
transferScannerThread :: UrlRenderer -> NamedThread
transferScannerThread urlrenderer = namedThread "TransferScanner" $ do
startupScan
go S.empty
where
go scanned = do
scanrunning False
liftIO $ threadDelaySeconds (Seconds 2)
(rs, infos) <- unzip <$> getScanRemote
scanrunning True
if any fullScan infos || any (`S.notMember` scanned) rs
then do
expensiveScan urlrenderer rs
go $ scanned `S.union` S.fromList rs
else do
mapM_ failedTransferScan rs
go scanned
scanrunning b = do
ds <- modifyDaemonStatus $ \s ->
(s { transferScanRunning = b }, s)
liftIO $ sendNotification $ transferNotifier ds
{- All git remotes are synced, and all available remotes
- are scanned in full on startup, for multiple reasons, including:
-
- * This may be the first run, and there may be remotes
- already in place, that need to be synced.
- * Changes may have been made last time we run, but remotes were
- not available to be synced with.
- * Changes may have been made to remotes while we were down.
- * We may have run before, and scanned a remote, but
- only been in a subdirectory of the git remote, and so
- not synced it all.
- * We may have run before, and had transfers queued,
- and then the system (or us) crashed, and that info was
- lost.
- * A remote may be in the unwanted group, and this is a chance
- to determine if the remote has been emptied.
-}
startupScan = do
reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus
addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus
{- This is a cheap scan for failed transfers involving a remote. -}
failedTransferScan :: Remote -> Assistant ()
failedTransferScan r = do
failed <- liftAnnex $ getFailedTransfers (Remote.uuid r)
liftAnnex $ mapM_ removeFailedTransfer $ map fst failed
mapM_ retry failed
where
retry (t, info)
| transferDirection t == Download = do
{- Check if the remote still has the key.
- If not, relies on the expensiveScan to
- get it queued from some other remote. -}
whenM (liftAnnex $ remoteHas r $ transferKey t) $
requeue t info
| otherwise = do
{- The Transferrer checks when uploading
- that the remote doesn't already have the
- key, so it's not redundantly checked here. -}
requeue t info
requeue t info = queueTransferWhenSmall "retrying failed transfer" (associatedFile info) t r
{- This is a expensive scan through the full git work tree, finding
- files to transfer. The scan is blocked when the transfer queue gets
- too large.
-
- This also finds files that are present either here or on a remote
- but that are not preferred content, and drops them. Searching for files
- to drop is done concurrently with the scan for transfers.
-
- TODO: It would be better to first drop as much as we can, before
- transferring much, to minimise disk use.
-
- During the scan, we'll also check if any unwanted repositories are empty,
- and can be removed. While unrelated, this is a cheap place to do it,
- since we need to look at the locations of all keys anyway.
-}
expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()
expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
debug ["starting scan of", show visiblers]
unwantedrs <- liftAnnex $ S.fromList
<$> filterM inUnwantedGroup (map Remote.uuid rs)
g <- liftAnnex gitRepo
(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
removablers <- scan unwantedrs files
void $ liftIO cleanup
debug ["finished scan of", show visiblers]
remove <- asIO1 $ removableRemote urlrenderer
liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers
where
onlyweb = all (== webUUID) $ map Remote.uuid rs
visiblers = let rs' = filter (not . Remote.readonly) rs
in if null rs' then rs else rs'
scan unwanted [] = return unwanted
scan unwanted (f:fs) = do
(unwanted', ts) <- maybe
(return (unwanted, []))
(findtransfers f unwanted)
=<< liftAnnex (Backend.lookupFile f)
mapM_ (enqueue f) ts
scan unwanted' fs
enqueue f (r, t) =
queueTransferWhenSmall "expensive scan found missing object"
(Just f) t r
findtransfers f unwanted (key, _) = do
{- The syncable remotes may have changed since this
- scan began. -}
syncrs <- syncDataRemotes <$> getDaemonStatus
locs <- liftAnnex $ loggedLocations key
present <- liftAnnex $ inAnnex key
handleDropsFrom locs syncrs
"expensive scan found too many copies of object"
present key (Just f) Nothing
liftAnnex $ do
let slocs = S.fromList locs
let use a = return $ catMaybes $ map (a key slocs) syncrs
ts <- if present
then filterM (wantSend True (Just f) . Remote.uuid . fst)
=<< use (genTransfer Upload False)
else ifM (wantGet True $ Just f)
( use (genTransfer Download True) , return [] )
let unwanted' = S.difference unwanted slocs
return (unwanted', ts)
genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
genTransfer direction want key slocs r
| direction == Upload && Remote.readonly r = Nothing
| (S.member (Remote.uuid r) slocs) == want = Just
(r, Transfer direction (Remote.uuid r) key)
| otherwise = Nothing
remoteHas :: Remote -> Key -> Annex Bool
remoteHas r key = elem
<$> pure (Remote.uuid r)
<*> loggedLocations key

View file

@ -0,0 +1,126 @@
{- git-annex assistant transfer watching thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.TransferWatcher where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.Drop
import Annex.Content
import Logs.Transfer
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Remote
import Control.Concurrent
{- This thread watches for changes to the gitAnnexTransferDir,
- and updates the DaemonStatus's map of ongoing transfers. -}
transferWatcherThread :: NamedThread
transferWatcherThread = namedThread "TransferWatcher" $ do
dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo
liftIO $ createDirectoryIfMissing True dir
let hook a = Just <$> asIO2 (runHandler a)
addhook <- hook onAdd
delhook <- hook onDel
modifyhook <- hook onModify
errhook <- hook onErr
let hooks = mkWatchHooks
{ addHook = addhook
, delHook = delhook
, modifyHook = modifyhook
, errHook = errhook
}
void $ liftIO $ watchDir dir (const False) hooks id
debug ["watching for transfers"]
type Handler = FilePath -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
onErr :: Handler
onErr msg = error msg
{- Called when a new transfer information file is written. -}
onAdd :: Handler
onAdd file = case parseTransferFile file of
Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t)
where
go _ Nothing = noop -- transfer already finished
go t (Just info) = do
debug [ "transfer starting:", describeTransfer t info ]
r <- liftAnnex $ Remote.remoteFromUUID $ transferUUID t
updateTransferInfo t info { transferRemote = r }
{- Called when a transfer information file is updated.
-
- The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
onModify :: Handler
onModify file = do
case parseTransferFile file of
Nothing -> noop
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where
go _ Nothing = noop
go t (Just newinfo) = alterTransferInfo t $
\i -> i { bytesComplete = bytesComplete newinfo }
{- This thread can only watch transfer sizes when the DirWatcher supports
- tracking modificatons to files. -}
watchesTransferSize :: Bool
watchesTransferSize = modifyTracked
{- Called when a transfer information file is removed. -}
onDel :: Handler
onDel file = case parseTransferFile file of
Nothing -> noop
Just t -> do
debug [ "transfer finishing:", show t]
minfo <- removeTransfer t
finished <- asIO2 finishedTransfer
void $ liftIO $ forkIO $ do
{- XXX race workaround delay. The location
- log needs to be updated before finishedTransfer
- runs. -}
threadDelay 10000000 -- 10 seconds
finished t minfo
{- Queue uploads of files downloaded to us, spreading them
- out to other reachable remotes.
-
- Downloading a file may have caused a remote to not want it;
- so check for drops from remotes.
-
- Uploading a file may cause the local repo, or some other remote to not
- want it; handle that too.
-}
finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
finishedTransfer t (Just info)
| transferDirection t == Download =
whenM (liftAnnex $ inAnnex $ transferKey t) $ do
dodrops False
queueTransfersMatching (/= transferUUID t)
"newly received object"
Later (transferKey t) (associatedFile info) Upload
| otherwise = dodrops True
where
dodrops fromhere = handleDrops
("drop wanted after " ++ describeTransfer t info)
fromhere (transferKey t) (associatedFile info) Nothing
finishedTransfer _ _ = noop

View file

@ -0,0 +1,140 @@
{- git-annex assistant data transferrer thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Transferrer where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.Commits
import Assistant.Drop
import Assistant.TransferrerPool
import Logs.Transfer
import Logs.Location
import Annex.Content
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git
import Config.Files
import Assistant.Threads.TransferWatcher
import Annex.Wanted
{- Dispatches transfers from the queue. -}
transfererThread :: NamedThread
transfererThread = namedThread "Transferrer" $ do
program <- liftIO readProgramFile
forever $ inTransferSlot program $
maybe (return Nothing) (uncurry $ genTransfer)
=<< getNextTransfer notrunning
where
{- Skip transfers that are already running. -}
notrunning = isNothing . startedTime
{- By the time this is called, the daemonstatus's currentTransfers map should
- already have been updated to include the transfer. -}
genTransfer :: Transfer -> TransferInfo -> TransferGenerator
genTransfer t info = case (transferRemote info, associatedFile info) of
(Just remote, Just file)
| Git.repoIsLocalUnknown (Remote.repo remote) -> do
-- optimisation for removable drives not plugged in
liftAnnex $ recordFailedTransfer t info
void $ removeTransfer t
return Nothing
| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
( do
debug [ "Transferring:" , describeTransfer t info ]
notifyTransfer
return $ Just (t, info, go remote file)
, do
debug [ "Skipping unnecessary transfer:",
describeTransfer t info ]
void $ removeTransfer t
finishedTransfer t (Just info)
return Nothing
)
_ -> return Nothing
where
direction = transferDirection t
isdownload = direction == Download
{- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons,
- so there's no point in bothering the user about
- those. The assistant should recover.
-
- After a successful upload, handle dropping it from
- here, if desired. In this case, the remote it was
- uploaded to is known to have it.
-
- Also, after a successful transfer, the location
- log has changed. Indicate that a commit has been
- made, in order to queue a push of the git-annex
- branch out to remotes that did not participate
- in the transfer.
-
- If the process failed, it could have crashed,
- so remove the transfer from the list of current
- transfers, just in case it didn't stop
- in a way that lets the TransferWatcher do its
- usual cleanup. However, first check if something else is
- running the transfer, to avoid removing active transfers.
-}
go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
( do
void $ addAlert $ makeAlertFiller True $
transferFileAlert direction True file
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
True (transferKey t)
(associatedFile info)
(Just remote)
void $ recordCommit
, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
void $ removeTransfer t
)
{- Called right before a transfer begins, this is a last chance to avoid
- unnecessary transfers.
-
- For downloads, we obviously don't need to download if the already
- have the object.
-
- Smilarly, for uploads, check if the remote is known to already have
- the object.
-
- Also, uploads get queued to all remotes, in order of cost.
- This may mean, for example, that an object is uploaded over the LAN
- to a locally paired client, and once that upload is done, a more
- expensive transfer remote no longer wants the object. (Since
- all the clients have it already.) So do one last check if this is still
- preferred content.
-
- We'll also do one last preferred content check for downloads. An
- example of a case where this could be needed is if a download is queued
- for a file that gets moved out of an archive directory -- but before
- that download can happen, the file is put back in the archive.
-}
shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
shouldTransfer t info
| transferDirection t == Download =
(not <$> inAnnex key) <&&> wantGet True file
| transferDirection t == Upload = case transferRemote info of
Nothing -> return False
Just r -> notinremote r
<&&> wantSend True file (Remote.uuid r)
| otherwise = return False
where
key = transferKey t
file = associatedFile info
{- Trust the location log to check if the remote already has
- the key. This avoids a roundtrip to the remote. -}
notinremote r = notElem (Remote.uuid r) <$> loggedLocations key

View file

@ -0,0 +1,352 @@
{- git-annex assistant tree watcher
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-}
module Assistant.Threads.Watcher (
watchThread,
WatcherException(..),
checkCanWatch,
needLsof,
onAddSymlink,
runHandler,
) where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Changes
import Assistant.Types.Changes
import Assistant.Alert
import Utility.DirWatcher
import Utility.DirWatcher.Types
import Utility.Lsof
import qualified Annex
import qualified Annex.Queue
import qualified Git
import qualified Git.UpdateIndex
import qualified Git.LsFiles as LsFiles
import qualified Backend
import Annex.Direct
import Annex.Content.Direct
import Annex.CatFile
import Annex.CheckIgnore
import Annex.Link
import Annex.FileMatcher
import Annex.ReplaceFile
import Git.Types
import Config
import Utility.ThreadScheduler
import Data.Bits.Utils
import Data.Typeable
import qualified Data.ByteString.Lazy as L
import qualified Control.Exception as E
import Data.Time.Clock
checkCanWatch :: Annex ()
checkCanWatch
| canWatch = do
liftIO setupLsof
unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force)
needLsof
| otherwise = error "watch mode is not available on this system"
needLsof :: Annex ()
needLsof = error $ unlines
[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
, "To override lsof checks to ensure that files are not open for writing"
, "when added to the annex, you can use --force"
, "Be warned: This can corrupt data in the annex, and make fsck complain."
]
{- A special exception that can be thrown to pause or resume the watcher. -}
data WatcherException = PauseWatcher | ResumeWatcher
deriving (Show, Eq, Typeable)
instance E.Exception WatcherException
watchThread :: NamedThread
watchThread = namedThread "Watcher" $
ifM (liftAnnex $ annexAutoCommit <$> Annex.getGitConfig)
( runWatcher
, waitFor ResumeWatcher runWatcher
)
runWatcher :: Assistant ()
runWatcher = do
startup <- asIO1 startupScan
matcher <- liftAnnex $ largeFilesMatcher
direct <- liftAnnex isDirect
symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig
addhook <- hook $ if direct
then onAddDirect symlinkssupported matcher
else onAdd matcher
delhook <- hook onDel
addsymlinkhook <- hook $ onAddSymlink direct
deldirhook <- hook onDelDir
errhook <- hook onErr
let hooks = mkWatchHooks
{ addHook = addhook
, delHook = delhook
, addSymlinkHook = addsymlinkhook
, delDirHook = deldirhook
, errHook = errhook
}
handle <- liftIO $ watchDir "." ignored hooks startup
debug [ "watching", "."]
{- Let the DirWatcher thread run until signalled to pause it,
- then wait for a resume signal, and restart. -}
waitFor PauseWatcher $ do
liftIO $ stopWatchDir handle
waitFor ResumeWatcher runWatcher
where
hook a = Just <$> asIO2 (runHandler a)
waitFor :: WatcherException -> Assistant () -> Assistant ()
waitFor sig next = do
r <- liftIO $ (E.try pause :: IO (Either E.SomeException ()))
case r of
Left e -> case E.fromException e of
Just s
| s == sig -> next
_ -> noop
_ -> noop
where
pause = runEvery (Seconds 86400) noop
{- Initial scartup scan. The action should return once the scan is complete. -}
startupScan :: IO a -> Assistant a
startupScan scanner = do
liftAnnex $ showAction "scanning"
alertWhile' startupScanAlert $ do
r <- liftIO $ scanner
-- Notice any files that were deleted before
-- watching was started.
top <- liftAnnex $ fromRepo Git.repoPath
(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top]
forM_ fs $ \f -> do
liftAnnex $ onDel' f
maybe noop recordChange =<< madeChange f RmChange
void $ liftIO $ cleanup
liftAnnex $ showAction "started"
liftIO $ putStrLn ""
modifyDaemonStatus_ $ \s -> s { scanComplete = True }
return (True, r)
{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
- at the entire .git directory. Does not include .gitignores. -}
ignored :: FilePath -> Bool
ignored = ig . takeFileName
where
ig ".git" = True
ig ".gitignore" = True
ig ".gitattributes" = True
#ifdef darwin_HOST_OS
ig ".DS_Store" = True
#endif
ig _ = False
unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
unlessIgnored file a = ifM (liftAnnex $ checkIgnored file)
( noChange
, a
)
type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
{- Runs an action handler, and if there was a change, adds it to the ChangeChan.
-
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-}
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus
case r of
Left e -> liftIO $ print e
Right Nothing -> noop
Right (Just change) -> do
-- Just in case the commit thread is not
-- flushing the queue fast enough.
liftAnnex $ Annex.Queue.flushWhenFull
recordChange change
where
normalize f
| "./" `isPrefixOf` file = drop 2 f
| otherwise = f
{- Small files are added to git as-is, while large ones go into the annex. -}
add :: FileMatcher -> FilePath -> Assistant (Maybe Change)
add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file)
( pendingAddChange file
, do
liftAnnex $ Annex.Queue.addCommand "add"
[Params "--force --"] [file]
madeChange file AddFileChange
)
onAdd :: FileMatcher -> Handler
onAdd matcher file filestatus
| maybe False isRegularFile filestatus =
unlessIgnored file $
add matcher file
| otherwise = noChange
{- In direct mode, add events are received for both new files, and
- modified existing files.
-}
onAddDirect :: Bool -> FileMatcher -> Handler
onAddDirect symlinkssupported matcher file fs = do
v <- liftAnnex $ catKeyFile file
case (v, fs) of
(Just key, Just filestatus) ->
ifM (liftAnnex $ sameFileStatus key filestatus)
{- It's possible to get an add event for
- an existing file that is not
- really modified, but it might have
- just been deleted and been put back,
- so it symlink is restaged to make sure. -}
( ifM (scanComplete <$> getDaemonStatus)
( do
link <- liftAnnex $ inRepo $ gitAnnexLink file key
addLink file link (Just key)
, noChange
)
, guardSymlinkStandin (Just key) $ do
debug ["changed direct", file]
liftAnnex $ changedDirect key file
add matcher file
)
_ -> unlessIgnored file $
guardSymlinkStandin Nothing $ do
debug ["add direct", file]
add matcher file
where
{- On a filesystem without symlinks, we'll get changes for regular
- files that git uses to stand-in for symlinks. Detect when
- this happens, and stage the symlink, rather than annexing the
- file. -}
guardSymlinkStandin mk a
| symlinkssupported = a
| otherwise = do
linktarget <- liftAnnex $ getAnnexLinkTarget file
case linktarget of
Nothing -> a
Just lt -> do
case fileKey $ takeFileName lt of
Nothing -> noop
Just key -> void $ liftAnnex $
addAssociatedFile key file
onAddSymlink' linktarget mk True file fs
{- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content
- before adding it.
-}
onAddSymlink :: Bool -> Handler
onAddSymlink isdirect file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
kv <- liftAnnex (Backend.lookupFile file)
onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus
onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
onAddSymlink' linktarget mk isdirect file filestatus = go mk
where
go (Just key) = do
when isdirect $
liftAnnex $ void $ addAssociatedFile key file
link <- liftAnnex $ inRepo $ gitAnnexLink file key
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
unless isdirect $
liftAnnex $ replaceFile file $
makeAnnexLink link
addLink file link (Just key)
-- other symlink, not git-annex
go Nothing = ensurestaged linktarget =<< getDaemonStatus
{- This is often called on symlinks that are already
- staged correctly. A symlink may have been deleted
- and being re-added, or added when the watcher was
- not running. So they're normally restaged to make sure.
-
- As an optimisation, during the startup scan, avoid
- restaging everything. Only links that were created since
- the last time the daemon was running are staged.
- (If the daemon has never ran before, avoid staging
- links too.)
-}
ensurestaged (Just link) daemonstatus
| scanComplete daemonstatus = addLink file link mk
| otherwise = case filestatus of
Just s
| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
_ -> addLink file link mk
ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -}
addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
debug ["add symlink", file]
liftAnnex $ do
v <- catObjectDetails $ Ref $ ':':file
case v of
Just (currlink, sha)
| s2w8 link == L.unpack currlink ->
stageSymlink file sha
_ -> stageSymlink file =<< hashSymlink link
madeChange file $ LinkChange mk
onDel :: Handler
onDel file _ = do
debug ["file deleted", file]
liftAnnex $ onDel' file
madeChange file RmChange
onDel' :: FilePath -> Annex ()
onDel' file = do
whenM isDirect $ do
mkey <- catKeyFile file
case mkey of
Nothing -> noop
Just key -> void $ removeAssociatedFile key file
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile file)
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
- use --cached to only delete it from the index.
-
- This queues up a lot of RmChanges, which assists the Committer in
- pairing up renamed files when the directory was renamed. -}
onDelDir :: Handler
onDelDir dir _ = do
debug ["directory deleted", dir]
(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir]
liftAnnex $ mapM_ onDel' fs
-- Get the events queued up as fast as possible, so the
-- committer sees them all in one block.
now <- liftIO getCurrentTime
recordChanges $ map (\f -> Change now f RmChange) fs
void $ liftIO $ clean
liftAnnex $ Annex.Queue.flushWhenFull
noChange
{- Called when there's an error with inotify or kqueue. -}
onErr :: Handler
onErr msg _ = do
liftAnnex $ warning msg
void $ addAlert $ warningAlert "watcher" msg
noChange

101
Assistant/Threads/WebApp.hs Normal file
View file

@ -0,0 +1,101 @@
{- git-annex assistant webapp thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.Threads.WebApp where
import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.DashBoard
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
import Assistant.WebApp.Configurators.AWS
import Assistant.WebApp.Configurators.IA
import Assistant.WebApp.Configurators.WebDAV
import Assistant.WebApp.Configurators.XMPP
import Assistant.WebApp.Configurators.Preferences
import Assistant.WebApp.Configurators.Edit
import Assistant.WebApp.Configurators.Delete
import Assistant.WebApp.Documentation
import Assistant.WebApp.Control
import Assistant.WebApp.OtherRepos
import Assistant.Types.ThreadedMonad
import Utility.WebApp
import Utility.Tmp
import Utility.FileMode
import Git
import Yesod
import Network.Socket (SockAddr, HostName)
import Data.Text (pack, unpack)
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
type Url = String
webAppThread
:: AssistantData
-> UrlRenderer
-> Bool
-> Maybe HostName
-> Maybe (IO Url)
-> Maybe (Url -> FilePath -> IO ())
-> NamedThread
webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do
#ifdef __ANDROID__
when (isJust listenhost) $
-- See Utility.WebApp
error "Sorry, --listen is not currently supported on Android"
#endif
webapp <- WebApp
<$> pure assistantdata
<*> (pack <$> genRandomToken)
<*> getreldir
<*> pure staticRoutes
<*> pure postfirstrun
<*> pure noannex
<*> pure listenhost
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
app <- toWaiAppPlain webapp
app' <- ifM debugEnabled
( return $ httpDebugLogger app
, return app
)
runWebApp listenhost app' $ \addr -> if noannex
then withTmpFile "webapp.html" $ \tmpfile _ ->
go addr webapp tmpfile Nothing
else do
let st = threadState assistantdata
htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
go addr webapp htmlshim (Just urlfile)
where
thread = namedThread "WebApp"
getreldir
| noannex = return Nothing
| otherwise = Just <$>
(relHome =<< absPath
=<< runThreadState (threadState assistantdata) (fromRepo repoPath))
go addr webapp htmlshim urlfile = do
let url = myUrl webapp addr
maybe noop (`writeFileProtected` url) urlfile
writeHtmlShim "Starting webapp..." url htmlshim
maybe noop (\a -> a url htmlshim) onstartup
myUrl :: WebApp -> SockAddr -> Url
myUrl webapp addr = unpack $ yesodRender webapp urlbase DashboardR []
where
urlbase = pack $ "http://" ++ show addr

View file

@ -0,0 +1,370 @@
{- git-annex XMPP client
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.XMPPClient where
import Assistant.Common
import Assistant.XMPP
import Assistant.XMPP.Client
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.Types.Buddies
import Assistant.XMPP.Buddies
import Assistant.Sync
import Assistant.DaemonStatus
import qualified Remote
import Utility.ThreadScheduler
import Assistant.WebApp (UrlRenderer)
import Assistant.WebApp.Types hiding (liftAssistant)
import Assistant.Alert
import Assistant.Pairing
import Assistant.XMPP.Git
import Annex.UUID
import Logs.UUID
import Network.Protocol.XMPP
import Control.Concurrent
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM (atomically)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Git.Branch
import Data.Time.Clock
import Control.Concurrent.Async
xmppClientThread :: UrlRenderer -> NamedThread
xmppClientThread urlrenderer = namedThread "XMPPClient" $
restartableClient . xmppClient urlrenderer =<< getAssistant id
{- Runs the client, handing restart events. -}
restartableClient :: (XMPPCreds -> IO ()) -> Assistant ()
restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
where
go Nothing = waitNetMessagerRestart
go (Just creds) = do
tid <- liftIO $ forkIO $ a creds
waitNetMessagerRestart
liftIO $ killThread tid
xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO ()
xmppClient urlrenderer d creds =
retry (runclient creds) =<< getCurrentTime
where
liftAssistant = runAssistant d
inAssistant = liftIO . liftAssistant
{- When the client exits, it's restarted;
- if it keeps failing, back off to wait 5 minutes before
- trying it again. -}
retry client starttime = do
{- The buddy list starts empty each time
- the client connects, so that stale info
- is not retained. -}
liftAssistant $
updateBuddyList (const noBuddies) <<~ buddyList
void client
liftAssistant $ modifyDaemonStatus_ $ \s -> s
{ xmppClientID = Nothing }
now <- getCurrentTime
if diffUTCTime now starttime > 300
then do
liftAssistant $ debug ["connection lost; reconnecting"]
retry client now
else do
liftAssistant $ debug ["connection failed; will retry"]
threadDelaySeconds (Seconds 300)
retry client =<< getCurrentTime
runclient c = liftIO $ connectXMPP c $ \jid -> do
selfjid <- bindJID jid
putStanza gitAnnexSignature
inAssistant $ do
modifyDaemonStatus_ $ \s -> s
{ xmppClientID = Just $ xmppJID creds }
debug ["connected", logJid selfjid]
lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime
sender <- xmppSession $ sendnotifications selfjid
receiver <- xmppSession $ receivenotifications selfjid lasttraffic
pinger <- xmppSession $ sendpings selfjid lasttraffic
{- Run all 3 threads concurrently, until
- any of them throw an exception.
- Then kill all 3 threads, and rethrow the
- exception.
-
- If this thread gets an exception, the 3 threads
- will also be killed. -}
liftIO $ pinger `concurrently` sender `concurrently` receiver
sendnotifications selfjid = forever $ do
a <- inAssistant $ relayNetMessage selfjid
a
receivenotifications selfjid lasttraffic = forever $ do
l <- decodeStanza selfjid <$> getStanza
void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime
inAssistant $ debug
["received:", show $ map logXMPPEvent l]
mapM_ (handle selfjid) l
sendpings selfjid lasttraffic = forever $ do
putStanza pingstanza
startping <- liftIO $ getCurrentTime
liftIO $ threadDelaySeconds (Seconds 120)
t <- liftIO $ atomically $ readTMVar lasttraffic
when (t < startping) $ do
inAssistant $ debug ["ping timeout"]
error "ping timeout"
where
{- XEP-0199 says that the server will respond with either
- a ping response or an error message. Either will
- cause traffic, so good enough. -}
pingstanza = xmppPing selfjid
handle selfjid (PresenceMessage p) = do
void $ inAssistant $
updateBuddyList (updateBuddies p) <<~ buddyList
resendImportantMessages selfjid p
handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
handle selfjid (GotNetMessage (PairingNotification stage c u)) =
maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
handle _ (GotNetMessage m@(Pushing _ pushstage))
| isPushNotice pushstage = inAssistant $ handlePushNotice m
| isPushInitiation pushstage = inAssistant $ queuePushInitiation m
| otherwise = inAssistant $ storeInbox m
handle _ (Ignorable _) = noop
handle _ (Unknown _) = noop
handle _ (ProtocolError _) = noop
resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do
let c = formatJID jid
(stored, sent) <- inAssistant $
checkImportantNetMessages (formatJID (baseJID jid), c)
forM_ (S.toList $ S.difference stored sent) $ \msg -> do
let msg' = readdressNetMessage msg c
inAssistant $ debug
[ "sending to new client:"
, logJid jid
, show $ logNetMessage msg'
]
a <- inAssistant $ convertNetMsg msg' selfjid
a
inAssistant $ sentImportantNetMessage msg c
resendImportantMessages _ _ = noop
data XMPPEvent
= GotNetMessage NetMessage
| PresenceMessage Presence
| Ignorable ReceivedStanza
| Unknown ReceivedStanza
| ProtocolError ReceivedStanza
deriving Show
logXMPPEvent :: XMPPEvent -> String
logXMPPEvent (GotNetMessage m) = logNetMessage m
logXMPPEvent (PresenceMessage p) = logPresence p
logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p
logXMPPEvent (Ignorable _) = "Ignorable message"
logXMPPEvent (Unknown _) = "Unknown message"
logXMPPEvent (ProtocolError _) = "Protocol error message"
logPresence :: Presence -> String
logPresence (p@Presence { presenceFrom = Just jid }) = unwords
[ "Presence from"
, logJid jid
, show $ extractGitAnnexTag p
]
logPresence _ = "Presence from unknown"
logJid :: JID -> String
logJid jid =
let name = T.unpack (buddyName jid)
resource = maybe "" (T.unpack . strResource) (jidResource jid)
in take 1 name ++ show (length name) ++ "/" ++ resource
logClient :: Client -> String
logClient (Client jid) = logJid jid
{- Decodes an XMPP stanza into one or more events. -}
decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
decodeStanza selfjid s@(ReceivedPresence p)
| presenceType p == PresenceError = [ProtocolError s]
| presenceFrom p == Nothing = [Ignorable s]
| presenceFrom p == Just selfjid = [Ignorable s]
| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
where
decode i
| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
decodePushNotification (tagValue i)
| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence
| otherwise = [Unknown s]
{- Things sent via presence imply a presence message,
- along with their real meaning. -}
impliedp v = [PresenceMessage p, v]
decodeStanza selfjid s@(ReceivedMessage m)
| messageFrom m == Nothing = [Ignorable s]
| messageFrom m == Just selfjid = [Ignorable s]
| messageType m == MessageError = [ProtocolError s]
| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
decodeStanza _ s = [Unknown s]
{- Waits for a NetMessager message to be sent, and relays it to XMPP.
-
- Chat messages must be directed to specific clients, not a base
- account JID, due to git-annex clients using a negative presence priority.
- PairingNotification messages are always directed at specific
- clients, but Pushing messages are sometimes not, and need to be exploded
- out to specific clients.
-
- Important messages, not directed at any specific client,
- are cached to be sent later when additional clients connect.
-}
relayNetMessage :: JID -> Assistant (XMPP ())
relayNetMessage selfjid = do
msg <- waitNetMessage
debug ["sending:", logNetMessage msg]
a1 <- handleImportant msg
a2 <- convert msg
return (a1 >> a2)
where
handleImportant msg = case parseJID =<< isImportantNetMessage msg of
Just tojid
| tojid == baseJID tojid -> do
storeImportantNetMessage msg (formatJID tojid) $
\c -> (baseJID <$> parseJID c) == Just tojid
return $ putStanza presenceQuery
_ -> return noop
convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> do
if tojid == baseJID tojid
then do
clients <- maybe [] (S.toList . buddyAssistants)
<$> getBuddy (genBuddyKey tojid) <<~ buddyList
debug ["exploded undirected message to clients", unwords $ map logClient clients]
return $ forM_ (clients) $ \(Client jid) ->
putStanza $ pushMessage pushstage jid selfjid
else do
debug ["to client:", logJid tojid]
return $ putStanza $ pushMessage pushstage tojid selfjid
convert msg = convertNetMsg msg selfjid
{- Converts a NetMessage to an XMPP action. -}
convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ())
convertNetMsg msg selfjid = convert msg
where
convert (NotifyPush us) = return $ putStanza $ pushNotification us
convert QueryPresence = return $ putStanza presenceQuery
convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do
changeBuddyPairing tojid True
return $ putStanza $ pairingNotification stage u tojid selfjid
convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
return $ putStanza $ pushMessage pushstage tojid selfjid
withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> (Assistant (XMPP ()))
withOtherClient selfjid c a = case parseJID c of
Nothing -> return noop
Just tojid
| tojid == selfjid -> return noop
| otherwise -> a tojid
withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()
withClient c a = maybe noop a $ parseJID c
{- Returns an IO action that runs a XMPP action in a separate thread,
- using a session to allow it to access the same XMPP client. -}
xmppSession :: XMPP () -> XMPP (IO ())
xmppSession a = do
s <- getSession
return $ void $ runXMPP s a
{- We only pull from one remote out of the set listed in the push
- notification, as an optimisation.
-
- Note that it might be possible (though very unlikely) for the push
- notification to take a while to be sent, and multiple pushes happen
- before it is sent, so it includes multiple remotes that were pushed
- to at different times.
-
- It could then be the case that the remote we choose had the earlier
- push sent to it, but then failed to get the later push, and so is not
- fully up-to-date. If that happens, the pushRetryThread will come along
- and retry the push, and we'll get another notification once it succeeds,
- and pull again. -}
pull :: [UUID] -> Assistant ()
pull [] = noop
pull us = do
rs <- filter matching . syncGitRemotes <$> getDaemonStatus
debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
pullone rs =<< liftAnnex (inRepo Git.Branch.current)
where
matching r = Remote.uuid r `S.member` s
s = S.fromList us
pullone [] _ = noop
pullone (r:rs) branch =
unlessM (null . fst <$> manualPull branch [r]) $
pullone rs branch
{- PairReq from another client using our JID is automatically
- accepted. This is so pairing devices all using the same XMPP
- account works without confirmations.
-
- Also, autoaccept PairReq from the same JID of any repo we've
- already paired with, as long as the UUID in the PairReq is
- one we know about.
-}
pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
| baseJID selfjid == baseJID theirjid = autoaccept
| otherwise = do
knownjids <- catMaybes . map (parseJID . getXMPPClientID)
. filter isXMPPRemote . syncRemotes <$> getDaemonStatus
um <- liftAnnex uuidMap
if any (== baseJID theirjid) knownjids && M.member theiruuid um
then autoaccept
else showalert
where
autoaccept = do
selfuuid <- liftAnnex getUUID
sendNetMessage $
PairingNotification PairAck (formatJID theirjid) selfuuid
finishXMPPPairing theirjid theiruuid
-- Show an alert to let the user decide if they want to pair.
showalert = do
button <- mkAlertButton (T.pack "Respond") urlrenderer $
ConfirmXMPPPairFriendR $
PairKey theiruuid $ formatJID theirjid
void $ addAlert $ pairRequestReceivedAlert
(T.unpack $ buddyName theirjid)
button
{- PairAck must come from one of the buddies we are pairing with;
- don't pair with just anyone. -}
pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
whenM (isBuddyPairing theirjid) $ do
changeBuddyPairing theirjid False
selfuuid <- liftAnnex getUUID
sendNetMessage $
PairingNotification PairDone (formatJID theirjid) selfuuid
finishXMPPPairing theirjid theiruuid
pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
changeBuddyPairing theirjid False
isBuddyPairing :: JID -> Assistant Bool
isBuddyPairing jid = maybe False buddyPairing <$>
getBuddy (genBuddyKey jid) <<~ buddyList
changeBuddyPairing :: JID -> Bool -> Assistant ()
changeBuddyPairing jid ispairing =
updateBuddyList (M.adjust set key) <<~ buddyList
where
key = genBuddyKey jid
set b = b { buddyPairing = ispairing }

View file

@ -0,0 +1,81 @@
{- git-annex XMPP pusher threads
-
- This is a pair of threads. One handles git send-pack,
- and the other git receive-pack. Each thread can be running at most
- one such operation at a time.
-
- Why not use a single thread? Consider two clients A and B.
- If both decide to run a receive-pack at the same time to the other,
- they would deadlock with only one thread. For larger numbers of
- clients, the two threads are also sufficient.
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.XMPPPusher where
import Assistant.Common
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.WebApp (UrlRenderer)
import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
import Assistant.XMPP.Git
import Control.Exception as E
xmppSendPackThread :: UrlRenderer -> NamedThread
xmppSendPackThread = pusherThread "XMPPSendPack" SendPack
xmppReceivePackThread :: UrlRenderer -> NamedThread
xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack
pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread
pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing
where
go lastpushedto = do
msg <- waitPushInitiation side $ selectNextPush lastpushedto
debug ["started running push", logNetMessage msg]
runpush <- asIO $ runPush checker msg
r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID)))
let successful = case r of
Right (Just _) -> True
_ -> False
{- Empty the inbox, because stuff may have
- been left in it if the push failed. -}
let justpushedto = getclient msg
maybe noop (`emptyInbox` side) justpushedto
debug ["finished running push", logNetMessage msg, show successful]
go $ if successful then justpushedto else lastpushedto
checker = checkCloudRepos urlrenderer
getclient (Pushing cid _) = Just cid
getclient _ = Nothing
{- Select the next push to run from the queue.
- The queue cannot be empty!
-
- We prefer to select the most recently added push, because its requestor
- is more likely to still be connected.
-
- When passed the ID of a client we just pushed to, we prefer to not
- immediately push again to that same client. This avoids one client
- drowing out others. So pushes from the client we just pushed to are
- relocated to the beginning of the list, to be processed later.
-}
selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage])
selectNextPush _ (m:[]) = (m, []) -- common case
selectNextPush _ [] = error "selectNextPush: empty list"
selectNextPush lastpushedto l = go [] l
where
go (r:ejected) [] = (r, ejected)
go rejected (m:ms) = case m of
(Pushing clientid _)
| Just clientid /= lastpushedto -> (m, rejected ++ ms)
_ -> go (m:rejected) ms
go [] [] = undefined

223
Assistant/TransferQueue.hs Normal file
View file

@ -0,0 +1,223 @@
{- git-annex assistant pending transfer queue
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.TransferQueue (
TransferQueue,
Schedule(..),
newTransferQueue,
getTransferQueue,
queueTransfers,
queueTransfersMatching,
queueDeferredDownloads,
queueTransfer,
queueTransferAt,
queueTransferWhenSmall,
getNextTransfer,
getMatchingTransfers,
dequeueTransfers,
) where
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Types.TransferQueue
import Logs.Transfer
import Types.Remote
import qualified Remote
import qualified Types.Remote as Remote
import Annex.Wanted
import Utility.TList
import Control.Concurrent.STM
import qualified Data.Map as M
import qualified Data.Set as S
type Reason = String
{- Reads the queue's content without blocking or changing it. -}
getTransferQueue :: Assistant [(Transfer, TransferInfo)]
getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue
stubInfo :: AssociatedFile -> Remote -> TransferInfo
stubInfo f r = stubTransferInfo
{ transferRemote = Just r
, associatedFile = f
}
{- Adds transfers to queue for some of the known remotes.
- Honors preferred content settings, only transferring wanted files. -}
queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
queueTransfers = queueTransfersMatching (const True)
{- Adds transfers to queue for some of the known remotes, that match a
- condition. Honors preferred content settings. -}
queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
queueTransfersMatching matching reason schedule k f direction
| direction == Download = whenM (liftAnnex $ wantGet True f) go
| otherwise = go
where
go = do
rs <- liftAnnex . selectremotes
=<< syncDataRemotes <$> getDaemonStatus
let matchingrs = filter (matching . Remote.uuid) rs
if null matchingrs
then defer
else forM_ matchingrs $ \r ->
enqueue reason schedule (gentransfer r) (stubInfo f r)
selectremotes rs
{- Queue downloads from all remotes that
- have the key. The list of remotes is ordered with
- cheapest first. More expensive ones will only be tried
- if downloading from a cheap one fails. -}
| direction == Download = do
s <- locs
return $ filter (inset s) rs
{- Upload to all remotes that want the content and don't
- already have it. -}
| otherwise = do
s <- locs
filterM (wantSend True f . Remote.uuid) $
filter (\r -> not (inset s r || Remote.readonly r)) rs
where
locs = S.fromList <$> Remote.keyLocations k
inset s r = S.member (Remote.uuid r) s
gentransfer r = Transfer
{ transferDirection = direction
, transferKey = k
, transferUUID = Remote.uuid r
}
defer
{- Defer this download, as no known remote has the key. -}
| direction == Download = do
q <- getAssistant transferQueue
void $ liftIO $ atomically $
consTList (deferreddownloads q) (k, f)
| otherwise = noop
{- Queues any deferred downloads that can now be accomplished, leaving
- any others in the list to try again later. -}
queueDeferredDownloads :: Reason -> Schedule -> Assistant ()
queueDeferredDownloads reason schedule = do
q <- getAssistant transferQueue
l <- liftIO $ atomically $ readTList (deferreddownloads q)
rs <- syncDataRemotes <$> getDaemonStatus
left <- filterM (queue rs) l
unless (null left) $
liftIO $ atomically $ appendTList (deferreddownloads q) left
where
queue rs (k, f) = do
uuids <- liftAnnex $ Remote.keyLocations k
let sources = filter (\r -> uuid r `elem` uuids) rs
unless (null sources) $
forM_ sources $ \r ->
enqueue reason schedule
(gentransfer r) (stubInfo f r)
return $ null sources
where
gentransfer r = Transfer
{ transferDirection = Download
, transferKey = k
, transferUUID = Remote.uuid r
}
enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant ()
enqueue reason schedule t info
| schedule == Next = go consTList
| otherwise = go snocTList
where
go modlist = whenM (add modlist) $ do
debug [ "queued", describeTransfer t info, ": " ++ reason ]
notifyTransfer
add modlist = do
q <- getAssistant transferQueue
dstatus <- getAssistant daemonStatusHandle
liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)
( return False
, do
l <- readTList (queuelist q)
if (t `notElem` map fst l)
then do
void $ modifyTVar' (queuesize q) succ
void $ modlist (queuelist q) (t, info)
return True
else return False
)
{- Adds a transfer to the queue. -}
queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
queueTransfer reason schedule f t remote =
enqueue reason schedule t (stubInfo f remote)
{- Blocks until the queue is no larger than a given size, and then adds a
- transfer to the queue. -}
queueTransferAt :: Int -> Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
queueTransferAt wantsz reason schedule f t remote = do
q <- getAssistant transferQueue
liftIO $ atomically $ do
sz <- readTVar (queuesize q)
unless (sz <= wantsz) $
retry -- blocks until queuesize changes
enqueue reason schedule t (stubInfo f remote)
queueTransferWhenSmall :: Reason -> AssociatedFile -> Transfer -> Remote -> Assistant ()
queueTransferWhenSmall reason = queueTransferAt 10 reason Later
{- Blocks until a pending transfer is available in the queue,
- and removes it.
-
- Checks that it's acceptable, before adding it to the
- currentTransfers map. If it's not acceptable, it's discarded.
-
- This is done in a single STM transaction, so there is no window
- where an observer sees an inconsistent status. -}
getNextTransfer :: (TransferInfo -> Bool) -> Assistant (Maybe (Transfer, TransferInfo))
getNextTransfer acceptable = do
q <- getAssistant transferQueue
dstatus <- getAssistant daemonStatusHandle
liftIO $ atomically $ do
sz <- readTVar (queuesize q)
if sz < 1
then retry -- blocks until queuesize changes
else do
(r@(t,info):rest) <- readTList (queuelist q)
void $ modifyTVar' (queuesize q) pred
setTList (queuelist q) rest
if acceptable info
then do
adjustTransfersSTM dstatus $
M.insertWith' const t info
return $ Just r
else return Nothing
{- Moves transfers matching a condition from the queue, to the
- currentTransfers map. -}
getMatchingTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
getMatchingTransfers c = do
q <- getAssistant transferQueue
dstatus <- getAssistant daemonStatusHandle
liftIO $ atomically $ do
ts <- dequeueTransfersSTM q c
unless (null ts) $
adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts
return ts
{- Removes transfers matching a condition from the queue, and returns the
- removed transfers. -}
dequeueTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
dequeueTransfers c = do
q <- getAssistant transferQueue
removed <- liftIO $ atomically $ dequeueTransfersSTM q c
unless (null removed) $
notifyTransfer
return removed
dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)]
dequeueTransfersSTM q c = do
(removed, ts) <- partition (c . fst) <$> readTList (queuelist q)
void $ writeTVar (queuesize q) (length ts)
setTList (queuelist q) ts
return removed

View file

@ -0,0 +1,78 @@
{- git-annex assistant transfer slots
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.TransferSlots where
import Assistant.Common
import Utility.ThreadScheduler
import Assistant.Types.TransferSlots
import Assistant.DaemonStatus
import Assistant.TransferrerPool
import Assistant.Types.TransferrerPool
import Logs.Transfer
import qualified Control.Exception as E
import Control.Concurrent
import qualified Control.Concurrent.MSemN as MSemN
type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
{- Waits until a transfer slot becomes available, then runs a
- TransferGenerator, and then runs the transfer action in its own thread.
-}
inTransferSlot :: FilePath -> TransferGenerator -> Assistant ()
inTransferSlot program gen = do
flip MSemN.wait 1 <<~ transferSlots
runTransferThread program =<< gen
{- Runs a TransferGenerator, and its transfer action,
- without waiting for a slot to become available. -}
inImmediateTransferSlot :: FilePath -> TransferGenerator -> Assistant ()
inImmediateTransferSlot program gen = do
flip MSemN.signal (-1) <<~ transferSlots
runTransferThread program =<< gen
{- Runs a transfer action, in an already allocated transfer slot.
- Once it finishes, frees the transfer slot.
-
- Note that the action is subject to being killed when the transfer
- is canceled or paused.
-
- A PauseTransfer exception is handled by letting the action be killed,
- then pausing the thread until a ResumeTransfer exception is raised,
- then rerunning the action.
-}
runTransferThread :: FilePath -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots
runTransferThread program (Just (t, info, a)) = do
d <- getAssistant id
aio <- asIO1 a
tid <- liftIO $ forkIO $ runTransferThread' program d aio
updateTransferInfo t $ info { transferTid = Just tid }
runTransferThread' :: FilePath -> AssistantData -> (Transferrer -> IO ()) -> IO ()
runTransferThread' program d run = go
where
go = catchPauseResume $
withTransferrer program (transferrerPool d)
run
pause = catchPauseResume $
runEvery (Seconds 86400) noop
{- Note: This must use E.try, rather than E.catch.
- When E.catch is used, and has called go in its exception
- handler, Control.Concurrent.throwTo will block sometimes
- when signaling. Using E.try avoids the problem. -}
catchPauseResume a' = do
r <- E.try a' :: IO (Either E.SomeException ())
case r of
Left e -> case E.fromException e of
Just PauseTransfer -> pause
Just ResumeTransfer -> go
_ -> done
_ -> done
done = runAssistant d $
flip MSemN.signal 1 <<~ transferSlots

View file

@ -0,0 +1,82 @@
{- A pool of "git-annex transferkeys" processes
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.TransferrerPool where
import Assistant.Common
import Assistant.Types.TransferrerPool
import Logs.Transfer
import qualified Command.TransferKeys as T
import Control.Concurrent.STM
import System.Process (create_group)
import Control.Exception (throw)
import Control.Concurrent
{- Runs an action with a Transferrer from the pool. -}
withTransferrer :: FilePath -> TransferrerPool -> (Transferrer -> IO a) -> IO a
withTransferrer program pool a = do
t <- maybe (mkTransferrer program) (checkTransferrer program)
=<< atomically (tryReadTChan pool)
v <- tryNonAsync $ a t
unlessM (putback t) $
void $ forkIO $ stopTransferrer t
either throw return v
where
putback t = atomically $ ifM (isEmptyTChan pool)
( do
writeTChan pool t
return True
, return False
)
{- Requests that a Transferrer perform a Transfer, and waits for it to
- finish. -}
performTransfer :: Transferrer -> Transfer -> AssociatedFile -> IO Bool
performTransfer transferrer t f = catchBoolIO $ do
T.sendRequest t f (transferrerWrite transferrer)
T.readResponse (transferrerRead transferrer)
{- Starts a new git-annex transferkeys process, setting up a pipe
- that will be used to communicate with it. -}
mkTransferrer :: FilePath -> IO Transferrer
mkTransferrer program = do
(myread, twrite) <- createPipe
(tread, mywrite) <- createPipe
mapM_ (\fd -> setFdOption fd CloseOnExec True) [myread, mywrite]
let params =
[ Param "transferkeys"
, Param "--readfd", Param $ show tread
, Param "--writefd", Param $ show twrite
]
{- It's put into its own group so that the whole group can be
- killed to stop a transfer. -}
(_, _, _, pid) <- createProcess (proc program $ toCommand params)
{ create_group = True }
closeFd twrite
closeFd tread
myreadh <- fdToHandle myread
mywriteh <- fdToHandle mywrite
fileEncoding myreadh
fileEncoding mywriteh
return $ Transferrer
{ transferrerRead = myreadh
, transferrerWrite = mywriteh
, transferrerHandle = pid
}
{- Checks if a Transferrer is still running. If not, makes a new one. -}
checkTransferrer :: FilePath -> Transferrer -> IO Transferrer
checkTransferrer program t = maybe (return t) (const $ mkTransferrer program)
=<< getProcessExitCode (transferrerHandle t)
{- Closing the fds will stop the transferrer. -}
stopTransferrer :: Transferrer -> IO ()
stopTransferrer t = do
hClose $ transferrerRead t
hClose $ transferrerWrite t
void $ waitForProcess $ transferrerHandle t

75
Assistant/Types/Alert.hs Normal file
View file

@ -0,0 +1,75 @@
{- git-annex assistant alert types
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.Alert where
import Utility.Tense
import Data.Text (Text)
import qualified Data.Map as M
{- Different classes of alerts are displayed differently. -}
data AlertClass = Success | Message | Activity | Warning | Error
deriving (Eq, Ord)
data AlertPriority = Filler | Low | Medium | High | Pinned
deriving (Eq, Ord)
{- An alert can have an name, which is used to combine it with other similar
- alerts. -}
data AlertName
= FileAlert TenseChunk
| SanityCheckFixAlert
| WarningAlert String
| PairAlert String
| XMPPNeededAlert
| RemoteRemovalAlert String
| CloudRepoNeededAlert
| SyncAlert
deriving (Eq)
{- The first alert is the new alert, the second is an old alert.
- Should return a modified version of the old alert. -}
type AlertCombiner = Alert -> Alert -> Maybe Alert
data Alert = Alert
{ alertClass :: AlertClass
, alertHeader :: Maybe TenseText
, alertMessageRender :: Alert -> TenseText
, alertData :: [TenseChunk]
, alertCounter :: Int
, alertBlockDisplay :: Bool
, alertClosable :: Bool
, alertPriority :: AlertPriority
, alertIcon :: Maybe AlertIcon
, alertCombiner :: Maybe AlertCombiner
, alertName :: Maybe AlertName
, alertButton :: Maybe AlertButton
}
data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud
type AlertMap = M.Map AlertId Alert
{- Higher AlertId indicates a more recent alert. -}
newtype AlertId = AlertId Integer
deriving (Read, Show, Eq, Ord)
firstAlertId :: AlertId
firstAlertId = AlertId 0
nextAlertId :: AlertId -> AlertId
nextAlertId (AlertId i) = AlertId $ succ i
{- When clicked, a button always redirects to a URL
- It may also run an IO action in the background, which is useful
- to make the button close or otherwise change the alert. -}
data AlertButton = AlertButton
{ buttonLabel :: Text
, buttonUrl :: Text
, buttonAction :: Maybe (AlertId -> IO ())
}

View file

@ -0,0 +1,19 @@
{- git-annex assistant git-annex branch change tracking
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.BranchChange where
import Control.Concurrent.MSampleVar
import Common.Annex
newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ())
newBranchChangeHandle :: IO BranchChangeHandle
newBranchChangeHandle = BranchChangeHandle <$> newEmptySV
fromBranchChangeHandle :: BranchChangeHandle -> MSampleVar ()
fromBranchChangeHandle (BranchChangeHandle v) = v

View file

@ -0,0 +1,80 @@
{- git-annex assistant buddies
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Types.Buddies where
import Common.Annex
import qualified Data.Map as M
import Control.Concurrent.STM
import Utility.NotificationBroadcaster
import Data.Text as T
{- For simplicity, dummy types are defined even when XMPP is disabled. -}
#ifdef WITH_XMPP
import Network.Protocol.XMPP
import Data.Set as S
import Data.Ord
newtype Client = Client JID
deriving (Eq, Show)
instance Ord Client where
compare = comparing show
data Buddy = Buddy
{ buddyPresent :: S.Set Client
, buddyAway :: S.Set Client
, buddyAssistants :: S.Set Client
, buddyPairing :: Bool
}
#else
data Buddy = Buddy
#endif
deriving (Eq, Show)
data BuddyKey = BuddyKey T.Text
deriving (Eq, Ord, Show, Read)
data PairKey = PairKey UUID T.Text
deriving (Eq, Ord, Show, Read)
type Buddies = M.Map BuddyKey Buddy
{- A list of buddies, and a way to notify when it changes. -}
type BuddyList = (TMVar Buddies, NotificationBroadcaster)
noBuddies :: Buddies
noBuddies = M.empty
newBuddyList :: IO BuddyList
newBuddyList = (,)
<$> atomically (newTMVar noBuddies)
<*> newNotificationBroadcaster
getBuddyList :: BuddyList -> IO [Buddy]
getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)
getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
getBuddyBroadcaster (_, h) = h
{- Applies a function to modify the buddy list, and if it's changed,
- sends notifications to any listeners. -}
updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
updateBuddyList a (v, caster) = do
changed <- atomically $ do
buds <- takeTMVar v
let buds' = a buds
putTMVar v buds'
return $ buds /= buds'
when changed $
sendNotification caster

View file

@ -0,0 +1,77 @@
{- git-annex assistant change tracking
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.Changes where
import Types.KeySource
import Types.Key
import Utility.TList
import Control.Concurrent.STM
import Data.Time.Clock
{- An un-ordered pool of Changes that have been noticed and should be
- staged and committed. Changes will typically be in order, but ordering
- may be lost. In any case, order should not matter, as any given Change
- may later be reverted by a later Change (ie, a file is added and then
- deleted). Code that processes the changes needs to deal with such
- scenarios.
-}
type ChangePool = TList Change
newChangePool :: IO ChangePool
newChangePool = atomically newTList
data Change
= Change
{ changeTime :: UTCTime
, _changeFile :: FilePath
, changeInfo :: ChangeInfo
}
| PendingAddChange
{ changeTime ::UTCTime
, _changeFile :: FilePath
}
| InProcessAddChange
{ changeTime ::UTCTime
, keySource :: KeySource
}
deriving (Show)
data ChangeInfo = AddKeyChange Key | AddFileChange | LinkChange (Maybe Key) | RmChange
deriving (Show, Eq, Ord)
changeInfoKey :: ChangeInfo -> Maybe Key
changeInfoKey (AddKeyChange k) = Just k
changeInfoKey (LinkChange (Just k)) = Just k
changeInfoKey _ = Nothing
changeFile :: Change -> FilePath
changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f
changeFile (InProcessAddChange _ ks) = keyFilename ks
isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
isPendingAddChange _ = False
isInProcessAddChange :: Change -> Bool
isInProcessAddChange (InProcessAddChange {}) = True
isInProcessAddChange _ = False
retryChange :: Change -> Change
retryChange (InProcessAddChange time ks) =
PendingAddChange time (keyFilename ks)
retryChange c = c
finishedChange :: Change -> Key -> Change
finishedChange c@(InProcessAddChange { keySource = ks }) k = Change
{ changeTime = changeTime c
, _changeFile = keyFilename ks
, changeInfo = AddKeyChange k
}
finishedChange c _ = c

View file

@ -0,0 +1,19 @@
{- git-annex assistant commit tracking
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.Commits where
import Utility.TList
import Control.Concurrent.STM
type CommitChan = TList Commit
data Commit = Commit
newCommitChan :: IO CommitChan
newCommitChan = atomically newTList

View file

@ -0,0 +1,96 @@
{- git-annex assistant daemon status
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE RankNTypes, ImpredicativeTypes #-}
module Assistant.Types.DaemonStatus where
import Common.Annex
import Assistant.Pairing
import Utility.NotificationBroadcaster
import Logs.Transfer
import Assistant.Types.ThreadName
import Assistant.Types.NetMessager
import Assistant.Types.Alert
import Control.Concurrent.STM
import Control.Concurrent.Async
import Data.Time.Clock.POSIX
import qualified Data.Map as M
import qualified Data.Set as S
data DaemonStatus = DaemonStatus
-- All the named threads that comprise the daemon,
-- and actions to run to restart them.
{ startedThreads :: M.Map ThreadName (Async (), IO ())
-- False when the daemon is performing its startup scan
, scanComplete :: Bool
-- Time when a previous process of the daemon was running ok
, lastRunning :: Maybe POSIXTime
-- True when the sanity checker is running
, sanityCheckRunning :: Bool
-- Last time the sanity checker ran
, lastSanityCheck :: Maybe POSIXTime
-- True when a scan for file transfers is running
, transferScanRunning :: Bool
-- Currently running file content transfers
, currentTransfers :: TransferMap
-- Messages to display to the user.
, alertMap :: AlertMap
, lastAlertId :: AlertId
-- Ordered list of all remotes that can be synced with
, syncRemotes :: [Remote]
-- Ordered list of remotes to sync git with
, syncGitRemotes :: [Remote]
-- Ordered list of remotes to sync data with
, syncDataRemotes :: [Remote]
-- Are we syncing to any cloud remotes?
, syncingToCloudRemote :: Bool
-- List of uuids of remotes that we may have gotten out of sync with.
, desynced :: S.Set UUID
-- Pairing request that is in progress.
, pairingInProgress :: Maybe PairingInProgress
-- Broadcasts notifications about all changes to the DaemonStatus
, changeNotifier :: NotificationBroadcaster
-- Broadcasts notifications when queued or current transfers change.
, transferNotifier :: NotificationBroadcaster
-- Broadcasts notifications when there's a change to the alerts
, alertNotifier :: NotificationBroadcaster
-- Broadcasts notifications when the syncRemotes change
, syncRemotesNotifier :: NotificationBroadcaster
-- When the XMPP client is connected, this will contain the XMPP
-- address.
, xmppClientID :: Maybe ClientID
}
type TransferMap = M.Map Transfer TransferInfo
{- This TMVar is never left empty, so accessing it will never block. -}
type DaemonStatusHandle = TMVar DaemonStatus
newDaemonStatus :: IO DaemonStatus
newDaemonStatus = DaemonStatus
<$> pure M.empty
<*> pure False
<*> pure Nothing
<*> pure False
<*> pure Nothing
<*> pure False
<*> pure M.empty
<*> pure M.empty
<*> pure firstAlertId
<*> pure []
<*> pure []
<*> pure []
<*> pure False
<*> pure S.empty
<*> pure Nothing
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
<*> pure Nothing

View file

@ -0,0 +1,17 @@
{- named threads
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.NamedThread where
import Assistant.Monad
import Assistant.Types.ThreadName
{- Information about a named thread that can be run. -}
data NamedThread = NamedThread ThreadName (Assistant ())
namedThread :: String -> Assistant () -> NamedThread
namedThread = NamedThread . ThreadName

View file

@ -0,0 +1,155 @@
{- git-annex assistant out of band network messager types
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.NetMessager where
import Common.Annex
import Assistant.Pairing
import Git.Types
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.DList as D
import Control.Concurrent.STM
import Control.Concurrent.MSampleVar
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import Data.Text (Text)
{- Messages that can be sent out of band by a network messager. -}
data NetMessage
-- indicate that pushes have been made to the repos with these uuids
= NotifyPush [UUID]
-- requests other clients to inform us of their presence
| QueryPresence
-- notification about a stage in the pairing process,
-- involving a client, and a UUID.
| PairingNotification PairStage ClientID UUID
-- used for git push over the network messager
| Pushing ClientID PushStage
deriving (Show, Eq, Ord)
{- Something used to identify the client, or clients to send the message to. -}
type ClientID = Text
data PushStage
-- indicates that we have data to push over the out of band network
= CanPush UUID [Sha]
-- request that a git push be sent over the out of band network
| PushRequest UUID
-- indicates that a push is starting
| StartingPush UUID
-- a chunk of output of git receive-pack
| ReceivePackOutput SequenceNum ByteString
-- a chuck of output of git send-pack
| SendPackOutput SequenceNum ByteString
-- sent when git receive-pack exits, with its exit code
| ReceivePackDone ExitCode
deriving (Show, Eq, Ord)
{- A sequence number. Incremented by one per packet in a sequence,
- starting with 1 for the first packet. 0 means sequence numbers are
- not being used. -}
type SequenceNum = Int
{- NetMessages that are important (and small), and should be stored to be
- resent when new clients are seen. -}
isImportantNetMessage :: NetMessage -> Maybe ClientID
isImportantNetMessage (Pushing c (CanPush _ _)) = Just c
isImportantNetMessage (Pushing c (PushRequest _)) = Just c
isImportantNetMessage _ = Nothing
{- Checks if two important NetMessages are equivilant.
- That is to say, assuming they were sent to the same client,
- would it do the same thing for one as for the other? -}
equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool
equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True
equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True
equivilantImportantNetMessages _ _ = False
readdressNetMessage :: NetMessage -> ClientID -> NetMessage
readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid
readdressNetMessage (Pushing _ stage) c = Pushing c stage
readdressNetMessage m _ = m
{- Convert a NetMessage to something that can be logged. -}
logNetMessage :: NetMessage -> String
logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $
case stage of
ReceivePackOutput n _ -> ReceivePackOutput n elided
SendPackOutput n _ -> SendPackOutput n elided
s -> s
where
elided = B8.pack "<elided>"
logNetMessage (PairingNotification stage c uuid) =
show $ PairingNotification stage (logClientID c) uuid
logNetMessage m = show m
logClientID :: ClientID -> ClientID
logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
{- Things that initiate either side of a push, but do not actually send data. -}
isPushInitiation :: PushStage -> Bool
isPushInitiation (PushRequest _) = True
isPushInitiation (StartingPush _) = True
isPushInitiation _ = False
isPushNotice :: PushStage -> Bool
isPushNotice (CanPush _ _) = True
isPushNotice _ = False
data PushSide = SendPack | ReceivePack
deriving (Eq, Ord, Show)
pushDestinationSide :: PushStage -> PushSide
pushDestinationSide (CanPush _ _) = ReceivePack
pushDestinationSide (PushRequest _) = SendPack
pushDestinationSide (StartingPush _) = ReceivePack
pushDestinationSide (ReceivePackOutput _ _) = SendPack
pushDestinationSide (SendPackOutput _ _) = ReceivePack
pushDestinationSide (ReceivePackDone _) = SendPack
type SideMap a = PushSide -> a
mkSideMap :: STM a -> IO (SideMap a)
mkSideMap gen = do
(sp, rp) <- atomically $ (,) <$> gen <*> gen
return $ lookupside sp rp
where
lookupside sp _ SendPack = sp
lookupside _ rp ReceivePack = rp
getSide :: PushSide -> SideMap a -> a
getSide side m = m side
type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage))
data NetMessager = NetMessager
-- outgoing messages
{ netMessages :: TChan NetMessage
-- important messages for each client
, importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
-- important messages that are believed to have been sent to a client
, sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
-- write to this to restart the net messager
, netMessagerRestart :: MSampleVar ()
-- queue of incoming messages that request the initiation of pushes
, netMessagerPushInitiations :: SideMap (TMVar [NetMessage])
-- incoming messages containing data for a running
-- (or not yet started) push
, netMessagerInboxes :: SideMap Inboxes
}
newNetMessager :: IO NetMessager
newNetMessager = NetMessager
<$> atomically newTChan
<*> atomically (newTMVar M.empty)
<*> atomically (newTMVar M.empty)
<*> newEmptySV
<*> mkSideMap newEmptyTMVar
<*> mkSideMap (newTVar M.empty)

24
Assistant/Types/Pushes.hs Normal file
View file

@ -0,0 +1,24 @@
{- git-annex assistant push tracking
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.Pushes where
import Common.Annex
import Control.Concurrent.STM
import Data.Time.Clock
import qualified Data.Map as M
{- Track the most recent push failure for each remote. -}
type PushMap = M.Map Remote UTCTime
type FailedPushMap = TMVar PushMap
{- The TMVar starts empty, and is left empty when there are no
- failed pushes. This way we can block until there are some failed pushes.
-}
newFailedPushMap :: IO FailedPushMap
newFailedPushMap = atomically newEmptyTMVar

View file

@ -0,0 +1,25 @@
{- git-annex assistant remotes needing scanning
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.ScanRemotes where
import Common.Annex
import Control.Concurrent.STM
import qualified Data.Map as M
data ScanInfo = ScanInfo
{ scanPriority :: Float
, fullScan :: Bool
}
type ScanRemoteMap = TMVar (M.Map Remote ScanInfo)
{- The TMVar starts empty, and is left empty when there are no remotes
- to scan. -}
newScanRemoteMap :: IO ScanRemoteMap
newScanRemoteMap = atomically newEmptyTMVar

View file

@ -0,0 +1,14 @@
{- name of a thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.ThreadName where
newtype ThreadName = ThreadName String
deriving (Eq, Read, Show, Ord)
fromThreadName :: ThreadName -> String
fromThreadName (ThreadName n) = n

View file

@ -0,0 +1,38 @@
{- making the Annex monad available across threads
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.ThreadedMonad where
import Common.Annex
import qualified Annex
import Control.Concurrent
import Data.Tuple
{- The Annex state is stored in a MVar, so that threaded actions can access
- it. -}
type ThreadState = MVar Annex.AnnexState
{- Stores the Annex state in a MVar.
-
- Once the action is finished, retrieves the state from the MVar.
-}
withThreadState :: (ThreadState -> Annex a) -> Annex a
withThreadState a = do
state <- Annex.getState id
mvar <- liftIO $ newMVar state
r <- a mvar
newstate <- liftIO $ takeMVar mvar
Annex.changeState (const newstate)
return r
{- Runs an Annex action, using the state from the MVar.
-
- This serializes calls by threads; only one thread can run in Annex at a
- time. -}
runThreadState :: ThreadState -> Annex a -> IO a
runThreadState mvar a = modifyMVar mvar $ \state -> swap <$> Annex.run state a

View file

@ -0,0 +1,29 @@
{- git-annex assistant pending transfer queue
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.TransferQueue where
import Common.Annex
import Logs.Transfer
import Control.Concurrent.STM
import Utility.TList
data TransferQueue = TransferQueue
{ queuesize :: TVar Int
, queuelist :: TList (Transfer, TransferInfo)
, deferreddownloads :: TList (Key, AssociatedFile)
}
data Schedule = Next | Later
deriving (Eq)
newTransferQueue :: IO TransferQueue
newTransferQueue = atomically $ TransferQueue
<$> newTVar 0
<*> newTList
<*> newTList

View file

@ -0,0 +1,34 @@
{- git-annex assistant transfer slots
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE DeriveDataTypeable #-}
module Assistant.Types.TransferSlots where
import qualified Control.Exception as E
import qualified Control.Concurrent.MSemN as MSemN
import Data.Typeable
type TransferSlots = MSemN.MSemN Int
{- A special exception that can be thrown to pause or resume a transfer, while
- keeping its slot in use. -}
data TransferException = PauseTransfer | ResumeTransfer
deriving (Show, Eq, Typeable)
instance E.Exception TransferException
{- Number of concurrent transfers allowed to be run from the assistant.
-
- Transfers launched by other means, including by remote assistants,
- do not currently take up slots.
-}
numSlots :: Int
numSlots = 1
newTransferSlots :: IO TransferSlots
newTransferSlots = MSemN.new numSlots

View file

@ -0,0 +1,23 @@
{- A pool of "git-annex transferkeys" processes
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.TransferrerPool where
import Common.Annex
import Control.Concurrent.STM
type TransferrerPool = TChan Transferrer
data Transferrer = Transferrer
{ transferrerRead :: Handle
, transferrerWrite :: Handle
, transferrerHandle :: ProcessHandle
}
newTransferrerPool :: IO TransferrerPool
newTransferrerPool = newTChanIO

View file

@ -0,0 +1,26 @@
{- webapp url renderer access from the assistant
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Types.UrlRenderer (
UrlRenderer,
newUrlRenderer
) where
#ifdef WITH_WEBAPP
import Assistant.WebApp (UrlRenderer, newUrlRenderer)
#else
data UrlRenderer = UrlRenderer -- dummy type
newUrlRenderer :: IO UrlRenderer
newUrlRenderer = return UrlRenderer
#endif

73
Assistant/WebApp.hs Normal file
View file

@ -0,0 +1,73 @@
{- git-annex assistant webapp core
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp where
import Assistant.WebApp.Types
import Assistant.Common
import Utility.NotificationBroadcaster
import Utility.Yesod
import Data.Text (Text)
import Control.Concurrent
import qualified Network.Wai as W
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T
waitNotifier :: Assistant NotificationBroadcaster -> NotificationId -> Handler ()
waitNotifier getbroadcaster nid = liftAssistant $ do
b <- getbroadcaster
liftIO $ waitNotification $ notificationHandleFromId b nid
newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId
newNotifier getbroadcaster = liftAssistant $ do
b <- getbroadcaster
liftIO $ notificationHandleToId <$> newNotificationHandle True b
{- Adds the auth parameter as a hidden field on a form. Must be put into
- every form. -}
webAppFormAuthToken :: Widget
webAppFormAuthToken = do
webapp <- liftH getYesod
[whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
{- A button with an icon, and maybe label or tooltip, that can be
- clicked to perform some action.
- With javascript, clicking it POSTs the Route, and remains on the same
- page.
- With noscript, clicking it GETs the Route. -}
actionButton :: Route WebApp -> (Maybe String) -> (Maybe String) -> String -> String -> Widget
actionButton route label tooltip buttonclass iconclass = $(widgetFile "actionbutton")
type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text
type UrlRenderer = MVar (UrlRenderFunc)
newUrlRenderer :: IO UrlRenderer
newUrlRenderer = newEmptyMVar
setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO ()
setUrlRenderer = putMVar
inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod
{- Blocks until the webapp is running and has called setUrlRenderer. -}
renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text
renderUrl urlrenderer route params = do
r <- readMVar urlrenderer
return $ r route params
{- Redirects back to the referring page, or if there's none, DashboardR -}
redirectBack :: Handler ()
redirectBack = do
mr <- lookup "referer" . W.requestHeaders <$> waiRequest
case mr of
Nothing -> redirect DashboardR
Just r -> redirect $ T.pack $ S8.unpack r

View file

@ -0,0 +1,17 @@
{- git-annex assistant webapp, common imports
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Assistant.WebApp.Common (module X) where
import Assistant.Common as X
import Assistant.WebApp as X
import Assistant.WebApp.Page as X
import Assistant.WebApp.Form as X
import Assistant.WebApp.Types as X
import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
import Data.Text as X (Text)

View file

@ -0,0 +1,44 @@
{- git-annex assistant webapp configurators
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-}
module Assistant.WebApp.Configurators where
import Assistant.WebApp.Common
import Assistant.WebApp.RepoList
#ifdef WITH_XMPP
import Assistant.XMPP.Client
#endif
{- The main configuration screen. -}
getConfigurationR :: Handler Html
getConfigurationR = ifM (inFirstRun)
( redirect FirstRepositoryR
, page "Configuration" (Just Configuration) $ do
#ifdef WITH_XMPP
xmppconfigured <- liftAnnex $ isJust <$> getXMPPCreds
#else
let xmppconfigured = False
#endif
$(widgetFile "configurators/main")
)
getAddRepositoryR :: Handler Html
getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
let repolist = repoListDisplay mainRepoSelector
$(widgetFile "configurators/addrepository")
makeMiscRepositories :: Widget
makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
makeCloudRepositories :: Widget
makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
makeArchiveRepositories :: Widget
makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive")

View file

@ -0,0 +1,239 @@
{- git-annex assistant webapp configurators for Amazon AWS services
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.AWS where
import Assistant.WebApp.Common
import Assistant.MakeRemote
import Assistant.Sync
#ifdef WITH_S3
import qualified Remote.S3 as S3
#endif
import qualified Remote.Glacier as Glacier
import qualified Remote.Helper.AWS as AWS
import Logs.Remote
import qualified Remote
import qualified Types.Remote as Remote
import Types.Remote (RemoteConfig)
import Types.StandardGroups
import Logs.PreferredContent
import Creds
import qualified Data.Text as T
import qualified Data.Map as M
import Data.Char
awsConfigurator :: Widget -> Handler Html
awsConfigurator = page "Add an Amazon repository" (Just Configuration)
glacierConfigurator :: Widget -> Handler Html
glacierConfigurator a = do
ifM (liftIO $ inPath "glacier")
( awsConfigurator a
, awsConfigurator needglaciercli
)
where
needglaciercli = $(widgetFile "configurators/needglaciercli")
data StorageClass = StandardRedundancy | ReducedRedundancy
deriving (Eq, Enum, Bounded)
instance Show StorageClass where
show StandardRedundancy = "STANDARD"
show ReducedRedundancy = "REDUCED_REDUNDANCY"
data AWSInput = AWSInput
{ accessKeyID :: Text
, secretAccessKey :: Text
, datacenter :: Text
-- Only used for S3, not Glacier.
, storageClass :: StorageClass
, repoName :: Text
, enableEncryption :: EnableEncryption
}
data AWSCreds = AWSCreds Text Text
extractCreds :: AWSInput -> AWSCreds
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
s3InputAForm :: Maybe CredPair -> MkAForm AWSInput
s3InputAForm defcreds = AWSInput
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> defcreds)
<*> datacenterField AWS.S3
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
<*> areq textField "Repository name" (Just "S3")
<*> enableEncryptionField
where
storageclasses :: [(Text, StorageClass)]
storageclasses =
[ ("Standard redundancy", StandardRedundancy)
, ("Reduced redundancy (costs less)", ReducedRedundancy)
]
glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput
glacierInputAForm defcreds = AWSInput
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> defcreds)
<*> datacenterField AWS.Glacier
<*> pure StandardRedundancy
<*> areq textField "Repository name" (Just "glacier")
<*> enableEncryptionField
awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds
awsCredsAForm defcreds = AWSCreds
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> secretAccessKeyField (T.pack . snd <$> defcreds)
accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text
accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def
accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
accessKeyIDFieldWithHelp def = accessKeyIDField help def
where
help = [whamlet|
<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
Get Amazon access keys
|]
secretAccessKeyField :: Maybe Text -> MkAForm Text
secretAccessKeyField def = areq passwordField "Secret Access Key" def
datacenterField :: AWS.Service -> MkAForm Text
datacenterField service = areq (selectFieldList list) "Datacenter" defregion
where
list = M.toList $ AWS.regionMap service
defregion = Just $ AWS.defaultRegion service
getAddS3R :: Handler Html
getAddS3R = postAddS3R
postAddS3R :: Handler Html
#ifdef WITH_S3
postAddS3R = awsConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ s3InputAForm defcreds
case result of
FormSuccess input -> liftH $ do
let name = T.unpack $ repoName input
makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $ M.fromList
[ configureEncryption $ enableEncryption input
, ("type", "S3")
, ("datacenter", T.unpack $ datacenter input)
, ("storageclass", show $ storageClass input)
]
_ -> $(widgetFile "configurators/adds3")
where
setgroup r = liftAnnex $
setStandardGroup (Remote.uuid r) TransferGroup
#else
postAddS3R = error "S3 not supported by this build"
#endif
getAddGlacierR :: Handler Html
getAddGlacierR = postAddGlacierR
postAddGlacierR :: Handler Html
#ifdef WITH_S3
postAddGlacierR = glacierConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ glacierInputAForm defcreds
case result of
FormSuccess input -> liftH $ do
let name = T.unpack $ repoName input
makeAWSRemote initSpecialRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
[ configureEncryption $ enableEncryption input
, ("type", "glacier")
, ("datacenter", T.unpack $ datacenter input)
]
_ -> $(widgetFile "configurators/addglacier")
where
setgroup r = liftAnnex $
setStandardGroup (Remote.uuid r) SmallArchiveGroup
#else
postAddGlacierR = error "S3 not supported by this build"
#endif
getEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3
getEnableS3R uuid = do
m <- liftAnnex readRemoteLog
if isIARemoteConfig $ fromJust $ M.lookup uuid m
then redirect $ EnableIAR uuid
else postEnableS3R uuid
#else
getEnableS3R = postEnableS3R
#endif
postEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
#else
postEnableS3R _ = error "S3 not supported by this build"
#endif
getEnableGlacierR :: UUID -> Handler Html
getEnableGlacierR = postEnableGlacierR
postEnableGlacierR :: UUID -> Handler Html
postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
enableAWSRemote :: RemoteType -> UUID -> Widget
#ifdef WITH_S3
enableAWSRemote remotetype uuid = do
defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ awsCredsAForm defcreds
case result of
FormSuccess creds -> liftH $ do
m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m
makeAWSRemote enableSpecialRemote remotetype creds name (const noop) M.empty
_ -> do
description <- liftAnnex $
T.pack <$> Remote.prettyUUID uuid
$(widgetFile "configurators/enableaws")
#else
enableAWSRemote _ _ = error "S3 not supported by this build"
#endif
makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
makeAWSRemote maker remotetype (AWSCreds ak sk) name setup config = do
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
r <- liftAnnex $ addRemote $ do
maker hostname remotetype config
setup r
liftAssistant $ syncRemote r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
where
{- AWS services use the remote name as the basis for a host
- name, so filter it to contain valid characters. -}
hostname = case filter isAlphaNum name of
[] -> "aws"
n -> n
getRepoInfo :: RemoteConfig -> Widget
getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
where
bucket = fromMaybe "" $ M.lookup "bucket" c
#ifdef WITH_S3
isIARemoteConfig :: RemoteConfig -> Bool
isIARemoteConfig = S3.isIAHost . fromMaybe "" . M.lookup "host"
previouslyUsedAWSCreds :: Annex (Maybe CredPair)
previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote]
where
gettype t = previouslyUsedCredPair AWS.creds t $
not . isIARemoteConfig . Remote.config
#endif

View file

@ -0,0 +1,126 @@
{- git-annex assistant webapp repository deletion
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Delete where
import Assistant.WebApp.Common
import Assistant.DeleteRemote
import Assistant.WebApp.Utility
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import qualified Remote
import qualified Git
import Config.Files
import Utility.FileMode
import Logs.Trust
import Logs.Remote
import Logs.PreferredContent
import Types.StandardGroups
import System.IO.HVFS (SystemFS(..))
import qualified Data.Text as T
import qualified Data.Map as M
import System.Path
notCurrentRepo :: UUID -> Handler Html -> Handler Html
notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid)
where
go Nothing = redirect DeleteCurrentRepositoryR
go (Just _) = a
getDisableRepositoryR :: UUID -> Handler Html
getDisableRepositoryR uuid = notCurrentRepo uuid $ do
void $ liftAssistant $ disableRemote uuid
redirect DashboardR
getDeleteRepositoryR :: UUID -> Handler Html
getDeleteRepositoryR uuid = notCurrentRepo uuid $
deletionPage $ do
reponame <- liftAnnex $ Remote.prettyUUID uuid
$(widgetFile "configurators/delete/start")
getStartDeleteRepositoryR :: UUID -> Handler Html
getStartDeleteRepositoryR uuid = do
remote <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
liftAnnex $ do
trustSet uuid UnTrusted
setStandardGroup uuid UnwantedGroup
liftAssistant $ addScanRemotes True [remote]
redirect DashboardR
getFinishDeleteRepositoryR :: UUID -> Handler Html
getFinishDeleteRepositoryR uuid = deletionPage $ do
void $ liftAssistant $ removeRemote uuid
reponame <- liftAnnex $ Remote.prettyUUID uuid
{- If it's not listed in the remote log, it must be a git repo. -}
gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
$(widgetFile "configurators/delete/finished")
getDeleteCurrentRepositoryR :: Handler Html
getDeleteCurrentRepositoryR = deleteCurrentRepository
postDeleteCurrentRepositoryR :: Handler Html
postDeleteCurrentRepositoryR = deleteCurrentRepository
deleteCurrentRepository :: Handler Html
deleteCurrentRepository = dangerPage $ do
reldir <- fromJust . relDir <$> liftH getYesod
havegitremotes <- haveremotes syncGitRemotes
havedataremotes <- haveremotes syncDataRemotes
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sanityVerifierAForm $
SanityVerifier magicphrase
case result of
FormSuccess _ -> liftH $ do
dir <- liftAnnex $ fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir
{- Disable syncing to this repository, and all
- remotes. This stops all transfers, and all
- file watching. -}
changeSyncable Nothing False
rs <- liftAssistant $ syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs
{- Make all directories writable, so all annexed
- content can be deleted. -}
liftIO $ do
recurseDir SystemFS dir >>=
filterM doesDirectoryExist >>=
mapM_ allowWrite
removeDirectoryRecursive dir
redirect ShutdownConfirmedR
_ -> $(widgetFile "configurators/delete/currentrepository")
where
haveremotes selector = not . null . selector
<$> liftAssistant getDaemonStatus
data SanityVerifier = SanityVerifier T.Text
deriving (Eq)
sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier
sanityVerifierAForm template = SanityVerifier
<$> areq checksanity "Confirm deletion?" Nothing
where
checksanity = checkBool (\input -> SanityVerifier input == template)
insane textField
insane = "Maybe this is not a good idea..." :: Text
deletionPage :: Widget -> Handler Html
deletionPage = page "Delete repository" (Just Configuration)
dangerPage :: Widget -> Handler Html
dangerPage = page "Danger danger danger" (Just Configuration)
magicphrase :: Text
magicphrase = "Yes, please do as I say!"

View file

@ -0,0 +1,223 @@
{- git-annex assistant webapp configurator for editing existing repos
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Edit where
import Assistant.WebApp.Common
import Assistant.WebApp.Utility
import Assistant.DaemonStatus
import Assistant.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
import Assistant.ScanRemotes
import qualified Assistant.WebApp.Configurators.AWS as AWS
import qualified Assistant.WebApp.Configurators.IA as IA
#ifdef WITH_S3
import qualified Remote.S3 as S3
#endif
import qualified Remote
import qualified Types.Remote as Remote
import qualified Remote.List as Remote
import Logs.UUID
import Logs.Group
import Logs.PreferredContent
import Logs.Remote
import Types.StandardGroups
import qualified Git
import qualified Git.Command
import qualified Git.Config
import qualified Annex
import Git.Remote
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Set as S
data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
deriving (Show, Eq)
data RepoConfig = RepoConfig
{ repoName :: Text
, repoDescription :: Maybe Text
, repoGroup :: RepoGroup
, repoAssociatedDirectory :: Maybe Text
, repoSyncable :: Bool
}
deriving (Show)
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
getRepoConfig uuid mremote = do
groups <- lookupGroups uuid
remoteconfig <- M.lookup uuid <$> readRemoteLog
let (repogroup, associateddirectory) = case getStandardGroup groups of
Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)
description <- maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap
syncable <- case mremote of
Just r -> return $ remoteAnnexSync $ Remote.gitconfig r
Nothing -> annexAutoCommit <$> Annex.getGitConfig
return $ RepoConfig
(T.pack $ maybe "here" Remote.name mremote)
description
repogroup
(T.pack <$> associateddirectory)
syncable
setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
setRepoConfig uuid mremote oldc newc = do
when descriptionChanged $ liftAnnex $ do
maybe noop (describeUUID uuid . T.unpack) (repoDescription newc)
void uuidMapLoad
when nameChanged $ do
liftAnnex $ do
name <- fromRepo $ uniqueRemoteName (legalName newc) 0
{- git remote rename expects there to be a
- remote.<name>.fetch, and exits nonzero if
- there's not. Special remotes don't normally
- have that, and don't use it. Temporarily add
- it if it's missing. -}
let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch"
needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch)
when needfetch $
inRepo $ Git.Command.run
[Param "config", Param remotefetch, Param ""]
inRepo $ Git.Command.run
[ Param "remote"
, Param "rename"
, Param $ T.unpack $ repoName oldc
, Param name
]
void $ Remote.remoteListRefresh
liftAssistant updateSyncRemotes
when associatedDirectoryChanged $ case repoAssociatedDirectory newc of
Nothing -> noop
Just t
| T.null t -> noop
| otherwise -> liftAnnex $ do
let dir = takeBaseName $ T.unpack t
m <- readRemoteLog
case M.lookup uuid m of
Nothing -> noop
Just remoteconfig -> configSet uuid $
M.insert "preferreddir" dir remoteconfig
when groupChanged $ do
liftAnnex $ case repoGroup newc of
RepoGroupStandard g -> setStandardGroup uuid g
RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
{- Enabling syncing will cause a scan,
- so avoid queueing a duplicate scan. -}
when (repoSyncable newc && not syncableChanged) $ liftAssistant $
case mremote of
Just remote -> do
addScanRemotes True [remote]
Nothing -> do
addScanRemotes True
=<< syncDataRemotes <$> getDaemonStatus
when syncableChanged $
changeSyncable mremote (repoSyncable newc)
where
syncableChanged = repoSyncable oldc /= repoSyncable newc
associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc
groupChanged = repoGroup oldc /= repoGroup newc
nameChanged = isJust mremote && legalName oldc /= legalName newc
descriptionChanged = repoDescription oldc /= repoDescription newc
legalName = makeLegalName . T.unpack . repoName
editRepositoryAForm :: Bool -> RepoConfig -> MkAForm RepoConfig
editRepositoryAForm ishere def = RepoConfig
<$> areq (if ishere then readonlyTextField else textField)
"Name" (Just $ repoName def)
<*> aopt textField "Description" (Just $ repoDescription def)
<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
<*> associateddirectory
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
where
groups = customgroups ++ standardgroups
standardgroups :: [(Text, RepoGroup)]
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
[minBound :: StandardGroup .. maxBound :: StandardGroup]
customgroups :: [(Text, RepoGroup)]
customgroups = case repoGroup def of
RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
_ -> []
help = [whamlet|<a href="@{RepoGroupR}">What's this?</a>|]
associateddirectory = case repoAssociatedDirectory def of
Nothing -> aopt hiddenField "" Nothing
Just d -> aopt textField "Associated directory" (Just $ Just d)
getEditRepositoryR :: UUID -> Handler Html
getEditRepositoryR = postEditRepositoryR
postEditRepositoryR :: UUID -> Handler Html
postEditRepositoryR = editForm False
getEditNewRepositoryR :: UUID -> Handler Html
getEditNewRepositoryR = postEditNewRepositoryR
postEditNewRepositoryR :: UUID -> Handler Html
postEditNewRepositoryR = editForm True
getEditNewCloudRepositoryR :: UUID -> Handler Html
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
postEditNewCloudRepositoryR :: UUID -> Handler Html
postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
editForm :: Bool -> UUID -> Handler Html
editForm new uuid = page "Edit repository" (Just Configuration) $ do
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
curr <- liftAnnex $ getRepoConfig uuid mremote
liftAnnex $ checkAssociatedDirectory curr mremote
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ editRepositoryAForm (isNothing mremote) curr
case result of
FormSuccess input -> liftH $ do
setRepoConfig uuid mremote curr input
liftAnnex $ checkAssociatedDirectory input mremote
redirect DashboardR
_ -> do
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
repoInfo <- getRepoInfo mremote . M.lookup uuid
<$> liftAnnex readRemoteLog
$(widgetFile "configurators/editrepository")
{- Makes any directory associated with the repository. -}
checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex ()
checkAssociatedDirectory _ Nothing = noop
checkAssociatedDirectory cfg (Just r) = do
repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog
case repoGroup cfg of
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
Just d -> inRepo $ \g ->
createDirectoryIfMissing True $
Git.repoPath g </> d
Nothing -> noop
_ -> noop
getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
getRepoInfo (Just r) (Just c) = case M.lookup "type" c of
Just "S3"
#ifdef WITH_S3
| S3.isIA c -> IA.getRepoInfo c
#endif
| otherwise -> AWS.getRepoInfo c
Just t
| t /= "git" -> [whamlet|#{t} remote|]
_ -> getGitRepoInfo $ Remote.repo r
getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
getRepoInfo _ _ = [whamlet|git repository|]
getGitRepoInfo :: Git.Repo -> Widget
getGitRepoInfo r = do
let loc = Git.repoLocation r
[whamlet|git repository located at <tt>#{loc}</tt>|]

View file

@ -0,0 +1,211 @@
{- git-annex assistant webapp configurators for Internet Archive
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.IA where
import Assistant.WebApp.Common
import qualified Assistant.WebApp.Configurators.AWS as AWS
#ifdef WITH_S3
import qualified Remote.S3 as S3
import qualified Remote.Helper.AWS as AWS
import Assistant.MakeRemote
#endif
import qualified Remote
import qualified Types.Remote as Remote
import Types.StandardGroups
import Types.Remote (RemoteConfig)
import Logs.PreferredContent
import Logs.Remote
import qualified Utility.Url as Url
import Creds
import qualified Data.Text as T
import qualified Data.Map as M
import Data.Char
import Network.URI
iaConfigurator :: Widget -> Handler Html
iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)
data IAInput = IAInput
{ accessKeyID :: Text
, secretAccessKey :: Text
, mediaType :: MediaType
, itemName :: Text
}
extractCreds :: IAInput -> AWS.AWSCreds
extractCreds i = AWS.AWSCreds (accessKeyID i) (secretAccessKey i)
{- IA defines only a few media types currently, or the media type
- may be omitted
-
- We add a few other common types, mapped to what we've been told
- is the closest match.
-}
data MediaType = MediaImages | MediaAudio | MediaVideo | MediaText | MediaSoftware | MediaOmitted
deriving (Eq, Ord, Enum, Bounded)
{- Format a MediaType for entry into the IA metadata -}
formatMediaType :: MediaType -> String
formatMediaType MediaText = "texts"
formatMediaType MediaImages = "image"
formatMediaType MediaSoftware = "software"
formatMediaType MediaVideo = "movies"
formatMediaType MediaAudio = "audio"
formatMediaType MediaOmitted = ""
{- A default collection to use for each Mediatype. -}
collectionMediaType :: MediaType -> Maybe String
collectionMediaType MediaText = Just "opensource"
collectionMediaType MediaImages = Just "opensource" -- not ideal
collectionMediaType MediaSoftware = Just "opensource" -- not ideal
collectionMediaType MediaVideo = Just "opensource_movies"
collectionMediaType MediaAudio = Just "opensource_audio"
collectionMediaType MediaOmitted = Just "opensource"
{- Format a MediaType for user display. -}
showMediaType :: MediaType -> String
showMediaType MediaText = "texts"
showMediaType MediaImages = "photos & images"
showMediaType MediaSoftware = "software"
showMediaType MediaVideo = "videos & movies"
showMediaType MediaAudio = "audio & music"
showMediaType MediaOmitted = "other"
iaInputAForm :: Maybe CredPair -> MkAForm IAInput
iaInputAForm defcreds = IAInput
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
<*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted)
<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing
where
mediatypes :: [(Text, MediaType)]
mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]
itemNameHelp :: Widget
itemNameHelp = [whamlet|
<div>
Each item stored in the Internet Archive must have a unique name.
<div>
Once you create the item, a special directory will appear #
with a name matching the item name. Files you put in that directory #
will be uploaded to your Internet Archive item.
|]
iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds
iaCredsAForm defcreds = AWS.AWSCreds
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
#ifdef WITH_S3
previouslyUsedIACreds :: Annex (Maybe CredPair)
previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
AWS.isIARemoteConfig . Remote.config
#endif
accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
where
help = [whamlet|
<a href="http://archive.org/account/s3.php">
Get Internet Archive access keys
|]
getAddIAR :: Handler Html
getAddIAR = postAddIAR
postAddIAR :: Handler Html
#ifdef WITH_S3
postAddIAR = iaConfigurator $ do
defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ iaInputAForm defcreds
case result of
FormSuccess input -> liftH $ do
let name = escapeBucket $ T.unpack $ itemName input
AWS.makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $
M.fromList $ catMaybes
[ Just $ configureEncryption NoEncryption
, Just ("type", "S3")
, Just ("host", S3.iaHost)
, Just ("bucket", escapeHeader name)
, Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input)
, if mediaType input == MediaOmitted
then Nothing
else Just ("x-archive-mediatype", formatMediaType $ mediaType input)
, (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input)
-- Make item show up ASAP.
, Just ("x-archive-interactive-priority", "1")
, Just ("preferreddir", name)
]
_ -> $(widgetFile "configurators/addia")
where
setgroup r = liftAnnex $
setStandardGroup (Remote.uuid r) PublicGroup
#else
postAddIAR = error "S3 not supported by this build"
#endif
getEnableIAR :: UUID -> Handler Html
getEnableIAR = postEnableIAR
postEnableIAR :: UUID -> Handler Html
#ifdef WITH_S3
postEnableIAR = iaConfigurator . enableIARemote
#else
postEnableIAR _ = error "S3 not supported by this build"
#endif
#ifdef WITH_S3
enableIARemote :: UUID -> Widget
enableIARemote uuid = do
defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ iaCredsAForm defcreds
case result of
FormSuccess creds -> liftH $ do
m <- liftAnnex readRemoteLog
let name = fromJust $ M.lookup "name" $
fromJust $ M.lookup uuid m
AWS.makeAWSRemote enableSpecialRemote S3.remote creds name (const noop) M.empty
_ -> do
description <- liftAnnex $
T.pack <$> Remote.prettyUUID uuid
$(widgetFile "configurators/enableia")
#endif
{- Convert a description into a bucket item name, which will also be
- used as the repository name, and the preferreddir.
- IA seems to need only lower case, and no spaces. -}
escapeBucket :: String -> String
escapeBucket = map toLower . replace " " "-"
{- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -}
escapeHeader :: String -> String
escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
getRepoInfo :: RemoteConfig -> Widget
getRepoInfo c = do
exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url []
[whamlet|
<a href="#{url}">
Internet Archive item
$if (not exists)
<p>
The page will only be available once some files #
have been uploaded, and the Internet Archive has processed them.
|]
where
bucket = fromMaybe "" $ M.lookup "bucket" c
#ifdef WITH_S3
url = S3.iaItemUrl bucket
#else
url = ""
#endif

View file

@ -0,0 +1,412 @@
{- git-annex assistant webapp configurators for making local repositories
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings, RankNTypes, KindSignatures, TypeFamilies #-}
module Assistant.WebApp.Configurators.Local where
import Assistant.WebApp.Common
import Assistant.WebApp.OtherRepos
import Assistant.MakeRemote
import Assistant.Sync
import Init
import qualified Git
import qualified Git.Construct
import qualified Git.Config
import qualified Git.Command
import qualified Annex
import Config.Files
import Utility.FreeDesktop
#ifdef WITH_CLIBS
import Utility.Mounts
#endif
import Utility.DiskFree
import Utility.DataUnits
import Utility.Network
import Remote (prettyUUID)
import Annex.UUID
import Types.StandardGroups
import Logs.PreferredContent
import Logs.UUID
import Utility.UserInfo
import Config
import qualified Data.Text as T
import qualified Data.Map as M
import Data.Char
import qualified Text.Hamlet as Hamlet
data RepositoryPath = RepositoryPath Text
deriving Show
{- Custom field display for a RepositoryPath, with an icon etc.
-
- Validates that the path entered is not empty, and is a safe value
- to use as a repository. -}
#if MIN_VERSION_yesod(1,2,0)
repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
#else
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
#endif
repositoryPathField autofocus = Field
#if ! MIN_VERSION_yesod_form(1,2,0)
{ fieldParse = parse
#else
{ fieldParse = \l _ -> parse l
, fieldEnctype = UrlEncoded
#endif
, fieldView = view
}
where
view idAttr nameAttr attrs val isReq =
[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
parse [path]
| T.null path = nopath
| otherwise = liftIO $ checkRepositoryPath path
parse [] = return $ Right Nothing
parse _ = nopath
nopath = return $ Left "Enter a location for the repository"
{- As well as checking the path for a lot of silly things, tilde is
- expanded in the returned path. -}
checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
checkRepositoryPath p = do
home <- myHomeDir
let basepath = expandTilde home $ T.unpack p
path <- absPath basepath
let parent = parentDir path
problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
, (doesFileExist path, "A file already exists with that name.")
, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
, (not <$> canWrite path, "Cannot write a repository there.")
]
return $
case headMaybe problems of
Nothing -> Right $ Just $ T.pack basepath
Just prob -> Left prob
where
runcheck (chk, msg) = ifM (chk) ( return $ Just msg, return Nothing )
expandTilde home ('~':'/':path) = home </> path
expandTilde _ path = path
{- On first run, if run in the home directory, default to putting it in
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
-
- If run in another directory, that the user can write to,
- the user probably wants to put it there. Unless that directory
- contains a git-annex file, in which case the user has probably
- browsed to a directory with git-annex and run it from there. -}
defaultRepositoryPath :: Bool -> IO FilePath
defaultRepositoryPath firstrun = do
cwd <- liftIO $ getCurrentDirectory
home <- myHomeDir
if home == cwd && firstrun
then inhome
else ifM (legit cwd <&&> canWrite cwd)
( return cwd
, inhome
)
where
inhome = do
desktop <- userDesktopDir
ifM (doesDirectoryExist desktop)
( relHome $ desktop </> gitAnnexAssistantDefaultDir
, return $ "~" </> gitAnnexAssistantDefaultDir
)
legit d = not <$> doesFileExist (d </> "git-annex")
newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) ""
(Just $ T.pack $ addTrailingPathSeparator defpath)
let (err, errmsg) = case pathRes of
FormMissing -> (False, "")
FormFailure l -> (True, concat $ map T.unpack l)
FormSuccess _ -> (False, "")
let form = do
webAppFormAuthToken
$(widgetFile "configurators/newrepository/form")
return (RepositoryPath <$> pathRes, form)
{- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler Html
getFirstRepositoryR = postFirstRepositoryR
postFirstRepositoryR :: Handler Html
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
#ifdef __ANDROID__
androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
let path = "/sdcard/annex"
#else
let androidspecial = False
path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun
#endif
((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm path
case res of
FormSuccess (RepositoryPath p) -> liftH $
startFullAssistant (T.unpack p) ClientGroup Nothing
_ -> $(widgetFile "configurators/newrepository/first")
getAndroidCameraRepositoryR :: Handler ()
getAndroidCameraRepositoryR =
startFullAssistant "/sdcard/DCIM" SourceGroup $ Just addignore
where
addignore = do
liftIO $ unlessM (doesFileExist ".gitignore") $
writeFile ".gitignore" ".thumbnails/*"
void $ inRepo $
Git.Command.runBool [Param "add", File ".gitignore"]
{- Adding a new local repository, which may be entirely separate, or may
- be connected to the current repository. -}
getNewRepositoryR :: Handler Html
getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
home <- liftIO myHomeDir
((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home
case res of
FormSuccess (RepositoryPath p) -> do
let path = T.unpack p
isnew <- liftIO $ makeRepo path False
u <- liftIO $ initRepo isnew True path Nothing
liftH $ liftAnnexOr () $ setStandardGroup u ClientGroup
liftIO $ addAutoStartFile path
liftIO $ startAssistant path
askcombine u path
_ -> $(widgetFile "configurators/newrepository")
where
askcombine newrepouuid newrepopath = do
newrepo <- liftIO $ relHome newrepopath
mainrepo <- fromJust . relDir <$> liftH getYesod
$(widgetFile "configurators/newrepository/combine")
getCombineRepositoryR :: FilePathAndUUID -> Handler Html
getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
r <- combineRepos newrepopath remotename
liftAssistant $ syncRemote r
redirect $ EditRepositoryR newrepouuid
where
remotename = takeFileName newrepopath
selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
selectDriveForm drives = renderBootstrap $ RemovableDrive
<$> pure Nothing
<*> areq (selectFieldList pairs) "Select drive:" Nothing
<*> areq textField "Use this directory on the drive:"
(Just $ T.pack gitAnnexAssistantDefaultDir)
where
pairs = zip (map describe drives) (map mountPoint drives)
describe drive = case diskFree drive of
Nothing -> mountPoint drive
Just free ->
let sz = roughSize storageUnits True free
in T.unwords
[ mountPoint drive
, T.concat ["(", T.pack sz]
, "free)"
]
removableDriveRepository :: RemovableDrive -> FilePath
removableDriveRepository drive =
T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
{- Adding a removable drive. -}
getAddDriveR :: Handler Html
getAddDriveR = postAddDriveR
postAddDriveR :: Handler Html
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO $ driveList
writabledrives <- liftIO $
filterM (canWrite . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- liftH $ runFormPost $
selectDriveForm (sort writabledrives)
case res of
FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive
_ -> $(widgetFile "configurators/adddrive")
{- The repo may already exist, when adding removable media
- that has already been used elsewhere. If so, check
- the UUID of the repo and see if it's one we know. If not,
- the user must confirm the repository merge. -}
getConfirmAddDriveR :: RemovableDrive -> Handler Html
getConfirmAddDriveR drive = do
ifM (needconfirm)
( page "Combine repositories?" (Just Configuration) $
$(widgetFile "configurators/adddrive/confirm")
, do
getFinishAddDriveR drive
)
where
dir = removableDriveRepository drive
needconfirm = ifM (liftIO $ doesDirectoryExist dir)
( liftAnnex $ do
mu <- liftIO $ catchMaybeIO $
inDir dir $ getUUID
case mu of
Nothing -> return False
Just driveuuid -> not .
M.member driveuuid <$> uuidMap
, return False
)
cloneModal :: Widget
cloneModal = $(widgetFile "configurators/adddrive/clonemodal")
getFinishAddDriveR :: RemovableDrive -> Handler Html
getFinishAddDriveR drive = make >>= redirect . EditNewRepositoryR
where
make = do
liftIO $ createDirectoryIfMissing True dir
isnew <- liftIO $ makeRepo dir True
u <- liftIO $ initRepo isnew False dir $ Just remotename
{- Removable drives are not reliable media, so enable fsync. -}
liftIO $ inDir dir $
setConfig (ConfigKey "core.fsyncobjectfiles")
(Git.Config.boolConfig True)
r <- combineRepos dir remotename
liftAnnex $ setStandardGroup u TransferGroup
liftAssistant $ syncRemote r
return u
mountpoint = T.unpack (mountPoint drive)
dir = removableDriveRepository drive
remotename = takeFileName mountpoint
{- Each repository is made a remote of the other.
- Next call syncRemote to get them in sync. -}
combineRepos :: FilePath -> String -> Handler Remote
combineRepos dir name = liftAnnex $ do
hostname <- maybe "host" id <$> liftIO getHostname
hostlocation <- fromRepo Git.repoLocation
liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
addRemote $ makeGitRemote name dir
getEnableDirectoryR :: UUID -> Handler Html
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
description <- liftAnnex $ T.pack <$> prettyUUID uuid
$(widgetFile "configurators/enabledirectory")
{- List of removable drives. -}
driveList :: IO [RemovableDrive]
#ifdef WITH_CLIBS
driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
where
gen dir = RemovableDrive
<$> getDiskFree dir
<*> pure (T.pack dir)
<*> pure (T.pack gitAnnexAssistantDefaultDir)
-- filter out some things that are surely not removable drives
sane Mntent { mnt_dir = dir, mnt_fsname = dev }
{- We want real disks like /dev/foo, not
- dummy mount points like proc or tmpfs or
- gvfs-fuse-daemon. -}
| not ('/' `elem` dev) = False
{- Just in case: These mount points are surely not
- removable disks. -}
| dir == "/" = False
| dir == "/tmp" = False
| dir == "/run/shm" = False
| dir == "/run/lock" = False
#ifdef __ANDROID__
| dir == "/mnt/sdcard" = False
| dir == "/sdcard" = False
#endif
| otherwise = True
#else
driveList = return []
#endif
{- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the
- url to the new webapp. -}
startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler ()
startFullAssistant path repogroup setup = do
webapp <- getYesod
url <- liftIO $ do
isnew <- makeRepo path False
u <- initRepo isnew True path Nothing
inDir path $ do
setStandardGroup u repogroup
maybe noop id setup
addAutoStartFile path
setCurrentDirectory path
fromJust $ postFirstRun webapp
redirect $ T.pack url
{- Makes a new git repository. Or, if a git repository already
- exists, returns False. -}
makeRepo :: FilePath -> Bool -> IO Bool
makeRepo path bare = ifM alreadyexists
( return False
, do
(transcript, ok) <-
processTranscript "git" (toCommand params) Nothing
unless ok $
error $ "git init failed!\nOutput:\n" ++ transcript
return True
)
where
alreadyexists = isJust <$>
catchDefaultIO Nothing (Git.Construct.checkForRepo path)
baseparams = [Param "init", Param "--quiet"]
params
| bare = baseparams ++ [Param "--bare", File path]
| otherwise = baseparams ++ [File path]
{- Runs an action in the git-annex 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 -> IO UUID
initRepo True primary_assistant_repo dir desc = inDir dir $ do
initRepo' desc
{- 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.Command.runBool
[ Param "commit"
, 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. -}
initRepo False _ dir desc = inDir dir $ do
initRepo' desc
getUUID
initRepo' :: Maybe String -> Annex ()
initRepo' desc = do
unlessM isInitialized $
initialize desc
{- Checks if the user can write to a directory.
-
- The directory may be in the process of being created; if so
- the parent directory is checked instead. -}
canWrite :: FilePath -> IO Bool
canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir)
(return dir, return $ parentDir dir)
catchBoolIO $ fileAccess tocheck False True False

View file

@ -0,0 +1,327 @@
{- git-annex assistant webapp configurator for pairing
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.WebApp.Configurators.Pairing where
import Assistant.Pairing
import Assistant.WebApp.Common
import Assistant.WebApp.Configurators
import Assistant.Types.Buddies
import Annex.UUID
#ifdef WITH_PAIRING
import Assistant.Pairing.Network
import Assistant.Pairing.MakeRemote
import Assistant.Ssh
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable
import Utility.Network
#endif
#ifdef WITH_XMPP
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.XMPP.Git
import Network.Protocol.XMPP
import Assistant.Types.NetMessager
import Assistant.NetMessager
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators.XMPP
#endif
import Utility.UserInfo
import Git
import qualified Data.Text as T
#ifdef WITH_PAIRING
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as B
import Data.Char
import qualified Control.Exception as E
import Control.Concurrent
#endif
#ifdef WITH_XMPP
import qualified Data.Set as S
#endif
getStartXMPPPairFriendR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
( do
{- Ask buddies to send presence info, to get
- the buddy list populated. -}
liftAssistant $ sendNetMessage QueryPresence
pairPage $
$(widgetFile "configurators/pairing/xmpp/friend/prompt")
, do
-- go get XMPP configured, then come back
redirect XMPPConfigForPairFriendR
)
#else
getStartXMPPPairFriendR = noXMPPPairing
noXMPPPairing :: Handler Html
noXMPPPairing = noPairing "XMPP"
#endif
getStartXMPPPairSelfR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
where
go Nothing = do
-- go get XMPP configured, then come back
redirect XMPPConfigForPairSelfR
go (Just creds) = do
{- Ask buddies to send presence info, to get
- the buddy list populated. -}
liftAssistant $ sendNetMessage QueryPresence
let account = xmppJID creds
pairPage $
$(widgetFile "configurators/pairing/xmpp/self/prompt")
#else
getStartXMPPPairSelfR = noXMPPPairing
#endif
getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
getRunningXMPPPairSelfR :: Handler Html
getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
{- Sends a XMPP pair request, to a buddy or to self. -}
sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
#ifdef WITH_XMPP
sendXMPPPairRequest mbid = do
bid <- maybe getself return mbid
buddy <- liftAssistant $ getBuddy bid <<~ buddyList
go $ S.toList . buddyAssistants <$> buddy
where
go (Just (clients@((Client exemplar):_))) = do
u <- liftAnnex getUUID
liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $
PairingNotification PairReq (formatJID c) u
xmppPairStatus True $
if selfpair then Nothing else Just exemplar
go _
{- Nudge the user to turn on their other device. -}
| selfpair = do
liftAssistant $ sendNetMessage QueryPresence
pairPage $
$(widgetFile "configurators/pairing/xmpp/self/retry")
{- Buddy could have logged out, etc.
- Go back to buddy list. -}
| otherwise = redirect StartXMPPPairFriendR
selfpair = isNothing mbid
getself = maybe (error "XMPP not configured")
(return . BuddyKey . xmppJID)
=<< liftAnnex getXMPPCreds
#else
sendXMPPPairRequest _ = noXMPPPairing
#endif
{- Starts local pairing. -}
getStartLocalPairR :: Handler Html
getStartLocalPairR = postStartLocalPairR
postStartLocalPairR :: Handler Html
#ifdef WITH_PAIRING
postStartLocalPairR = promptSecret Nothing $
startLocalPairing PairReq noop pairingAlert Nothing
#else
postStartLocalPairR = noLocalPairing
noLocalPairing :: Handler Html
noLocalPairing = noPairing "local"
#endif
{- Runs on the system that responds to a local pair request; sets up the ssh
- authorized key first so that the originating host can immediately sync
- with us. -}
getFinishLocalPairR :: PairMsg -> Handler Html
getFinishLocalPairR = postFinishLocalPairR
postFinishLocalPairR :: PairMsg -> Handler Html
#ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
repodir <- liftH $ repoPath <$> liftAnnex gitRepo
liftIO $ setup repodir
startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
where
alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
setup repodir = setupAuthorizedKeys msg repodir
cleanup repodir = removeAuthorizedKeys False repodir $
remoteSshPubKey $ pairMsgData msg
uuid = Just $ pairUUID $ pairMsgData msg
#else
postFinishLocalPairR _ = noLocalPairing
#endif
getConfirmXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP
getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
Nothing -> error "bad JID"
Just theirjid -> pairPage $ do
let name = buddyName theirjid
$(widgetFile "configurators/pairing/xmpp/friend/confirm")
#else
getConfirmXMPPPairFriendR _ = noXMPPPairing
#endif
getFinishXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP
getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
Nothing -> error "bad JID"
Just theirjid -> do
selfuuid <- liftAnnex getUUID
liftAssistant $ do
sendNetMessage $
PairingNotification PairAck (formatJID theirjid) selfuuid
finishXMPPPairing theirjid theiruuid
xmppPairStatus False $ Just theirjid
#else
getFinishXMPPPairFriendR _ = noXMPPPairing
#endif
{- Displays a page indicating pairing status and
- prompting to set up cloud repositories. -}
#ifdef WITH_XMPP
xmppPairStatus :: Bool -> Maybe JID -> Handler Html
xmppPairStatus inprogress theirjid = pairPage $ do
let friend = buddyName <$> theirjid
$(widgetFile "configurators/pairing/xmpp/end")
#endif
getRunningLocalPairR :: SecretReminder -> Handler Html
#ifdef WITH_PAIRING
getRunningLocalPairR s = pairPage $ do
let secret = fromSecretReminder s
$(widgetFile "configurators/pairing/local/inprogress")
#else
getRunningLocalPairR _ = noLocalPairing
#endif
#ifdef WITH_PAIRING
{- Starts local pairing, at either the PairReq (initiating host) or
- PairAck (responding host) stage.
-
- Displays an alert, and starts a thread sending the pairing message,
- which will continue running until the other host responds, or until
- canceled by the user. If canceled by the user, runs the oncancel action.
-
- Redirects to the pairing in progress page.
-}
startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
startLocalPairing stage oncancel alert muuid displaysecret secret = do
urlrender <- liftH getUrlRender
reldir <- fromJust . relDir <$> liftH getYesod
sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender
{- Generating a ssh key pair can take a while, so do it in the
- background. -}
thread <- liftAssistant $ asIO $ do
keypair <- liftIO $ genSshKeyPair
pairdata <- liftIO $ PairData
<$> getHostname
<*> myUserName
<*> pure reldir
<*> pure (sshPubKey keypair)
<*> (maybe genUUID return muuid)
let sender = multicastPairMsg Nothing secret pairdata
let pip = PairingInProgress secret Nothing keypair pairdata stage
startSending pip stage $ sendrequests sender
void $ liftIO $ forkIO thread
liftH $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
where
{- Sends pairing messages until the thread is killed,
- and shows an activity alert while doing it.
-
- The cancel button returns the user to the DashboardR. This is
- not ideal, but they have to be sent somewhere, and could
- have been on a page specific to the in-process pairing
- that just stopped, so can't go back there.
-}
mksendrequests urlrender sender _stage = do
tid <- liftIO myThreadId
let selfdestruct = AlertButton
{ buttonLabel = "Cancel"
, buttonUrl = urlrender DashboardR
, buttonAction = Just $ const $ do
oncancel
killThread tid
}
alertDuring (alert selfdestruct) $ liftIO $ do
_ <- E.try (sender stage) :: IO (Either E.SomeException ())
return ()
data InputSecret = InputSecret { secretText :: Maybe Text }
{- If a PairMsg is passed in, ensures that the user enters a secret
- that can validate it. -}
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
promptSecret msg cont = pairPage $ do
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $
InputSecret <$> aopt textField "Secret phrase" Nothing
case result of
FormSuccess v -> do
let rawsecret = fromMaybe "" $ secretText v
let secret = toSecret rawsecret
case msg of
Nothing -> case secretProblem secret of
Nothing -> cont rawsecret secret
Just problem ->
showform form enctype $ Just problem
Just m ->
if verify (fromPairMsg m) secret
then cont rawsecret secret
else showform form enctype $ Just
"That's not the right secret phrase."
_ -> showform form enctype Nothing
where
showform form enctype mproblem = do
let start = isNothing msg
let badphrase = isJust mproblem
let problem = fromMaybe "" mproblem
let (username, hostname) = maybe ("", "")
(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))
(verifiableVal . fromPairMsg <$> msg)
u <- T.pack <$> liftIO myUserName
let sameusername = username == u
$(widgetFile "configurators/pairing/local/prompt")
{- This counts unicode characters as more than one character,
- but that's ok; they *do* provide additional entropy. -}
secretProblem :: Secret -> Maybe Text
secretProblem s
| B.null s = Just "The secret phrase cannot be left empty. (Remember that punctuation and white space is ignored.)"
| B.length s < 6 = Just "Enter a longer secret phrase, at least 6 characters, but really, a phrase is best! This is not a password you'll need to enter every day."
| s == toSecret sampleQuote = Just "Speaking of foolishness, don't paste in the example I gave. Enter a different phrase, please!"
| otherwise = Nothing
toSecret :: Text -> Secret
toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s]
{- From Dickens -}
sampleQuote :: Text
sampleQuote = T.unwords
[ "It was the best of times,"
, "it was the worst of times,"
, "it was the age of wisdom,"
, "it was the age of foolishness."
]
#else
#endif
pairPage :: Widget -> Handler Html
pairPage = page "Pairing" (Just Configuration)
noPairing :: Text -> Handler Html
noPairing pairingtype = pairPage $
$(widgetFile "configurators/pairing/disabled")

View file

@ -0,0 +1,103 @@
{- git-annex assistant general preferences
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Preferences (
getPreferencesR,
postPreferencesR
) where
import Assistant.WebApp.Common
import qualified Annex
import qualified Git
import Config
import Config.Files
import Utility.DataUnits
import Git.Config
import qualified Data.Text as T
data PrefsForm = PrefsForm
{ diskReserve :: Text
, numCopies :: Int
, autoStart :: Bool
, debugEnabled :: Bool
}
prefsAForm :: PrefsForm -> MkAForm PrefsForm
prefsAForm def = PrefsForm
<$> areq (storageField `withNote` diskreservenote)
"Disk reserve" (Just $ diskReserve def)
<*> areq (positiveIntField `withNote` numcopiesnote)
"Number of copies" (Just $ numCopies def)
<*> areq (checkBoxField `withNote` autostartnote)
"Auto start" (Just $ autoStart def)
<*> areq (checkBoxField `withNote` debugnote)
"Enable debug logging" (Just $ debugEnabled def)
where
diskreservenote = [whamlet|<br>Avoid downloading files from other repositories when there is too little free disk space.|]
numcopiesnote = [whamlet|<br>Only drop a file after verifying that other repositories contain this many copies.|]
debugnote = [whamlet|<a href="@{LogR}">View Log</a>|]
autostartnote = [whamlet|Start the git-annex assistant at boot or on login.|]
positiveIntField = check isPositive intField
where
isPositive i
| i > 0 = Right i
| otherwise = Left notPositive
notPositive :: Text
notPositive = "This should be 1 or more!"
storageField = check validStorage textField
where
validStorage t
| T.null t = Right t
| otherwise = case readSize dataUnits $ T.unpack t of
Nothing -> Left badParse
Just _ -> Right t
badParse :: Text
badParse = "Parse error. Expected something like \"100 megabytes\" or \"2 gb\""
getPrefs :: Annex PrefsForm
getPrefs = PrefsForm
<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
<*> (annexNumCopies <$> Annex.getGitConfig)
<*> inAutoStartFile
<*> (annexDebug <$> Annex.getGitConfig)
storePrefs :: PrefsForm -> Annex ()
storePrefs p = do
setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
setConfig (annexConfig "numcopies") (show $ numCopies p)
unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
here <- fromRepo Git.repoPath
liftIO $ if autoStart p
then addAutoStartFile here
else removeAutoStartFile here
setConfig (annexConfig "debug") (boolConfig $ debugEnabled p)
liftIO $ if debugEnabled p
then enableDebugOutput
else disableDebugOutput
getPreferencesR :: Handler Html
getPreferencesR = postPreferencesR
postPreferencesR :: Handler Html
postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- liftH $ do
current <- liftAnnex getPrefs
runFormPost $ renderBootstrap $ prefsAForm current
case result of
FormSuccess new -> liftH $ do
liftAnnex $ storePrefs new
redirect ConfigurationR
_ -> $(widgetFile "configurators/preferences")
inAutoStartFile :: Annex Bool
inAutoStartFile = do
here <- fromRepo Git.repoPath
any (`equalFilePath` here) <$> liftIO readAutoStartFile

View file

@ -0,0 +1,382 @@
{- git-annex assistant webapp configurator for ssh-based remotes
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.WebApp.Configurators.Ssh where
import Assistant.WebApp.Common
import Assistant.Ssh
import Assistant.MakeRemote
import Utility.Rsync (rsyncUrlIsShell)
import Logs.Remote
import Remote
import Logs.PreferredContent
import Types.StandardGroups
import Utility.UserInfo
import qualified Data.Text as T
import qualified Data.Map as M
import Network.Socket
sshConfigurator :: Widget -> Handler Html
sshConfigurator = page "Add a remote server" (Just Configuration)
data SshInput = SshInput
{ inputHostname :: Maybe Text
, inputUsername :: Maybe Text
, inputDirectory :: Maybe Text
, inputPort :: Int
}
deriving (Show)
{- SshInput is only used for applicative form prompting, this converts
- the result of such a form into a SshData. -}
mkSshData :: SshInput -> SshData
mkSshData s = SshData
{ sshHostName = fromMaybe "" $ inputHostname s
, sshUserName = inputUsername s
, sshDirectory = fromMaybe "" $ inputDirectory s
, sshRepoName = genSshRepoName
(T.unpack $ fromJust $ inputHostname s)
(maybe "" T.unpack $ inputDirectory s)
, sshPort = inputPort s
, needsPubKey = False
, rsyncOnly = False
}
mkSshInput :: SshData -> SshInput
mkSshInput s = SshInput
{ inputHostname = Just $ sshHostName s
, inputUsername = sshUserName s
, inputDirectory = Just $ sshDirectory s
, inputPort = sshPort s
}
#if MIN_VERSION_yesod(1,2,0)
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
#else
sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
#endif
sshInputAForm hostnamefield def = SshInput
<$> aopt check_hostname "Host name" (Just $ inputHostname def)
<*> aopt check_username "User name" (Just $ inputUsername def)
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
<*> areq intField "Port" (Just $ inputPort def)
where
check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
bad_username textField
bad_username = "bad user name" :: Text
#ifndef __ANDROID__
bad_hostname = "cannot resolve host name" :: Text
check_hostname = checkM (liftIO . checkdns) hostnamefield
checkdns t = do
let h = T.unpack t
let canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }
r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
return $ case catMaybes . map addrCanonName <$> r of
-- canonicalize input hostname if it had no dot
Just (fullname:_)
| '.' `elem` h -> Right t
| otherwise -> Right $ T.pack fullname
Just [] -> Right t
Nothing -> Left bad_hostname
#else
-- getAddrInfo currently broken on Android
check_hostname = hostnamefield -- unchecked
#endif
data ServerStatus
= UntestedServer
| UnusableServer Text -- reason why it's not usable
| UsableRsyncServer
| UsableSshInput
deriving (Eq)
usable :: ServerStatus -> Bool
usable UntestedServer = False
usable (UnusableServer _) = False
usable UsableRsyncServer = True
usable UsableSshInput = True
getAddSshR :: Handler Html
getAddSshR = postAddSshR
postAddSshR :: Handler Html
postAddSshR = sshConfigurator $ do
u <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sshInputAForm textField $
SshInput Nothing (Just u) Nothing 22
case result of
FormSuccess sshinput -> do
s <- liftIO $ testServer sshinput
case s of
Left status -> showform form enctype status
Right sshdata -> liftH $ redirect $ ConfirmSshR sshdata
_ -> showform form enctype UntestedServer
where
showform form enctype status = $(widgetFile "configurators/ssh/add")
sshTestModal :: Widget
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
{- To enable an existing rsync special remote, parse the SshInput from
- its rsyncurl, and display a form whose only real purpose is to check
- if ssh public keys need to be set up. From there, we can proceed with
- the usual repo setup; all that code is idempotent.
-
- Note that there's no EnableSshR because ssh remotes are not special
- remotes, and so their configuration is not shared between repositories.
-}
getEnableRsyncR :: UUID -> Handler Html
getEnableRsyncR = postEnableRsyncR
postEnableRsyncR :: UUID -> Handler Html
postEnableRsyncR u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
(Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
case result of
FormSuccess sshinput'
| isRsyncNet (inputHostname sshinput') ->
void $ liftH $ makeRsyncNet sshinput' reponame (const noop)
| otherwise -> do
s <- liftIO $ testServer sshinput'
case s of
Left status -> showform form enctype status
Right sshdata -> enable sshdata
{ sshRepoName = reponame }
_ -> showform form enctype UntestedServer
_ -> redirect AddSshR
where
showform form enctype status = do
description <- liftAnnex $ T.pack <$> prettyUUID u
$(widgetFile "configurators/ssh/enable")
enable sshdata = liftH $ redirect $ ConfirmSshR $
sshdata { rsyncOnly = True }
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
- url; rsync:// urls or bare path names are not supported.
-
- The hostname is stored mangled in the remote log for rsync special
- remotes configured by this webapp. So that mangling has to reversed
- here to get back the original hostname.
-}
parseSshRsyncUrl :: String -> Maybe SshInput
parseSshRsyncUrl u
| not (rsyncUrlIsShell u) = Nothing
| otherwise = Just $ SshInput
{ inputHostname = val $ unMangleSshHostName host
, inputUsername = if null user then Nothing else val user
, inputDirectory = val dir
, inputPort = 22
}
where
val = Just . T.pack
(userhost, dir) = separate (== ':') u
(user, host) = if '@' `elem` userhost
then separate (== '@') userhost
else (userhost, "")
{- Test if we can ssh into the server.
-
- Two probe attempts are made. First, try sshing in using the existing
- configuration, but don't let ssh prompt for any password. If
- passwordless login is already enabled, use it. Otherwise,
- a special ssh key will need to be generated just for this server.
-
- Once logged into the server, probe to see if git-annex-shell is
- available, or rsync. Note that, ~/.ssh/git-annex-shell may be
- present, while git-annex-shell is not in PATH.
-}
testServer :: SshInput -> IO (Either ServerStatus SshData)
testServer (SshInput { inputHostname = Nothing }) = return $
Left $ UnusableServer "Please enter a host name."
testServer sshinput@(SshInput { inputHostname = Just hn }) = do
status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
if usable status
then ret status False
else do
status' <- probe []
if usable status'
then ret status' True
else return $ Left status'
where
ret status needspubkey = return $ Right $ (mkSshData sshinput)
{ needsPubKey = needspubkey
, rsyncOnly = status == UsableRsyncServer
}
probe extraopts = do
let remotecommand = shellWrap $ intercalate ";"
[ report "loggedin"
, checkcommand "git-annex-shell"
, checkcommand "rsync"
, checkcommand shim
]
knownhost <- knownHost hn
let sshopts = filter (not . null) $ extraopts ++
{- If this is an already known host, let
- ssh check it as usual.
- Otherwise, trust the host key. -}
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
, "-n" -- don't read from stdin
, "-p", show (inputPort sshinput)
, genSshHost
(fromJust $ inputHostname sshinput)
(inputUsername sshinput)
, remotecommand
]
parsetranscript . fst <$> sshTranscript sshopts Nothing
parsetranscript s
| reported "git-annex-shell" = UsableSshInput
| reported shim = UsableSshInput
| reported "rsync" = UsableRsyncServer
| reported "loggedin" = UnusableServer
"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
| otherwise = UnusableServer $ T.pack $
"Failed to ssh to the server. Transcript: " ++ s
where
reported r = token r `isInfixOf` s
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
token r = "git-annex-probe " ++ r
report r = "echo " ++ token r
shim = "~/.ssh/git-annex-shell"
{- Runs a ssh command; if it fails shows the user the transcript,
- and if it succeeds, runs an action. -}
sshSetup :: [String] -> String -> Handler Html -> Handler Html
sshSetup opts input a = do
(transcript, ok) <- liftIO $ sshTranscript opts (Just input)
if ok
then a
else showSshErr transcript
showSshErr :: String -> Handler Html
showSshErr msg = sshConfigurator $
$(widgetFile "configurators/ssh/error")
getConfirmSshR :: SshData -> Handler Html
getConfirmSshR sshdata = sshConfigurator $
$(widgetFile "configurators/ssh/confirm")
getRetrySshR :: SshData -> Handler ()
getRetrySshR sshdata = do
s <- liftIO $ testServer $ mkSshInput sshdata
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
getMakeSshGitR :: SshData -> Handler Html
getMakeSshGitR = makeSsh False setupGroup
getMakeSshRsyncR :: SshData -> Handler Html
getMakeSshRsyncR = makeSsh True setupGroup
makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
makeSsh rsync setup sshdata
| needsPubKey sshdata = do
keypair <- liftIO genSshKeyPair
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
makeSsh' rsync setup sshdata sshdata' (Just keypair)
| sshPort sshdata /= 22 = do
sshdata' <- liftIO $ setSshConfig sshdata []
makeSsh' rsync setup sshdata sshdata' Nothing
| otherwise = makeSsh' rsync setup sshdata sshdata Nothing
makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
makeSsh' rsync setup origsshdata sshdata keypair = do
sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $
makeSshRepo rsync setup sshdata
where
sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
remotedir = T.unpack $ sshDirectory sshdata
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
[ Just $ "mkdir -p " ++ shellEscape remotedir
, Just $ "cd " ++ shellEscape remotedir
, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
, if rsync then Nothing else Just "git annex init"
, if needsPubKey sshdata
then addAuthorizedKeysCommand (rsync || rsyncOnly sshdata) remotedir . sshPubKey <$> keypair
else Nothing
]
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
makeSshRepo forcersync setup sshdata = do
r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing
setup r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
getAddRsyncNetR :: Handler Html
getAddRsyncNetR = postAddRsyncNetR
postAddRsyncNetR :: Handler Html
postAddRsyncNetR = do
((result, form), enctype) <- runFormPost $
renderBootstrap $ sshInputAForm hostnamefield $
SshInput Nothing Nothing Nothing 22
let showform status = page "Add a Rsync.net repository" (Just Configuration) $
$(widgetFile "configurators/addrsync.net")
case result of
FormSuccess sshinput
| isRsyncNet (inputHostname sshinput) -> do
let reponame = genSshRepoName "rsync.net"
(maybe "" T.unpack $ inputDirectory sshinput)
makeRsyncNet sshinput reponame setupGroup
| otherwise ->
showform $ UnusableServer
"That is not a rsync.net host name."
_ -> showform UntestedServer
where
hostnamefield = textField `withExpandableNote` ("Help", help)
help = [whamlet|
<div>
When you sign up for a Rsync.net account, you should receive an #
email from them with the host name and user name to put here.
<div>
The host name will be something like "usw-s001.rsync.net", and the #
user name something like "7491"
|]
makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html
makeRsyncNet sshinput reponame setup = do
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
keypair <- liftIO $ genSshKeyPair
sshdata <- liftIO $ setupSshKeyPair keypair $
(mkSshData sshinput)
{ sshRepoName = reponame
, needsPubKey = True
, rsyncOnly = True
}
{- I'd prefer to separate commands with && , but
- rsync.net's shell does not support that.
-
- The dd method of appending to the authorized_keys file is the
- one recommended by rsync.net documentation. I touch the file first
- to not need to use a different method to create it.
-}
let remotecommand = intercalate ";"
[ "mkdir -p .ssh"
, "touch .ssh/authorized_keys"
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
]
let sshopts = filter (not . null)
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
, remotecommand
]
sshSetup sshopts (sshPubKey keypair) $
makeSshRepo True setup sshdata
isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
setupGroup :: Remote -> Handler ()
setupGroup r = liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup

View file

@ -0,0 +1,147 @@
{- git-annex assistant webapp configurators for WebDAV remotes
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.WebDAV where
import Assistant.WebApp.Common
import Creds
#ifdef WITH_WEBDAV
import qualified Remote.WebDAV as WebDAV
import Assistant.MakeRemote
import Assistant.Sync
import qualified Remote
import Types.Remote (RemoteConfig)
import Types.StandardGroups
import Logs.PreferredContent
import Logs.Remote
import qualified Data.Map as M
#endif
import qualified Data.Text as T
import Network.URI
webDAVConfigurator :: Widget -> Handler Html
webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
boxConfigurator :: Widget -> Handler Html
boxConfigurator = page "Add a Box.com repository" (Just Configuration)
data WebDAVInput = WebDAVInput
{ user :: Text
, password :: Text
, embedCreds :: Bool
, directory :: Text
, enableEncryption :: EnableEncryption
}
toCredPair :: WebDAVInput -> CredPair
toCredPair input = (T.unpack $ user input, T.unpack $ password input)
boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput
boxComAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
<*> areq textField "Directory" (Just "annex")
<*> enableEncryptionField
webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput
webDAVCredsAForm defcreds = WebDAVInput
<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
<*> areq passwordField "Password" (T.pack . snd <$> defcreds)
<*> pure False
<*> pure T.empty
<*> pure NoEncryption -- not used!
getAddBoxComR :: Handler Html
getAddBoxComR = postAddBoxComR
postAddBoxComR :: Handler Html
#ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ boxComAForm defcreds
case result of
FormSuccess input -> liftH $
makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) setgroup $ M.fromList
[ configureEncryption $ enableEncryption input
, ("embedcreds", if embedCreds input then "yes" else "no")
, ("type", "webdav")
, ("url", "https://www.box.com/dav/" ++ T.unpack (directory input))
-- Box.com has a max file size of 100 mb, but
-- using smaller chunks has better memory
-- performance.
, ("chunksize", "10mb")
]
_ -> $(widgetFile "configurators/addbox.com")
where
setgroup r = liftAnnex $
setStandardGroup (Remote.uuid r) TransferGroup
#else
postAddBoxComR = error "WebDAV not supported by this build"
#endif
getEnableWebDAVR :: UUID -> Handler Html
getEnableWebDAVR = postEnableWebDAVR
postEnableWebDAVR :: UUID -> Handler Html
#ifdef WITH_WEBDAV
postEnableWebDAVR uuid = do
m <- liftAnnex readRemoteLog
let c = fromJust $ M.lookup uuid m
let name = fromJust $ M.lookup "name" c
let url = fromJust $ M.lookup "url" c
mcreds <- liftAnnex $
getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
case mcreds of
Just creds -> webDAVConfigurator $ liftH $
makeWebDavRemote enableSpecialRemote name creds (const noop) M.empty
Nothing
| "box.com/" `isInfixOf` url ->
boxConfigurator $ showform name url
| otherwise ->
webDAVConfigurator $ showform name url
where
showform name url = do
defcreds <- liftAnnex $
maybe (pure Nothing) previouslyUsedWebDAVCreds $
urlHost url
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
case result of
FormSuccess input -> liftH $
makeWebDavRemote enableSpecialRemote name (toCredPair input) (const noop) M.empty
_ -> do
description <- liftAnnex $
T.pack <$> Remote.prettyUUID uuid
$(widgetFile "configurators/enablewebdav")
#else
postEnableWebDAVR _ = error "WebDAV not supported by this build"
#endif
#ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds setup config = do
liftIO $ WebDAV.setCredsEnv creds
r <- liftAnnex $ addRemote $ maker name WebDAV.remote config
setup r
liftAssistant $ syncRemote r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
{- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)
previouslyUsedWebDAVCreds hostname =
previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost
where
samehost url = case urlHost =<< WebDAV.configUrl url of
Nothing -> False
Just h -> h == hostname
#endif
urlHost :: String -> Maybe String
urlHost url = uriRegName <$> (uriAuthority =<< parseURI url)

View file

@ -0,0 +1,220 @@
{- git-annex assistant XMPP configuration
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Assistant.WebApp.Configurators.XMPP where
import Assistant.WebApp.Common
import Assistant.WebApp.Notifications
import Utility.NotificationBroadcaster
#ifdef WITH_XMPP
import qualified Remote
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.Types.Buddies
import Assistant.NetMessager
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
#endif
#ifdef WITH_XMPP
import Network.Protocol.XMPP
import Network
import qualified Data.Text as T
#endif
{- Displays an alert suggesting to configure XMPP. -}
xmppNeeded :: Handler ()
#ifdef WITH_XMPP
xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
urlrender <- getUrlRender
void $ liftAssistant $ do
close <- asIO1 removeAlert
addAlert $ xmppNeededAlert $ AlertButton
{ buttonLabel = "Configure a Jabber account"
, buttonUrl = urlrender XMPPConfigR
, buttonAction = Just close
}
#else
xmppNeeded = return ()
#endif
{- When appropriate, displays an alert suggesting to configure a cloud repo
- to suppliment an XMPP remote. -}
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
#ifdef WITH_XMPP
checkCloudRepos urlrenderer r =
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
buddyname <- getBuddyName $ Remote.uuid r
button <- mkAlertButton "Add a cloud repository" urlrenderer $
NeedCloudRepoR $ Remote.uuid r
void $ addAlert $ cloudRepoNeededAlert buddyname button
#else
checkCloudRepos _ _ = noop
#endif
#ifdef WITH_XMPP
{- Returns the name of the friend corresponding to a
- repository's UUID, but not if it's our name. -}
getBuddyName :: UUID -> Assistant (Maybe String)
getBuddyName u = go =<< getclientjid
where
go Nothing = return Nothing
go (Just myjid) = (T.unpack . buddyName <$>)
. headMaybe
. filter (\j -> baseJID j /= baseJID myjid)
. map fst
. filter (\(_, r) -> Remote.uuid r == u)
<$> getXMPPRemotes
getclientjid = maybe Nothing parseJID . xmppClientID
<$> getDaemonStatus
#endif
getNeedCloudRepoR :: UUID -> Handler Html
#ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
buddyname <- liftAssistant $ getBuddyName for
$(widgetFile "configurators/xmpp/needcloudrepo")
#else
getNeedCloudRepoR _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
getXMPPConfigR :: Handler Html
getXMPPConfigR = postXMPPConfigR
postXMPPConfigR :: Handler Html
postXMPPConfigR = xmppform DashboardR
getXMPPConfigForPairFriendR :: Handler Html
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
postXMPPConfigForPairFriendR :: Handler Html
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
getXMPPConfigForPairSelfR :: Handler Html
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
postXMPPConfigForPairSelfR :: Handler Html
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
xmppform :: Route WebApp -> Handler Html
#ifdef WITH_XMPP
xmppform next = xmppPage $ do
((result, form), enctype) <- liftH $ do
oldcreds <- liftAnnex getXMPPCreds
runFormPost $ renderBootstrap $ xmppAForm $
creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp")
case result of
FormSuccess f -> either (showform . Just) (liftH . storecreds)
=<< liftIO (validateForm f)
_ -> showform Nothing
where
storecreds creds = do
void $ liftAnnex $ setXMPPCreds creds
liftAssistant notifyNetMessagerRestart
redirect next
#else
xmppform _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
{- Called by client to get a list of buddies.
-
- Returns a div, which will be inserted into the calling page.
-}
getBuddyListR :: NotificationId -> Handler Html
getBuddyListR nid = do
waitNotifier getBuddyListBroadcaster nid
p <- widgetToPageContent buddyListDisplay
giveUrlRenderer $ [hamlet|^{pageBody p}|]
buddyListDisplay :: Widget
buddyListDisplay = do
autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
#ifdef WITH_XMPP
myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
let isself (BuddyKey b) = Just b == myjid
buddies <- liftAssistant $ do
pairedwith <- map fst <$> getXMPPRemotes
catMaybes . map (buddySummary pairedwith)
<$> (getBuddyList <<~ buddyList)
$(widgetFile "configurators/xmpp/buddylist")
#endif
where
ident = "buddylist"
#ifdef WITH_XMPP
getXMPPRemotes :: Assistant [(JID, Remote)]
getXMPPRemotes = catMaybes . map pair . filter isXMPPRemote . syncGitRemotes
<$> getDaemonStatus
where
pair r = maybe Nothing (\jid -> Just (jid, r)) $
parseJID $ getXMPPClientID r
data XMPPForm = XMPPForm
{ formJID :: Text
, formPassword :: Text }
creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
xmppAForm def = XMPPForm
<$> areq jidField "Jabber address" (formJID <$> def)
<*> areq passwordField "Password" Nothing
jidField :: MkField Text
jidField = checkBool (isJust . parseJID) bad textField
where
bad :: Text
bad = "This should look like an email address.."
validateForm :: XMPPForm -> IO (Either String XMPPCreds)
validateForm f = do
let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
let username = fromMaybe "" (strNode <$> jidNode jid)
testXMPP $ XMPPCreds
{ xmppUsername = username
, xmppPassword = formPassword f
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
, xmppPort = 5222
, xmppJID = formJID f
}
testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
testXMPP creds = do
(good, bad) <- partition (either (const False) (const True) . snd)
<$> connectXMPP creds (const noop)
case good of
(((h, PortNumber p), _):_) -> return $ Right $ creds
{ xmppHostname = h
, xmppPort = fromIntegral p
}
(((h, _), _):_) -> return $ Right $ creds
{ xmppHostname = h
}
_ -> return $ Left $ intercalate "; " $ map formatlog bad
where
formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
formatlog _ = ""
showport (PortNumber n) = show n
showport (Service s) = s
showport (UnixSocket s) = s
#endif
xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration)

View file

@ -0,0 +1,71 @@
{- git-annex assistant webapp control
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.Control where
import Assistant.WebApp.Common
import Config.Files
import Utility.LogFile
import Assistant.DaemonStatus
import Assistant.WebApp.Utility
import Assistant.Alert
import Control.Concurrent
import System.Posix (getProcessID, signalProcess, sigTERM)
import qualified Data.Map as M
getShutdownR :: Handler Html
getShutdownR = page "Shutdown" Nothing $
$(widgetFile "control/shutdown")
getShutdownConfirmedR :: Handler Html
getShutdownConfirmedR = do
{- Remove all alerts for currently running activities. -}
liftAssistant $ do
updateAlertMap $ M.filter $ \a -> alertClass a /= Activity
void $ addAlert shutdownAlert
{- Stop transfers the assistant is running,
- otherwise they would continue past shutdown.
- Pausing transfers prevents more being started up (and stops
- the transfer processes). -}
ts <- liftAssistant $ M.keys . currentTransfers <$> getDaemonStatus
mapM_ pauseTransfer ts
page "Shutdown" Nothing $ do
{- Wait 2 seconds before shutting down, to give the web
- page time to load in the browser. -}
void $ liftIO $ forkIO $ do
threadDelay 2000000
signalProcess sigTERM =<< getProcessID
$(widgetFile "control/shutdownconfirmed")
{- Quite a hack, and doesn't redirect the browser window. -}
getRestartR :: Handler Html
getRestartR = page "Restarting" Nothing $ do
void $ liftIO $ forkIO $ do
threadDelay 2000000
program <- readProgramFile
unlessM (boolSystem "sh" [Param "-c", Param $ restartcommand program]) $
error "restart failed"
$(widgetFile "control/restarting")
where
restartcommand program = program ++ " assistant --stop; exec " ++
program ++ " webapp"
getRestartThreadR :: ThreadName -> Handler ()
getRestartThreadR name = do
m <- liftAssistant $ startedThreads <$> getDaemonStatus
liftIO $ maybe noop snd $ M.lookup name m
redirectBack
getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexLogFile
logs <- liftIO $ listLogs logfile
logcontent <- liftIO $ concat <$> mapM readFile logs
$(widgetFile "control/log")

View file

@ -0,0 +1,150 @@
{- git-annex assistant webapp dashboard
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.DashBoard where
import Assistant.WebApp.Common
import Assistant.WebApp.Utility
import Assistant.WebApp.RepoList
import Assistant.WebApp.Notifications
import Assistant.TransferQueue
import Assistant.DaemonStatus
import Utility.NotificationBroadcaster
import Logs.Transfer
import Utility.Percentage
import Utility.DataUnits
import Types.Key
import qualified Remote
import qualified Git
import qualified Text.Hamlet as Hamlet
import qualified Data.Map as M
import Control.Concurrent
{- A display of currently running and queued transfers. -}
transfersDisplay :: Bool -> Widget
transfersDisplay warnNoScript = do
webapp <- liftH getYesod
current <- liftH $ M.toList <$> getCurrentTransfers
queued <- take 10 <$> liftAssistant getTransferQueue
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued
let transfersrunning = not $ null transfers
scanrunning <- if transfersrunning
then return False
else liftAssistant $ transferScanRunning <$> getDaemonStatus
$(widgetFile "dashboard/transfers")
where
ident = "transfers"
isrunning info = not $
transferPaused info || isNothing (startedTime info)
{- Simplifies a list of transfers, avoiding display of redundant
- equivilant transfers. -}
simplifyTransfers :: [(Transfer, TransferInfo)] -> [(Transfer, TransferInfo)]
simplifyTransfers [] = []
simplifyTransfers (x:[]) = [x]
simplifyTransfers (v@(t1, _):r@((t2, _):l))
| equivilantTransfer t1 t2 = simplifyTransfers (v:l)
| otherwise = v : (simplifyTransfers r)
{- Called by client to get a display of currently in process transfers.
-
- Returns a div, which will be inserted into the calling page.
-
- Note that the head of the widget is not included, only its
- body is. To get the widget head content, the widget is also
- inserted onto the getDashboardR page.
-}
getTransfersR :: NotificationId -> Handler Html
getTransfersR nid = do
waitNotifier getTransferBroadcaster nid
p <- widgetToPageContent $ transfersDisplay False
giveUrlRenderer $ [hamlet|^{pageBody p}|]
{- The main dashboard. -}
dashboard :: Bool -> Widget
dashboard warnNoScript = do
let repolist = repoListDisplay $
mainRepoSelector { nudgeAddMore = True }
let transferlist = transfersDisplay warnNoScript
$(widgetFile "dashboard/main")
getDashboardR :: Handler Html
getDashboardR = ifM (inFirstRun)
( redirect ConfigurationR
, page "" (Just DashBoard) $ dashboard True
)
{- Used to test if the webapp is running. -}
headDashboardR :: Handler ()
headDashboardR = noop
{- Same as DashboardR, except no autorefresh at all (and no noscript warning). -}
getNoScriptR :: Handler Html
getNoScriptR = page "" (Just DashBoard) $ dashboard False
{- Same as DashboardR, except with autorefreshing via meta refresh. -}
getNoScriptAutoR :: Handler Html
getNoScriptAutoR = page "" (Just DashBoard) $ do
let ident = NoScriptR
let delayseconds = 3 :: Int
let this = NoScriptAutoR
toWidgetHead $(Hamlet.hamletFile $ hamletTemplate "dashboard/metarefresh")
dashboard False
{- The javascript code does a post. -}
postFileBrowserR :: Handler ()
postFileBrowserR = void openFileBrowser
{- Used by non-javascript browsers, where clicking on the link actually
- opens this page, so we redirect back to the referrer. -}
getFileBrowserR :: Handler ()
getFileBrowserR = whenM openFileBrowser $ redirectBack
{- Opens the system file browser on the repo, or, as a fallback,
- goes to a file:// url. Returns True if it's ok to redirect away
- from the page (ie, the system file browser was opened).
-
- Note that the command is opened using a different thread, to avoid
- blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool
openFileBrowser = do
path <- liftAnnex $ fromRepo Git.repoPath
ifM (liftIO $ inPath cmd <&&> inPath cmd)
( do
void $ liftIO $ forkIO $ void $
boolSystem cmd [Param path]
return True
, do
void $ redirect $ "file://" ++ path
return False
)
where
#ifdef darwin_HOST_OS
cmd = "open"
#else
cmd = "xdg-open"
#endif
{- Transfer controls. The GET is done in noscript mode and redirects back
- to the referring page. The POST is called by javascript. -}
getPauseTransferR :: Transfer -> Handler ()
getPauseTransferR t = pauseTransfer t >> redirectBack
postPauseTransferR :: Transfer -> Handler ()
postPauseTransferR t = pauseTransfer t
getStartTransferR :: Transfer -> Handler ()
getStartTransferR t = startTransfer t >> redirectBack
postStartTransferR :: Transfer -> Handler ()
postStartTransferR t = startTransfer t
getCancelTransferR :: Transfer -> Handler ()
getCancelTransferR t = cancelTransfer False t >> redirectBack
postCancelTransferR :: Transfer -> Handler ()
postCancelTransferR t = cancelTransfer False t

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