copying almost working
This commit is contained in:
parent
e28ff5bdaf
commit
f87c5ed949
4 changed files with 44 additions and 24 deletions
10
Annex.hs
10
Annex.hs
|
@ -64,8 +64,8 @@ annexFile state file = inBackend file err $ do
|
|||
else return ()
|
||||
setup key backend = do
|
||||
logStatus state key ValuePresent
|
||||
let dest = annexLocation state backend key
|
||||
let reldest = annexLocationRelative state backend key
|
||||
let dest = annexLocation (repo state) backend key
|
||||
let reldest = annexLocationRelative (repo state) backend key
|
||||
createDirectoryIfMissing True (parentDir dest)
|
||||
renameFile file dest
|
||||
createSymbolicLink ((linkTarget file) ++ reldest) file
|
||||
|
@ -94,7 +94,7 @@ unannexFile state file = notinBackend file err $ \(key, backend) -> do
|
|||
-- git rm deletes empty directories;
|
||||
-- put them back
|
||||
createDirectoryIfMissing True (parentDir file)
|
||||
let src = annexLocation state backend key
|
||||
let src = annexLocation (repo state) backend key
|
||||
renameFile src file
|
||||
return ()
|
||||
where
|
||||
|
@ -107,7 +107,7 @@ annexGetFile state file = notinBackend file err $ \(key, backend) -> do
|
|||
if (inannex)
|
||||
then return ()
|
||||
else do
|
||||
let dest = annexLocation state backend key
|
||||
let dest = annexLocation (repo state) backend key
|
||||
createDirectoryIfMissing True (parentDir dest)
|
||||
success <- retrieveFile state backend key dest
|
||||
if (success)
|
||||
|
@ -166,4 +166,4 @@ logStatus state key status = do
|
|||
|
||||
{- Checks if a given key is currently present in the annexLocation -}
|
||||
inAnnex :: State -> Backend -> Key -> IO Bool
|
||||
inAnnex state backend key = doesFileExist $ annexLocation state backend key
|
||||
inAnnex state backend key = doesFileExist $ annexLocation (repo state) backend key
|
||||
|
|
|
@ -3,6 +3,9 @@
|
|||
|
||||
module BackendFile (backend) where
|
||||
|
||||
import System.IO
|
||||
import System.Cmd
|
||||
import Control.Exception
|
||||
import Types
|
||||
import LocationLog
|
||||
import Locations
|
||||
|
@ -45,12 +48,30 @@ copyKeyFile state key file = do
|
|||
"To get that file, need access to one of these remotes: " ++
|
||||
(remotesList full)
|
||||
trycopy full (r:rs) = do
|
||||
ok <- copyFromRemote r key file
|
||||
if (ok)
|
||||
then return True
|
||||
else trycopy full rs
|
||||
putStrLn "trying a remote"
|
||||
result <- try (copyFromRemote r key file)::IO (Either SomeException ())
|
||||
case (result) of
|
||||
Left err -> do
|
||||
showerr err r
|
||||
trycopy full rs
|
||||
Right succ -> return True
|
||||
showerr err r = do
|
||||
hPutStrLn stderr $ "git-annex: copy from " ++
|
||||
(gitRepoDescribe r ) ++ " failed: " ++
|
||||
(show err)
|
||||
|
||||
{- Tries to copy a file from a remote. -}
|
||||
copyFromRemote :: GitRepo -> Key -> FilePath -> IO (Bool)
|
||||
{- Tries to copy a file from a remote, exception on error. -}
|
||||
copyFromRemote :: GitRepo -> Key -> FilePath -> IO ()
|
||||
copyFromRemote r key file = do
|
||||
return False -- TODO
|
||||
r <- if (gitRepoIsLocal r)
|
||||
then getlocal
|
||||
else getremote
|
||||
return ()
|
||||
where
|
||||
getlocal = do
|
||||
putStrLn $ "get: " ++ location
|
||||
rawSystem "cp" ["-a", location, file]
|
||||
getremote = do
|
||||
putStrLn $ "get: " ++ location
|
||||
error "get via network not yet implemented!"
|
||||
location = annexLocation r backend key
|
||||
|
|
20
Locations.hs
20
Locations.hs
|
@ -21,18 +21,18 @@ gitStateDir :: GitRepo -> FilePath
|
|||
gitStateDir repo = (gitWorkTree repo) ++ "/" ++ stateLoc ++ "/"
|
||||
|
||||
{- An annexed file's content is stored in
|
||||
- .git/annex/<backend>/<key> ; this allows deriving the key and backend
|
||||
- by looking at the symlink to it. -}
|
||||
annexLocation :: State -> Backend -> Key -> FilePath
|
||||
annexLocation state backend key =
|
||||
(gitWorkTree $ repo state) ++ "/" ++
|
||||
(annexLocationRelative state backend key)
|
||||
- /path/to/repo/.git/annex/<backend>/<key>
|
||||
-
|
||||
- (That allows deriving the key and backend by looking at the symlink to it.)
|
||||
-}
|
||||
annexLocation :: GitRepo -> Backend -> Key -> FilePath
|
||||
annexLocation r backend key =
|
||||
(gitWorkTree r) ++ "/" ++ (annexLocationRelative r backend key)
|
||||
|
||||
{- Annexed file's location relative to the gitWorkTree -}
|
||||
annexLocationRelative :: State -> Backend -> Key -> FilePath
|
||||
annexLocationRelative state backend key =
|
||||
gitDir (repo state) ++ "/annex/" ++ (name backend) ++
|
||||
"/" ++ (keyFile key)
|
||||
annexLocationRelative :: GitRepo -> Backend -> Key -> FilePath
|
||||
annexLocationRelative r backend key =
|
||||
gitDir r ++ "/annex/" ++ (name backend) ++ "/" ++ (keyFile key)
|
||||
|
||||
{- Converts a key into a filename fragment.
|
||||
-
|
||||
|
|
|
@ -32,6 +32,5 @@ tryRun errnum oknum (a:as) = do
|
|||
{- Exception pretty-printing. -}
|
||||
showErr :: SomeException -> IO ()
|
||||
showErr e = do
|
||||
let err = show e
|
||||
hPutStrLn stderr $ "git-annex: " ++ err
|
||||
hPutStrLn stderr $ "git-annex: " ++ (show e)
|
||||
return ()
|
||||
|
|
Loading…
Reference in a new issue