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:
commit
341269e035
5105 changed files with 170755 additions and 0 deletions
.ghciAnnex.hs
Annex
Branch.hsBranchState.hsCatFile.hsCheckAttr.hsCheckIgnore.hsContent.hs
Assistant.hsContent
Direct.hsEnvironment.hsException.hsFileMatcher.hsJournal.hsLink.hsLockPool.hsPerms.hsQueue.hsReplaceFile.hsSsh.hsTaggedPush.hsUUID.hsVersion.hsWanted.hsAssistant
Alert.hs
Alert
BranchChange.hsChanges.hsCommits.hsCommon.hsDaemonStatus.hsDeleteRemote.hsDrop.hsInstall.hsInstall
MakeRemote.hsMonad.hsNamedThread.hsNetMessager.hsPairing.hsPairing
Pushes.hsScanRemotes.hsSsh.hsSync.hsThreads
Committer.hsConfigMonitor.hsDaemonStatus.hsGlacier.hsMerger.hsMountWatcher.hsNetWatcher.hsPairListener.hsPusher.hsSanityChecker.hsTransferPoller.hsTransferScanner.hsTransferWatcher.hsTransferrer.hsWatcher.hsWebApp.hsXMPPClient.hsXMPPPusher.hs
TransferQueue.hsTransferSlots.hsTransferrerPool.hsTypes
Alert.hsBranchChange.hsBuddies.hsChanges.hsCommits.hsDaemonStatus.hsNamedThread.hsNetMessager.hsPushes.hsScanRemotes.hsThreadName.hsThreadedMonad.hsTransferQueue.hsTransferSlots.hsTransferrerPool.hsUrlRenderer.hs
WebApp.hsWebApp
1
.ghci
Normal file
1
.ghci
Normal file
|
@ -0,0 +1 @@
|
|||
:load Common
|
247
Annex.hs
Normal file
247
Annex.hs
Normal 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
363
Annex/Branch.hs
Normal 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
43
Annex/BranchState.hs
Normal 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
92
Annex/CatFile.hs
Normal 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
35
Annex/CheckAttr.hs
Normal 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
32
Annex/CheckIgnore.hs
Normal 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
511
Annex/Content.hs
Normal 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
251
Annex/Content/Direct.hs
Normal 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
232
Annex/Direct.hs
Normal 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
65
Annex/Environment.hs
Normal 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
39
Annex/Exception.hs
Normal 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
101
Annex/FileMatcher.hs
Normal 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
104
Annex/Journal.hs
Normal 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
105
Annex/Link.hs
Normal 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
56
Annex/LockPool.hs
Normal 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
105
Annex/Perms.hs
Normal 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
62
Annex/Queue.hs
Normal 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
39
Annex/ReplaceFile.hs
Normal 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
177
Annex/Ssh.hs
Normal 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
57
Annex/TaggedPush.hs
Normal 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
74
Annex/UUID.hs
Normal 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
53
Annex/Version.hs
Normal 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
32
Annex/Wanted.hs
Normal 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
147
Assistant.hs
Normal 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
311
Assistant/Alert.hs
Normal 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
130
Assistant/Alert/Utility.hs
Normal 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
19
Assistant/BranchChange.hs
Normal 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
47
Assistant/Changes.hs
Normal 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
23
Assistant/Commits.hs
Normal 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
14
Assistant/Common.hs
Normal 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
259
Assistant/DaemonStatus.hs
Normal 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
98
Assistant/DeleteRemote.hs
Normal 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
112
Assistant/Drop.hs
Normal 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
101
Assistant/Install.hs
Normal 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
|
39
Assistant/Install/AutoStart.hs
Normal file
39
Assistant/Install/AutoStart.hs
Normal 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
47
Assistant/Install/Menu.hs
Normal 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
175
Assistant/MakeRemote.hs
Normal 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
141
Assistant/Monad.hs
Normal 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
91
Assistant/NamedThread.hs
Normal 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
176
Assistant/NetMessager.hs
Normal 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
92
Assistant/Pairing.hs
Normal 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
|
91
Assistant/Pairing/MakeRemote.hs
Normal file
91
Assistant/Pairing/MakeRemote.hs
Normal 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)
|
130
Assistant/Pairing/Network.hs
Normal file
130
Assistant/Pairing/Network.hs
Normal 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
40
Assistant/Pushes.hs
Normal 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
41
Assistant/ScanRemotes.hs
Normal 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
293
Assistant/Ssh.hs
Normal 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
222
Assistant/Sync.hs
Normal 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
|
492
Assistant/Threads/Committer.hs
Normal file
492
Assistant/Threads/Committer.hs
Normal 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
|
86
Assistant/Threads/ConfigMonitor.hs
Normal file
86
Assistant/Threads/ConfigMonitor.hs
Normal 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)
|
29
Assistant/Threads/DaemonStatus.hs
Normal file
29
Assistant/Threads/DaemonStatus.hs
Normal 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
|
43
Assistant/Threads/Glacier.hs
Normal file
43
Assistant/Threads/Glacier.hs
Normal 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
118
Assistant/Threads/Merger.hs
Normal 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
|
192
Assistant/Threads/MountWatcher.hs
Normal file
192
Assistant/Threads/MountWatcher.hs
Normal 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
|
131
Assistant/Threads/NetWatcher.hs
Normal file
131
Assistant/Threads/NetWatcher.hs
Normal 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
|
148
Assistant/Threads/PairListener.hs
Normal file
148
Assistant/Threads/PairListener.hs
Normal 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)
|
48
Assistant/Threads/Pusher.hs
Normal file
48
Assistant/Threads/Pusher.hs
Normal 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
|
138
Assistant/Threads/SanityChecker.hs
Normal file
138
Assistant/Threads/SanityChecker.hs
Normal 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
|
56
Assistant/Threads/TransferPoller.hs
Normal file
56
Assistant/Threads/TransferPoller.hs
Normal 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
|
180
Assistant/Threads/TransferScanner.hs
Normal file
180
Assistant/Threads/TransferScanner.hs
Normal 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
|
126
Assistant/Threads/TransferWatcher.hs
Normal file
126
Assistant/Threads/TransferWatcher.hs
Normal 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
|
||||
|
140
Assistant/Threads/Transferrer.hs
Normal file
140
Assistant/Threads/Transferrer.hs
Normal 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
|
352
Assistant/Threads/Watcher.hs
Normal file
352
Assistant/Threads/Watcher.hs
Normal 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
101
Assistant/Threads/WebApp.hs
Normal 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
|
370
Assistant/Threads/XMPPClient.hs
Normal file
370
Assistant/Threads/XMPPClient.hs
Normal 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 }
|
81
Assistant/Threads/XMPPPusher.hs
Normal file
81
Assistant/Threads/XMPPPusher.hs
Normal 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
223
Assistant/TransferQueue.hs
Normal 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
|
78
Assistant/TransferSlots.hs
Normal file
78
Assistant/TransferSlots.hs
Normal 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
|
82
Assistant/TransferrerPool.hs
Normal file
82
Assistant/TransferrerPool.hs
Normal 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
75
Assistant/Types/Alert.hs
Normal 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 ())
|
||||
}
|
19
Assistant/Types/BranchChange.hs
Normal file
19
Assistant/Types/BranchChange.hs
Normal 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
|
80
Assistant/Types/Buddies.hs
Normal file
80
Assistant/Types/Buddies.hs
Normal 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
|
77
Assistant/Types/Changes.hs
Normal file
77
Assistant/Types/Changes.hs
Normal 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
|
19
Assistant/Types/Commits.hs
Normal file
19
Assistant/Types/Commits.hs
Normal 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
|
96
Assistant/Types/DaemonStatus.hs
Normal file
96
Assistant/Types/DaemonStatus.hs
Normal 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
|
17
Assistant/Types/NamedThread.hs
Normal file
17
Assistant/Types/NamedThread.hs
Normal 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
|
155
Assistant/Types/NetMessager.hs
Normal file
155
Assistant/Types/NetMessager.hs
Normal 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
24
Assistant/Types/Pushes.hs
Normal 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
|
25
Assistant/Types/ScanRemotes.hs
Normal file
25
Assistant/Types/ScanRemotes.hs
Normal 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
|
14
Assistant/Types/ThreadName.hs
Normal file
14
Assistant/Types/ThreadName.hs
Normal 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
|
38
Assistant/Types/ThreadedMonad.hs
Normal file
38
Assistant/Types/ThreadedMonad.hs
Normal 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
|
29
Assistant/Types/TransferQueue.hs
Normal file
29
Assistant/Types/TransferQueue.hs
Normal 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
|
34
Assistant/Types/TransferSlots.hs
Normal file
34
Assistant/Types/TransferSlots.hs
Normal 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
|
23
Assistant/Types/TransferrerPool.hs
Normal file
23
Assistant/Types/TransferrerPool.hs
Normal 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
|
26
Assistant/Types/UrlRenderer.hs
Normal file
26
Assistant/Types/UrlRenderer.hs
Normal 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
73
Assistant/WebApp.hs
Normal 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
|
17
Assistant/WebApp/Common.hs
Normal file
17
Assistant/WebApp/Common.hs
Normal 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)
|
44
Assistant/WebApp/Configurators.hs
Normal file
44
Assistant/WebApp/Configurators.hs
Normal 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")
|
||||
|
239
Assistant/WebApp/Configurators/AWS.hs
Normal file
239
Assistant/WebApp/Configurators/AWS.hs
Normal 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
|
126
Assistant/WebApp/Configurators/Delete.hs
Normal file
126
Assistant/WebApp/Configurators/Delete.hs
Normal 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!"
|
223
Assistant/WebApp/Configurators/Edit.hs
Normal file
223
Assistant/WebApp/Configurators/Edit.hs
Normal 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>|]
|
211
Assistant/WebApp/Configurators/IA.hs
Normal file
211
Assistant/WebApp/Configurators/IA.hs
Normal 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
|
412
Assistant/WebApp/Configurators/Local.hs
Normal file
412
Assistant/WebApp/Configurators/Local.hs
Normal 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
|
327
Assistant/WebApp/Configurators/Pairing.hs
Normal file
327
Assistant/WebApp/Configurators/Pairing.hs
Normal 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")
|
103
Assistant/WebApp/Configurators/Preferences.hs
Normal file
103
Assistant/WebApp/Configurators/Preferences.hs
Normal 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
|
382
Assistant/WebApp/Configurators/Ssh.hs
Normal file
382
Assistant/WebApp/Configurators/Ssh.hs
Normal 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
|
147
Assistant/WebApp/Configurators/WebDAV.hs
Normal file
147
Assistant/WebApp/Configurators/WebDAV.hs
Normal 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)
|
220
Assistant/WebApp/Configurators/XMPP.hs
Normal file
220
Assistant/WebApp/Configurators/XMPP.hs
Normal 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)
|
71
Assistant/WebApp/Control.hs
Normal file
71
Assistant/WebApp/Control.hs
Normal 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")
|
150
Assistant/WebApp/DashBoard.hs
Normal file
150
Assistant/WebApp/DashBoard.hs
Normal 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
Loading…
Add table
Reference in a new issue