This commit is contained in:
Joey Hess 2012-06-12 11:32:06 -04:00
parent 85f0992c03
commit 942d8f7298
14 changed files with 20 additions and 21 deletions

View file

@ -68,7 +68,7 @@ siblingBranches = inRepo $ Git.Ref.matchingUniq name
{- Creates the branch, if it does not already exist. -} {- Creates the branch, if it does not already exist. -}
create :: Annex () create :: Annex ()
create = void $ getBranch create = void getBranch
{- Returns the ref of the branch, creating it first if necessary. -} {- Returns the ref of the branch, creating it first if necessary. -}
getBranch :: Annex Git.Ref getBranch :: Annex Git.Ref

View file

@ -87,7 +87,7 @@ lockContent key a = do
- to fiddle with permissions to open for an exclusive lock. -} - to fiddle with permissions to open for an exclusive lock. -}
openforlock f = catchMaybeIO $ ifM (doesFileExist f) openforlock f = catchMaybeIO $ ifM (doesFileExist f)
( withModifiedFileMode f ( withModifiedFileMode f
(\cur -> cur `unionFileModes` ownerWriteMode) (`unionFileModes` ownerWriteMode)
open open
, open , open
) )

View file

@ -22,7 +22,7 @@ seek = [withNothing start]
start :: CommandStart start :: CommandStart
start = next $ next $ do start = next $ next $ do
Annex.Branch.commit "update" Annex.Branch.commit "update"
_ <- runhook =<< (inRepo $ Git.hookPath "annex-content") _ <- runhook =<< inRepo (Git.hookPath "annex-content")
return True return True
where where
runhook (Just hook) = liftIO $ boolSystem hook [] runhook (Just hook) = liftIO $ boolSystem hook []

View file

@ -145,13 +145,13 @@ fixLink key file = do
-} -}
whenM (liftIO $ doesFileExist file) $ whenM (liftIO $ doesFileExist file) $
unlessM (inAnnex key) $ do unlessM (inAnnex key) $ do
showNote $ "fixing content location" showNote "fixing content location"
dir <- liftIO $ parentDir <$> absPath file dir <- liftIO $ parentDir <$> absPath file
let content = absPathFrom dir have let content = absPathFrom dir have
liftIO $ allowWrite (parentDir content) liftIO $ allowWrite (parentDir content)
moveAnnex key content moveAnnex key content
showNote $ "fixing link" showNote "fixing link"
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ removeFile file liftIO $ removeFile file
liftIO $ createSymbolicLink want file liftIO $ createSymbolicLink want file
@ -220,7 +220,7 @@ checkKeySize' key file bad = case Types.Key.keySize key of
Nothing -> return True Nothing -> return True
Just size -> do Just size -> do
size' <- fromIntegral . fileSize size' <- fromIntegral . fileSize
<$> (liftIO $ getFileStatus file) <$> liftIO (getFileStatus file)
comparesizes size size' comparesizes size size'
where where
comparesizes a b = do comparesizes a b = do

View file

@ -26,7 +26,7 @@ start from file (key, _) = stopUnless (not <$> inAnnex key) $
autoCopies file key (<) $ \_numcopies -> autoCopies file key (<) $ \_numcopies ->
case from of case from of
Nothing -> go $ perform key Nothing -> go $ perform key
Just src -> do Just src ->
-- get --from = copy --from -- get --from = copy --from
stopUnless (Command.Move.fromOk src key) $ stopUnless (Command.Move.fromOk src key) $
go $ Command.Move.fromPerform src False key go $ Command.Move.fromPerform src False key

View file

@ -128,9 +128,9 @@ fromOk src key
expensive = do expensive = do
u <- getUUID u <- getUUID
remotes <- Remote.keyPossibilities key remotes <- Remote.keyPossibilities key
return $ u /= Remote.uuid src && any (== src) remotes return $ u /= Remote.uuid src && elem src remotes
fromPerform :: Remote -> Bool -> Key -> CommandPerform fromPerform :: Remote -> Bool -> Key -> CommandPerform
fromPerform src move key = moveLock move key $ do fromPerform src move key = moveLock move key $
ifM (inAnnex key) ifM (inAnnex key)
( handle move True ( handle move True
, do , do

View file

@ -28,8 +28,8 @@ check = do
"cannot uninit when the " ++ show b ++ " branch is checked out" "cannot uninit when the " ++ show b ++ " branch is checked out"
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
cwd <- liftIO getCurrentDirectory cwd <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ error $ whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $
"can only run uninit from the top of the git repository" error "can only run uninit from the top of the git repository"
where where
current_branch = Git.Ref . Prelude.head . lines <$> revhead current_branch = Git.Ref . Prelude.head . lines <$> revhead
revhead = inRepo $ Git.Command.pipeRead revhead = inRepo $ Git.Command.pipeRead

View file

@ -176,7 +176,7 @@ runHandler :: MVar Annex.AnnexState -> ChangeChan -> Handler -> FilePath -> IO (
runHandler st changechan handler file = void $ do runHandler st changechan handler file = void $ do
r <- tryIO (runStateMVar st $ handler file) r <- tryIO (runStateMVar st $ handler file)
case r of case r of
Left e -> putStrLn $ show e Left e -> print e
Right Nothing -> noop Right Nothing -> noop
Right (Just change) -> void $ Right (Just change) -> void $
runChangeChan $ writeTChan changechan change runChangeChan $ writeTChan changechan change
@ -236,7 +236,7 @@ onAddSymlink file = go =<< Backend.lookupFile file
- So for speed, tries to reuse the existing blob for - So for speed, tries to reuse the existing blob for
- the symlink target. -} - the symlink target. -}
addlink link = do addlink link = do
v <- catObjectDetails $ Ref $ ":" ++ file v <- catObjectDetails $ Ref $ ':':file
case v of case v of
Just (currlink, sha) Just (currlink, sha)
| s2w8 link == L.unpack currlink -> | s2w8 link == L.unpack currlink ->
@ -307,7 +307,7 @@ commitThread st changechan = forever $ do
-- Now see if now's a good time to commit. -- Now see if now's a good time to commit.
time <- getCurrentTime time <- getCurrentTime
if shouldCommit time cs if shouldCommit time cs
then void $ tryIO $ runStateMVar st $ commitStaged then void $ tryIO $ runStateMVar st commitStaged
else refillChanges changechan cs else refillChanges changechan cs
where where
oneSecond = 1000000 -- microseconds oneSecond = 1000000 -- microseconds

View file

@ -37,7 +37,7 @@ perform remotemap key = do
unless (null safelocations) $ showLongNote pp unless (null safelocations) $ showLongNote pp
pp' <- prettyPrintUUIDs "untrusted" untrustedlocations pp' <- prettyPrintUUIDs "untrusted" untrustedlocations
unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp' unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'
forM_ (catMaybes $ map (`M.lookup` remotemap) locations) $ forM_ (mapMaybe (`M.lookup` remotemap) locations) $
performRemote key performRemote key
if null safelocations then stop else next $ return True if null safelocations then stop else next $ return True
where where

View file

@ -114,6 +114,6 @@ getDiskReserve = fromMaybe megabyte . readSize dataUnits
getHttpHeaders :: Annex [String] getHttpHeaders :: Annex [String]
getHttpHeaders = do getHttpHeaders = do
cmd <- getConfig (annexConfig "http-headers-command") "" cmd <- getConfig (annexConfig "http-headers-command") ""
if (null cmd) if null cmd
then fromRepo $ Git.Config.getList "annex.http-headers" then fromRepo $ Git.Config.getList "annex.http-headers"
else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd]) else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd])

View file

@ -138,7 +138,7 @@ withDecryptedContent = pass withDecryptedHandle
pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a)
-> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
pass to n s a = to n s $ \h -> a =<< L.hGetContents h pass to n s a = to n s $ a <=< L.hGetContents
hmacWithCipher :: Cipher -> String -> String hmacWithCipher :: Cipher -> String -> String
hmacWithCipher c = hmacWithCipher' (cipherHmac c) hmacWithCipher c = hmacWithCipher' (cipherHmac c)

View file

@ -165,7 +165,7 @@ gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"
{- Checks a symlink target to see if it appears to point to annexed content. -} {- Checks a symlink target to see if it appears to point to annexed content. -}
isLinkToAnnex :: FilePath -> Bool isLinkToAnnex :: FilePath -> Bool
isLinkToAnnex s = ("/" ++ d) `isInfixOf` s || d `isPrefixOf` s isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s
where where
d = ".git" </> objectDir d = ".git" </> objectDir

View file

@ -183,7 +183,7 @@ setupConsole = do
fileEncoding stderr fileEncoding stderr
handle :: IO () -> IO () -> Annex () handle :: IO () -> IO () -> Annex ()
handle json normal = withOutputType $ go handle json normal = withOutputType go
where where
go NormalOutput = liftIO normal go NormalOutput = liftIO normal
go QuietOutput = q go QuietOutput = q

View file

@ -10,12 +10,11 @@ module Utility.Directory where
import System.IO.Error import System.IO.Error
import System.Posix.Files import System.Posix.Files
import System.Directory import System.Directory
import Control.Exception (throw) import Control.Exception (throw, bracket_)
import Control.Monad import Control.Monad
import Control.Monad.IfElse import Control.Monad.IfElse
import System.FilePath import System.FilePath
import Control.Applicative import Control.Applicative
import Control.Exception (bracket_)
import System.Posix.Directory import System.Posix.Directory
import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Unsafe (unsafeInterleaveIO)