nukes another 15 lines thanks to ifM

This commit is contained in:
Joey Hess 2012-03-15 20:39:25 -04:00
parent ff8b6c1bab
commit c0c9991c9f
6 changed files with 57 additions and 74 deletions

View file

@ -100,11 +100,7 @@ withCheckedFiles _ _ [] _ _ = return False
withCheckedFiles check Nothing d k a = go $ locations d k withCheckedFiles check Nothing d k a = go $ locations d k
where where
go [] = return False go [] = return False
go (f:fs) = do go (f:fs) = ifM (check f) ( a [f] , go fs )
use <- check f
if use
then a [f]
else go fs
withCheckedFiles check (Just _) d k a = go $ locations d k withCheckedFiles check (Just _) d k a = go $ locations d k
where where
go [] = return False go [] = return False
@ -115,10 +111,8 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
then do then do
count <- readcount chunkcount count <- readcount chunkcount
let chunks = take count $ chunkStream f let chunks = take count $ chunkStream f
ok <- all id <$> mapM check chunks ifM (all id <$> mapM check chunks)
if ok ( a chunks , return False )
then a chunks
else return False
else go fs else go fs
readcount f = fromMaybe (error $ "cannot parse " ++ f) readcount f = fromMaybe (error $ "cannot parse " ++ f)
. (readish :: String -> Maybe Int) . (readish :: String -> Maybe Int)

View file

@ -127,10 +127,11 @@ tryGitConfigRead r
Annex.changeState $ \s -> s { Annex.repo = g' } Annex.changeState $ \s -> s { Annex.repo = g' }
exchange [] _ = [] exchange [] _ = []
exchange (old:ls) new = exchange (old:ls) new
if Git.remoteName old == Git.remoteName new | Git.remoteName old == Git.remoteName new =
then new : exchange ls new new : exchange ls new
else old : exchange ls new | otherwise =
old : exchange ls new
{- Checks if a given remote has the content for a key inAnnex. {- Checks if a given remote has the content for a key inAnnex.
- If the remote cannot be accessed, or if it cannot determine - If the remote cannot be accessed, or if it cannot determine
@ -227,11 +228,11 @@ copyFromRemoteCheap r key file
| not $ Git.repoIsUrl r = do | not $ Git.repoIsUrl r = do
loc <- liftIO $ gitAnnexLocation key r loc <- liftIO $ gitAnnexLocation key r
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
| Git.repoIsSsh r = do | Git.repoIsSsh r =
ok <- Annex.Content.preseedTmp key file ifM (Annex.Content.preseedTmp key file)
if ok ( copyFromRemote r key file
then copyFromRemote r key file , return False
else return False )
| otherwise = return False | otherwise = return False
{- Tries to copy a key's content to a remote's annex. -} {- Tries to copy a key's content to a remote's annex. -}
@ -254,22 +255,24 @@ copyToRemote r key
rsyncHelper :: [CommandParam] -> Annex Bool rsyncHelper :: [CommandParam] -> Annex Bool
rsyncHelper p = do rsyncHelper p = do
showOutput -- make way for progress bar showOutput -- make way for progress bar
res <- liftIO $ rsync p ifM (liftIO $ rsync p)
if res ( return True
then return res , do
else do
showLongNote "rsync failed -- run git annex again to resume file transfer" showLongNote "rsync failed -- run git annex again to resume file transfer"
return res return False
)
{- Copys a file with rsync unless both locations are on the same {- Copys a file with rsync unless both locations are on the same
- filesystem. Then cp could be faster. -} - filesystem. Then cp could be faster. -}
rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> Annex Bool rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> Annex Bool
rsyncOrCopyFile rsyncparams src dest = do rsyncOrCopyFile rsyncparams src dest =
ss <- liftIO $ getFileStatus $ parentDir src ifM (sameDeviceIds src dest)
ds <- liftIO $ getFileStatus $ parentDir dest ( liftIO $ copyFileExternal src dest
if deviceID ss == deviceID ds , rsyncHelper $ rsyncparams ++ [Param src, Param dest]
then liftIO $ copyFileExternal src dest )
else rsyncHelper $ rsyncparams ++ [Param src, Param dest] where
sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b)
getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
{- Generates rsync parameters that ssh to the remote and asks it {- Generates rsync parameters that ssh to the remote and asks it
- to either receive or send the key's content. -} - to either receive or send the key's content. -}

View file

@ -84,10 +84,8 @@ runHooks r starthook stophook a = do
liftIO $ closeFd fd liftIO $ closeFd fd
lookupHook :: Remote -> String -> Annex (Maybe String) lookupHook :: Remote -> String -> Annex (Maybe String)
lookupHook r n = do lookupHook r n = go =<< getConfig (repo r) hookname ""
command <- getConfig (repo r) hookname ""
if null command
then return Nothing
else return $ Just command
where where
go "" = return Nothing
go command = return $ Just command
hookname = n ++ "-command" hookname = n ++ "-command"

View file

@ -89,13 +89,13 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
where where
run command = do run command = do
showOutput -- make way for hook output showOutput -- make way for hook output
res <- liftIO $ boolSystemEnv ifM (liftIO $ boolSystemEnv
"sh" [Param "-c", Param command] $ hookEnv k f "sh" [Param "-c", Param command] $ hookEnv k f)
if res ( a
then a , do
else do
warning $ hook ++ " hook exited nonzero!" warning $ hook ++ " hook exited nonzero!"
return res return False
)
store :: String -> Key -> Annex Bool store :: String -> Key -> Annex Bool
store h k = do store h k = do

View file

@ -113,20 +113,16 @@ retrieve o k f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
] ]
retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
retrieveCheap o k f = do retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k f , return False )
ok <- preseedTmp k f
if ok
then retrieve o k f
else return False
retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> do retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> do
res <- retrieve o enck tmp ifM (retrieve o enck tmp)
if res ( liftIO $ catchBoolIO $ do
then liftIO $ catchBoolIO $ do
withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
return True return True
else return res , return False
)
remove :: RsyncOpts -> Key -> Annex Bool remove :: RsyncOpts -> Key -> Annex Bool
remove o k = withRsyncScratchDir $ \tmp -> liftIO $ do remove o k = withRsyncScratchDir $ \tmp -> liftIO $ do
@ -188,12 +184,12 @@ withRsyncScratchDir a = do
rsyncRemote :: RsyncOpts -> [CommandParam] -> Annex Bool rsyncRemote :: RsyncOpts -> [CommandParam] -> Annex Bool
rsyncRemote o params = do rsyncRemote o params = do
showOutput -- make way for progress bar showOutput -- make way for progress bar
res <- liftIO $ rsync $ rsyncOptions o ++ defaultParams ++ params ifM (liftIO $ rsync $ rsyncOptions o ++ defaultParams ++ params)
if res ( return True
then return res , do
else do
showLongNote "rsync failed -- run git annex again to resume file transfer" showLongNote "rsync failed -- run git annex again to resume file transfer"
return res return False
)
where where
defaultParams = [Params "--progress"] defaultParams = [Params "--progress"]

View file

@ -14,15 +14,10 @@ module Utility.Url (
get get
) where ) where
import Control.Applicative import Common
import Control.Monad
import qualified Network.Browser as Browser import qualified Network.Browser as Browser
import Network.HTTP import Network.HTTP
import Network.URI import Network.URI
import Data.Maybe
import Utility.SafeCommand
import Utility.Path
type URLString = String type URLString = String
@ -47,7 +42,7 @@ exists url =
(2,_,_) -> return (True, size r) (2,_,_) -> return (True, size r)
_ -> return (False, Nothing) _ -> return (False, Nothing)
where where
size = liftM read . lookupHeader HdrContentLength . rspHeaders size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
canDownload :: IO Bool canDownload :: IO Bool
canDownload = (||) <$> inPath "wget" <*> inPath "curl" canDownload = (||) <$> inPath "wget" <*> inPath "curl"
@ -60,20 +55,17 @@ canDownload = (||) <$> inPath "wget" <*> inPath "curl"
- for only one in. - for only one in.
-} -}
download :: URLString -> [CommandParam] -> FilePath -> IO Bool download :: URLString -> [CommandParam] -> FilePath -> IO Bool
download url options file = do download url options file = ifM (inPath "wget") (wget , curl)
e <- inPath "wget"
if e
then
go "wget" [Params "-c -O", File file, File url]
else
-- Uses the -# progress display, because the normal
-- one is very confusing when resuming, showing
-- the remainder to download as the whole file,
-- and not indicating how much percent was
-- downloaded before the resume.
go "curl" [Params "-L -C - -# -o", File file, File url]
where where
go cmd opts = boolSystem cmd (options++opts) wget = go "wget" [Params "-c -O"]
{- Uses the -# progress display, because the normal
- one is very confusing when resuming, showing
- the remainder to download as the whole file,
- and not indicating how much percent was
- downloaded before the resume. -}
curl = go "curl" [Params "-L -C - -# -o"]
go cmd opts = boolSystem cmd $
options++opts++[File file, File url]
{- Downloads a small file. -} {- Downloads a small file. -}
get :: URLString -> IO String get :: URLString -> IO String