This commit is contained in:
Joey Hess 2010-10-14 03:50:28 -04:00
parent 7117702fdd
commit 0f12bd16d8
4 changed files with 11 additions and 11 deletions

18
Backend/Checksum.hs Normal file
View file

@ -0,0 +1,18 @@
{- git-annex "checksum" backend
- -}
module Backend.Checksum (backend) where
import qualified Backend.File
import Data.Digest.Pure.SHA
import BackendTypes
-- based on BackendFile just with a different key type
backend = Backend.File.backend {
name = "checksum",
getKey = keyValue
}
-- checksum the file to get its key
keyValue :: FilePath -> Annex (Maybe Key)
keyValue k = error "checksum keyValue unimplemented" -- TODO

72
Backend/File.hs Normal file
View file

@ -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

35
Backend/Url.hs Normal file
View file

@ -0,0 +1,35 @@
{- git-annex "url" backend
- -}
module Backend.Url (backend) where
import Control.Monad.State
import System.Cmd
import IO
import BackendTypes
backend = Backend {
name = "url",
getKey = keyValue,
storeFileKey = dummyStore,
retrieveKeyFile = downloadUrl,
removeKey = dummyRemove
}
-- cannot generate url from filename
keyValue :: FilePath -> Annex (Maybe Key)
keyValue file = return Nothing
-- cannot change url contents
dummyStore :: FilePath -> Key -> Annex Bool
dummyStore file url = return False
dummyRemove :: Key -> Annex Bool
dummyRemove url = return False
downloadUrl :: Key -> FilePath -> Annex Bool
downloadUrl url file = do
liftIO $ putStrLn $ "download: " ++ (show url)
result <- liftIO $ try $ rawSystem "curl" ["-#", "-o", file, (show url)]
case (result) of
Left _ -> return False
Right _ -> return True