This commit is contained in:
Joey Hess 2012-02-16 00:41:30 -04:00
parent e7aaa55c53
commit a1e52f0ce5
18 changed files with 36 additions and 37 deletions

View file

@ -116,7 +116,7 @@ updateTo pairs = do
-- check what needs updating before taking the lock -- check what needs updating before taking the lock
dirty <- journalDirty dirty <- journalDirty
(refs, branches) <- unzip <$> filterM isnewer pairs (refs, branches) <- unzip <$> filterM isnewer pairs
if (not dirty && null refs) if not dirty && null refs
then updateIndex branchref then updateIndex branchref
else withIndex $ lockJournal $ do else withIndex $ lockJournal $ do
when dirty stageJournal when dirty stageJournal
@ -172,7 +172,7 @@ get' staleok file = fromcache =<< getCache file
- modifes the current content of the file on the branch. - modifes the current content of the file on the branch.
-} -}
change :: FilePath -> (String -> String) -> Annex () change :: FilePath -> (String -> String) -> Annex ()
change file a = lockJournal $ getStale file >>= return . a >>= set file change file a = lockJournal $ a <$> getStale file >>= set file
{- Records new content of a file into the journal and cache. -} {- Records new content of a file into the journal and cache. -}
set :: FilePath -> String -> Annex () set :: FilePath -> String -> Annex ()

View file

@ -32,7 +32,7 @@ sshParams (host, port) opts = go =<< sshInfo (host, port)
-- If the lock pool is empty, this is the first ssh of this -- If the lock pool is empty, this is the first ssh of this
-- run. There could be stale ssh connections hanging around -- run. There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted. -- from a previous git-annex run that was interrupted.
cleanstale = whenM (null . filter isLock . M.keys <$> getPool) $ cleanstale = whenM (not . any isLock . M.keys <$> getPool) $
sshCleanup sshCleanup
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
@ -40,9 +40,9 @@ sshInfo (host, port) = do
caching <- Git.configTrue <$> fromRepo (Git.Config.get "annex.sshcaching" "true") caching <- Git.configTrue <$> fromRepo (Git.Config.get "annex.sshcaching" "true")
if caching if caching
then do then do
dir <- fromRepo $ gitAnnexSshDir dir <- fromRepo gitAnnexSshDir
let socketfile = dir </> hostport2socket host port let socketfile = dir </> hostport2socket host port
return $ (Just socketfile, cacheParams socketfile) return (Just socketfile, cacheParams socketfile)
else return (Nothing, []) else return (Nothing, [])
cacheParams :: FilePath -> [CommandParam] cacheParams :: FilePath -> [CommandParam]
@ -58,7 +58,7 @@ portParams (Just port) = [Param "-p", Param $ show port]
{- Stop any unused ssh processes. -} {- Stop any unused ssh processes. -}
sshCleanup :: Annex () sshCleanup :: Annex ()
sshCleanup = do sshCleanup = do
dir <- fromRepo $ gitAnnexSshDir dir <- fromRepo gitAnnexSshDir
liftIO $ createDirectoryIfMissing True dir liftIO $ createDirectoryIfMissing True dir
sockets <- filter (not . isLock) <$> liftIO (dirContents dir) sockets <- filter (not . isLock) <$> liftIO (dirContents dir)
forM_ sockets cleanup forM_ sockets cleanup

View file

@ -60,7 +60,7 @@ genKey file trybackend = do
genKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend)) genKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend))
genKey' [] _ = return Nothing genKey' [] _ = return Nothing
genKey' (b:bs) file = do genKey' (b:bs) file = do
r <- (B.getKey b) file r <- B.getKey b file
case r of case r of
Nothing -> genKey' bs file Nothing -> genKey' bs file
Just k -> return $ Just (makesane k, b) Just k -> return $ Just (makesane k, b)

View file

@ -30,7 +30,7 @@ seek = [withField fromOption Remote.byName $ \from ->
withFilesInGit $ whenAnnexed $ start from] withFilesInGit $ whenAnnexed $ start from]
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
start from file (key, _) = autoCopies file key (>) $ \numcopies -> do start from file (key, _) = autoCopies file key (>) $ \numcopies ->
case from of case from of
Nothing -> startLocal file numcopies key Nothing -> startLocal file numcopies key
Just remote -> do Just remote -> do

View file

@ -36,7 +36,7 @@ seek :: [CommandSeek]
seek = [withField formatOption formatconverter $ \f -> seek = [withField formatOption formatconverter $ \f ->
withFilesInGit $ whenAnnexed $ start f] withFilesInGit $ whenAnnexed $ start f]
where where
formatconverter = return . maybe Nothing (Just . Utility.Format.gen) formatconverter = return . fmap Utility.Format.gen
start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
start format file (key, _) = do start format file (key, _) = do

View file

@ -23,7 +23,7 @@ seek = [withField Command.Move.fromOption Remote.byName $ \from ->
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
start from file (key, _) = stopUnless (not <$> inAnnex key) $ start from file (key, _) = stopUnless (not <$> inAnnex key) $
autoCopies file key (<) $ \_numcopies -> do autoCopies file key (<) $ \_numcopies ->
case from of case from of
Nothing -> go $ perform key Nothing -> go $ perform key
Just src -> do Just src -> do
@ -36,7 +36,7 @@ start from file (key, _) = stopUnless (not <$> inAnnex key) $
next a next a
perform :: Key -> CommandPerform perform :: Key -> CommandPerform
perform key = stopUnless (getViaTmp key $ getKeyFile key) $ do perform key = stopUnless (getViaTmp key $ getKeyFile key) $
next $ return True -- no cleanup needed next $ return True -- no cleanup needed
{- Try to find a copy of the file in one of the remotes, {- Try to find a copy of the file in one of the remotes,

View file

@ -55,7 +55,7 @@ gourceOption :: Option
gourceOption = Option.flag [] "gource" "format output for gource" gourceOption = Option.flag [] "gource" "format output for gource"
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withValue (Remote.uuidDescriptions) $ \m -> seek = [withValue Remote.uuidDescriptions $ \m ->
withValue (liftIO getCurrentTimeZone) $ \zone -> withValue (liftIO getCurrentTimeZone) $ \zone ->
withValue (concat <$> mapM getoption passthruOptions) $ \os -> withValue (concat <$> mapM getoption passthruOptions) $ \os ->
withFlag gourceOption $ \gource -> withFlag gourceOption $ \gource ->
@ -65,7 +65,7 @@ seek = [withValue (Remote.uuidDescriptions) $ \m ->
Annex.getField (Option.name o) Annex.getField (Option.name o)
use o v = [Param ("--" ++ Option.name o), Param v] use o v = [Param ("--" ++ Option.name o), Param v]
start :: (M.Map UUID String) -> TimeZone -> [CommandParam] -> Bool -> start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
FilePath -> (Key, Backend) -> CommandStart FilePath -> (Key, Backend) -> CommandStart
start m zone os gource file (key, _) = do start m zone os gource file (key, _) = do
showLog output =<< readLog <$> getLog key os showLog output =<< readLog <$> getLog key os
@ -91,7 +91,7 @@ showLog outputter ps = do
catObject ref catObject ref
normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter
normalOutput lookupdescription file zone present ts us = do normalOutput lookupdescription file zone present ts us =
liftIO $ mapM_ (putStrLn . format) us liftIO $ mapM_ (putStrLn . format) us
where where
time = showTimeStamp zone ts time = showTimeStamp zone ts
@ -100,7 +100,7 @@ normalOutput lookupdescription file zone present ts us = do
fromUUID u ++ " -- " ++ lookupdescription u ] fromUUID u ++ " -- " ++ lookupdescription u ]
gourceOutput :: (UUID -> String) -> FilePath -> Outputter gourceOutput :: (UUID -> String) -> FilePath -> Outputter
gourceOutput lookupdescription file present ts us = do gourceOutput lookupdescription file present ts us =
liftIO $ mapM_ (putStrLn . intercalate "|" . format) us liftIO $ mapM_ (putStrLn . intercalate "|" . format) us
where where
time = takeWhile isDigit $ show ts time = takeWhile isDigit $ show ts

View file

@ -23,7 +23,7 @@ seek = [withWords start]
start :: [FilePath] -> CommandStart start :: [FilePath] -> CommandStart
start (src:dest:[]) start (src:dest:[])
| src == dest = stop | src == dest = stop
| otherwise = do | otherwise =
ifAnnexed src ifAnnexed src
(error $ "cannot used annexed file as src: " ++ src) (error $ "cannot used annexed file as src: " ++ src)
go go

View file

@ -33,7 +33,7 @@ seek :: CommandSeek
seek rs = do seek rs = do
!branch <- fromMaybe nobranch <$> inRepo Git.Branch.current !branch <- fromMaybe nobranch <$> inRepo Git.Branch.current
remotes <- syncRemotes rs remotes <- syncRemotes rs
return $ concat $ return $ concat
[ [ commit ] [ [ commit ]
, [ mergeLocal branch ] , [ mergeLocal branch ]
, [ pullRemote remote branch | remote <- remotes ] , [ pullRemote remote branch | remote <- remotes ]
@ -137,9 +137,9 @@ pushRemote remote branch = go =<< needpush
showStart "push" (Remote.name remote) showStart "push" (Remote.name remote)
next $ next $ do next $ next $ do
showOutput showOutput
inRepo $ Git.Command.runBool "push" $ inRepo $ Git.Command.runBool "push"
[ Param (Remote.name remote) [ Param (Remote.name remote)
, Param (show $ Annex.Branch.name) , Param (show Annex.Branch.name)
, Param refspec , Param refspec
] ]
refspec = show (Git.Ref.base branch) ++ ":" ++ show (Git.Ref.base syncbranch) refspec = show (Git.Ref.base branch) ++ ":" ++ show (Git.Ref.base syncbranch)

View file

@ -39,7 +39,7 @@ fromOption :: Option
fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content" fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content"
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withNothing $ start] seek = [withNothing start]
{- Finds unused content in the annex. -} {- Finds unused content in the annex. -}
start :: CommandStart start :: CommandStart

View file

@ -22,12 +22,12 @@ seek :: [CommandSeek]
seek = [withValue (remoteMap id) $ \m -> seek = [withValue (remoteMap id) $ \m ->
withFilesInGit $ whenAnnexed $ start m] withFilesInGit $ whenAnnexed $ start m]
start :: (M.Map UUID Remote) -> FilePath -> (Key, Backend) -> CommandStart start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart
start remotemap file (key, _) = do start remotemap file (key, _) = do
showStart "whereis" file showStart "whereis" file
next $ perform remotemap key next $ perform remotemap key
perform :: (M.Map UUID Remote) -> Key -> CommandPerform perform :: M.Map UUID Remote -> Key -> CommandPerform
perform remotemap key = do perform remotemap key = do
locations <- keyLocations key locations <- keyLocations key
(untrustedlocations, safelocations) <- trustPartition UnTrusted locations (untrustedlocations, safelocations) <- trustPartition UnTrusted locations

View file

@ -68,7 +68,7 @@ gitPreCommitHookUnWrite = unlessBare $ do
" Edit it to remove call to git annex." " Edit it to remove call to git annex."
unlessBare :: Annex () -> Annex () unlessBare :: Annex () -> Annex ()
unlessBare = unlessM $ fromRepo $ Git.repoIsLocalBare unlessBare = unlessM $ fromRepo Git.repoIsLocalBare
preCommitHook :: Annex FilePath preCommitHook :: Annex FilePath
preCommitHook = (</>) <$> fromRepo Git.gitDir <*> pure "hooks/pre-commit" preCommitHook = (</>) <$> fromRepo Git.gitDir <*> pure "hooks/pre-commit"

View file

@ -79,7 +79,7 @@ configUnEscape = unescape
num = takeWhile isNumber s num = takeWhile isNumber s
r = drop (length num) s r = drop (length num) s
rest = drop 1 r rest = drop 1 r
ok = not (null num) && take 1 r == ";" ok = not (null num) && ":" `isPrefixOf` r
{- for quickcheck -} {- for quickcheck -}
prop_idempotent_configEscape :: String -> Bool prop_idempotent_configEscape :: String -> Bool

View file

@ -132,7 +132,7 @@ handle json normal = Annex.getState Annex.output >>= go
where where
go Annex.NormalOutput = liftIO normal go Annex.NormalOutput = liftIO normal
go Annex.QuietOutput = q go Annex.QuietOutput = q
go Annex.JSONOutput = liftIO $ flushed $ json go Annex.JSONOutput = liftIO $ flushed json
q :: Monad m => m () q :: Monad m => m ()
q = return () q = return ()

View file

@ -37,7 +37,7 @@ common =
"allow verbose output (default)" "allow verbose output (default)"
, Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput)) , Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput))
"enable JSON output" "enable JSON output"
, Option ['d'] ["debug"] (NoArg (setdebug)) , Option ['d'] ["debug"] (NoArg setdebug)
"show debug messages" "show debug messages"
, Option ['b'] ["backend"] (ReqArg setforcebackend paramName) , Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
"specify key-value backend to use" "specify key-value backend to use"

View file

@ -215,4 +215,4 @@ forceTrust level remotename = do
- key to the remote, or removing the key from it *may* log the change - key to the remote, or removing the key from it *may* log the change
- on the remote, but this cannot always be relied on. -} - on the remote, but this cannot always be relied on. -}
logStatus :: Remote -> Key -> LogStatus -> Annex () logStatus :: Remote -> Key -> LogStatus -> Annex ()
logStatus remote key present = logChange key (uuid remote) present logStatus remote key = logChange key (uuid remote)

View file

@ -94,7 +94,7 @@ gen = filter (not . empty) . fuse [] . scan [] . decode_c
| i < 0 = LeftJustified (-1 * i) | i < 0 = LeftJustified (-1 * i)
| otherwise = RightJustified i | otherwise = RightJustified i
novar v = "${" ++ reverse v novar v = "${" ++ reverse v
foundvar f v p cs = scan (Var (reverse v) p : f) cs foundvar f v p = scan (Var (reverse v) p : f)
empty :: Frag -> Bool empty :: Frag -> Bool
empty (Const "") = True empty (Const "") = True

View file

@ -108,8 +108,7 @@ request url requesttype = go 5 url
(3,0,x) | x /= 5 -> redir (n - 1) u rsp (3,0,x) | x /= 5 -> redir (n - 1) u rsp
_ -> return rsp _ -> return rsp
ignore = const $ return () ignore = const $ return ()
redir n u rsp = do redir n u rsp = case retrieveHeaders HdrLocation rsp of
case retrieveHeaders HdrLocation rsp of
[] -> return rsp [] -> return rsp
(Header _ newu:_) -> (Header _ newu:_) ->
case parseURIReference newu of case parseURIReference newu of