nukes another 15 lines thanks to ifM
This commit is contained in:
parent
ff8b6c1bab
commit
c0c9991c9f
6 changed files with 57 additions and 74 deletions
|
@ -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)
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"]
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue