mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

use safesystem

Browse source
This commit is contained in:
Joey Hess 2010-10-19 01:19:56 -04:00
parent 15986f01d1
commit c7664588f8
4 changed files with 10 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
Backend/File.hs
View file

@ -13,6 +13,7 @@ module Backend.File (backend) where
import Control.Monad.State import Control.Monad.State
import System.IO import System.IO
import System.Cmd import System.Cmd
import System.Cmd.Utils
import System.Exit import System.Exit
import Control.Exception import Control.Exception
@ -92,11 +93,7 @@ copyFromRemote r key file = do
then getlocal then getlocal
else getremote else getremote
where where
getlocal = do getlocal = safeSystem "cp" ["-a", location, file]
res <-rawSystem "cp" ["-a", location, file]
if (res == ExitSuccess)
then return ()
else error "cp failed"
getremote = error "get via network not yet implemented!" getremote = error "get via network not yet implemented!"
location = annexLocation r key location = annexLocation r key

11
Backend/URL.hs
View file

@ -3,9 +3,11 @@
module Backend.URL (backend) where module Backend.URL (backend) where
import Control.Exception
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import Data.String.Utils import Data.String.Utils
import System.Cmd import System.Cmd
import System.Cmd.Utils
import System.Exit import System.Exit
import TypeInternals import TypeInternals
@ -36,9 +38,10 @@ downloadUrl :: Key -> FilePath -> Annex Bool
downloadUrl key file = do downloadUrl key file = do
showNote "downloading" showNote "downloading"
liftIO $ putStrLn "" -- make way for curl progress bar liftIO $ putStrLn "" -- make way for curl progress bar
result <- liftIO $ rawSystem "curl" ["-#", "-o", file, url] result <- liftIO $ (try curl::IO (Either SomeException ()))
if (result == ExitSuccess) case result of
then return True Left err -> return False
else return False Right succ -> return True
where where
curl = safeSystem "curl" ["-#", "-o", file, url]
url = join ":" $ drop 1 $ split ":" $ show key url = join ":" $ drop 1 $ split ":" $ show key

2
GitRepo.hs
View file

@ -167,7 +167,7 @@ gitCommandLine repo params = assertlocal repo $
{- Runs git in the specified repo. -} {- Runs git in the specified repo. -}
run :: Repo -> [String] -> IO () run :: Repo -> [String] -> IO ()
run repo params = assertlocal repo $ do run repo params = assertlocal repo $ do
r <- rawSystem "git" (gitCommandLine repo params) r <- safeSystem "git" (gitCommandLine repo params)
return () return ()
{- Runs a git subcommand and returns its output. -} {- Runs a git subcommand and returns its output. -}

3
TODO
View file

@ -4,9 +4,6 @@
* bug: doesn't learn new remote's uuids if a known (but maybe not accessible) * bug: doesn't learn new remote's uuids if a known (but maybe not accessible)
uuids has a wanted file uuids has a wanted file
* bug: ctrl+c does not stop it from running another action; need to
not catch UserInterrupt exceptions.
* --push/--pull should take a reponame and files, and push those files * --push/--pull should take a reponame and files, and push those files
to that repo; dropping them from the current repo to that repo; dropping them from the current repo