diff options
author | 2010-10-14 03:50:28 -0400 | |
---|---|---|
committer | 2010-10-14 03:50:28 -0400 | |
commit | 0f12bd16d829432f7b1c2efbba386262ed36fc27 (patch) | |
tree | f205d39ce599d1c25f0ce76b590a604377605a75 /Backend/File.hs | |
parent | 7117702fddf521ed4f3675a91cd87119207eba02 (diff) |
subdir
Diffstat (limited to 'Backend/File.hs')
-rw-r--r-- | Backend/File.hs | 72 |
1 files changed, 72 insertions, 0 deletions
diff --git a/Backend/File.hs b/Backend/File.hs new file mode 100644 index 000000000..107ef3851 --- /dev/null +++ b/Backend/File.hs @@ -0,0 +1,72 @@ +{- git-annex "file" backend + - -} + +module Backend.File (backend) where + +import Control.Monad.State +import System.IO +import System.Cmd +import Control.Exception +import BackendTypes +import LocationLog +import Locations +import qualified Remotes +import qualified GitRepo as Git + +backend = Backend { + name = "file", + getKey = keyValue, + storeFileKey = dummyStore, + retrieveKeyFile = copyKeyFile, + removeKey = dummyRemove +} + +-- direct mapping from filename to key +keyValue :: FilePath -> Annex (Maybe Key) +keyValue file = return $ Just $ Key file + +{- This backend does not really do any independant data storage, + - it relies on the file contents in .git/annex/ in this repo, + - and other accessible repos. So storing or removing a key is + - a no-op. TODO until support is added for git annex --push otherrepo, + - then these could implement that.. -} +dummyStore :: FilePath -> Key -> Annex (Bool) +dummyStore file key = return True +dummyRemove :: Key -> Annex Bool +dummyRemove url = return False + +{- Try to find a copy of the file in one of the remotes, + - and copy it over to this one. -} +copyKeyFile :: Key -> FilePath -> Annex (Bool) +copyKeyFile key file = do + remotes <- Remotes.withKey key + trycopy remotes remotes + where + trycopy full [] = error $ "unable to get: " ++ (keyFile key) ++ "\n" ++ + "To get that file, need access to one of these remotes: " ++ + (Remotes.list full) + trycopy full (r:rs) = do + -- annexLocation needs the git config to have been + -- read for a remote, so do that now, + -- if it hasn't been already + r' <- Remotes.ensureGitConfigRead r + result <- liftIO $ (try (copyFromRemote r' key file)::IO (Either SomeException ())) + case (result) of + Left err -> do + liftIO $ hPutStrLn stderr (show err) + trycopy full rs + Right succ -> return True + +{- Tries to copy a file from a remote, exception on error. -} +copyFromRemote :: Git.Repo -> Key -> FilePath -> IO () +copyFromRemote r key file = do + putStrLn $ "copy from " ++ (Git.repoDescribe r ) ++ " " ++ file + + if (Git.repoIsLocal r) + then getlocal + else getremote + return () + where + getlocal = rawSystem "cp" ["-a", location, file] + getremote = error "get via network not yet implemented!" + location = annexLocation r backend key |