update
This commit is contained in:
parent
f4d2a05e86
commit
cc23519235
6 changed files with 79 additions and 30 deletions
55
Backend.hs
55
Backend.hs
|
@ -18,24 +18,60 @@
|
||||||
|
|
||||||
module Backend where
|
module Backend where
|
||||||
|
|
||||||
import GitRepo
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
import GitRepo
|
||||||
|
import Utility
|
||||||
|
|
||||||
|
type Key = String
|
||||||
|
|
||||||
data Backend = Backend {
|
data Backend = Backend {
|
||||||
name :: String, -- name of this backend
|
-- name of this backend
|
||||||
keyvalue :: FilePath -> Maybe String, -- maps from key to value
|
name :: String,
|
||||||
retrievekey :: IO String -> IO (Bool) -- retrieves value given key
|
-- converts a filename to a key
|
||||||
|
getKey :: FilePath -> IO (Maybe Key),
|
||||||
|
-- stores a file's contents to a key
|
||||||
|
storeFileKey :: FilePath -> Key -> IO (Bool),
|
||||||
|
-- retrieves a key's contents to a file
|
||||||
|
retrieveKeyFile :: IO Key -> FilePath -> IO (Bool)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
instance Show Backend where
|
||||||
|
show backend = "Backend { name =\"" ++ (name backend) ++ "\" }"
|
||||||
|
|
||||||
{- Name of state file that holds the key for an annexed file,
|
{- Name of state file that holds the key for an annexed file,
|
||||||
- using a given backend. -}
|
- using a given backend. -}
|
||||||
backendFile :: Backend -> GitRepo -> FilePath -> String
|
backendFile :: Backend -> GitRepo -> FilePath -> String
|
||||||
backendFile backend repo file = gitStateDir repo ++
|
backendFile backend repo file = gitStateDir repo ++
|
||||||
(gitRelative repo file) ++ "." ++ (name backend)
|
(gitRelative repo file) ++ "." ++ (name backend)
|
||||||
|
|
||||||
|
{- Attempts to Stores a file in one of the backends. -}
|
||||||
|
storeFile :: [Backend] -> GitRepo -> FilePath -> IO (Bool)
|
||||||
|
storeFile [] _ _ = return False
|
||||||
|
storeFile (b:bs) repo file = do
|
||||||
|
try <- (getKey b) (gitRelative repo file)
|
||||||
|
case (try) of
|
||||||
|
Nothing -> storeFile bs repo file
|
||||||
|
Just key -> do
|
||||||
|
(storeFileKey b) file key
|
||||||
|
createDirectoryIfMissing True (parentDir backendfile)
|
||||||
|
writeFile backendfile key
|
||||||
|
return True
|
||||||
|
where backendfile = backendFile b repo file
|
||||||
|
|
||||||
|
{- Attempts to retrieve an file from one of the backends, saving it to
|
||||||
|
- a specified location. -}
|
||||||
|
retrieveFile :: [Backend] -> GitRepo -> FilePath -> FilePath -> IO (Bool)
|
||||||
|
retrieveFile backends repo file dest = do
|
||||||
|
result <- lookupBackend backends repo file
|
||||||
|
case (result) of
|
||||||
|
Nothing -> return False
|
||||||
|
Just b -> (retrieveKeyFile b) key dest
|
||||||
|
where
|
||||||
|
key = readFile (backendFile b repo file)
|
||||||
|
|
||||||
{- Looks up the backend used for an already annexed file. -}
|
{- Looks up the backend used for an already annexed file. -}
|
||||||
lookupBackend :: [Backend] -> GitRepo -> FilePath -> IO (Maybe Backend)
|
lookupBackend :: [Backend] -> GitRepo -> FilePath -> IO (Maybe Backend)
|
||||||
lookupBackend [] repo file = return Nothing
|
lookupBackend [] _ _ = return Nothing
|
||||||
lookupBackend (b:bs) repo file = do
|
lookupBackend (b:bs) repo file = do
|
||||||
present <- checkBackend b repo file
|
present <- checkBackend b repo file
|
||||||
if present
|
if present
|
||||||
|
@ -47,12 +83,3 @@ lookupBackend (b:bs) repo file = do
|
||||||
{- Checks if a file is available via a given backend. -}
|
{- Checks if a file is available via a given backend. -}
|
||||||
checkBackend :: Backend -> GitRepo -> FilePath -> IO (Bool)
|
checkBackend :: Backend -> GitRepo -> FilePath -> IO (Bool)
|
||||||
checkBackend backend repo file = doesFileExist $ backendFile backend repo file
|
checkBackend backend repo file = doesFileExist $ backendFile backend repo file
|
||||||
|
|
||||||
{- Attempts to retrieve an annexed file from one of the backends. -}
|
|
||||||
retrieveFile :: [Backend] -> GitRepo -> FilePath -> IO (Bool)
|
|
||||||
retrieveFile backends repo file = do
|
|
||||||
result <- lookupBackend backends repo file
|
|
||||||
case (result) of
|
|
||||||
Nothing -> return False
|
|
||||||
Just b -> (retrievekey b) key
|
|
||||||
where key = readFile (backendFile b repo file)
|
|
||||||
|
|
|
@ -7,11 +7,18 @@ import Backend
|
||||||
|
|
||||||
backend = Backend {
|
backend = Backend {
|
||||||
name = "file",
|
name = "file",
|
||||||
keyvalue = keyValue,
|
getKey = keyValue,
|
||||||
retrievekey = copyFile
|
storeFileKey = moveToAnnex,
|
||||||
|
retrieveKeyFile = copyFromOtherRepo
|
||||||
}
|
}
|
||||||
|
|
||||||
-- direct mapping from filename to key
|
-- direct mapping from filename to key
|
||||||
keyValue k = Just $ id k
|
keyValue :: FilePath -> IO (Maybe Key)
|
||||||
|
keyValue k = return $ Just $ id k
|
||||||
|
|
||||||
|
moveToAnnex :: FilePath -> Key -> IO (Bool)
|
||||||
|
moveToAnnex file key = return False
|
||||||
|
|
||||||
|
copyFromOtherRepo :: IO Key -> FilePath -> IO (Bool)
|
||||||
|
copyFromOtherRepo key file = return False
|
||||||
|
|
||||||
copyFile f = error "unimplemented"
|
|
||||||
|
|
|
@ -7,11 +7,18 @@ import Backend
|
||||||
|
|
||||||
backend = Backend {
|
backend = Backend {
|
||||||
name = "url",
|
name = "url",
|
||||||
keyvalue = keyValue,
|
getKey = keyValue,
|
||||||
retrievekey = downloadUrl
|
storeFileKey = dummyStore,
|
||||||
|
retrieveKeyFile = downloadUrl
|
||||||
}
|
}
|
||||||
|
|
||||||
-- cannot generate url from filename
|
-- cannot generate url from filename
|
||||||
keyValue k = Nothing
|
keyValue :: FilePath -> IO (Maybe Key)
|
||||||
|
keyValue k = return Nothing
|
||||||
|
|
||||||
downloadUrl k = error "unimplemented"
|
-- cannot store to urls
|
||||||
|
dummyStore :: FilePath -> Key -> IO (Bool)
|
||||||
|
dummyStore file url = return False
|
||||||
|
|
||||||
|
downloadUrl :: IO Key -> FilePath -> IO (Bool)
|
||||||
|
downloadUrl url file = error "unimplemented"
|
||||||
|
|
11
GitRepo.hs
11
GitRepo.hs
|
@ -57,15 +57,22 @@ gitPrep repo = do
|
||||||
attributes <- gitAttributes repo
|
attributes <- gitAttributes repo
|
||||||
exists <- doesFileExist attributes
|
exists <- doesFileExist attributes
|
||||||
if (not exists)
|
if (not exists)
|
||||||
then writeFile attributes $ attrLine ++ "\n"
|
then do
|
||||||
|
writeFile attributes $ attrLine ++ "\n"
|
||||||
|
gitAdd repo attributes
|
||||||
else do
|
else do
|
||||||
content <- readFile attributes
|
content <- readFile attributes
|
||||||
if (all (/= attrLine) (lines content))
|
if (all (/= attrLine) (lines content))
|
||||||
then do
|
then do
|
||||||
appendFile attributes $ attrLine ++ "\n"
|
appendFile attributes $ attrLine ++ "\n"
|
||||||
-- TODO check attributes file into git?
|
gitAdd repo attributes
|
||||||
else return ()
|
else return ()
|
||||||
|
|
||||||
|
{- Stages a changed file in git's index. -}
|
||||||
|
gitAdd repo file = do
|
||||||
|
-- TODO
|
||||||
|
return ()
|
||||||
|
|
||||||
{- Finds the top of the current git repository, which may be in a parent
|
{- Finds the top of the current git repository, which may be in a parent
|
||||||
- directory. -}
|
- directory. -}
|
||||||
repoTop :: IO GitRepo
|
repoTop :: IO GitRepo
|
||||||
|
|
|
@ -84,6 +84,7 @@ appendLog file line = do
|
||||||
createDirectoryIfMissing True (parentDir file)
|
createDirectoryIfMissing True (parentDir file)
|
||||||
withFileLocked file AppendMode $ \h ->
|
withFileLocked file AppendMode $ \h ->
|
||||||
hPutStrLn h $ show line
|
hPutStrLn h $ show line
|
||||||
|
-- TODO git add log
|
||||||
|
|
||||||
{- Writes a set of lines to a log file -}
|
{- Writes a set of lines to a log file -}
|
||||||
writeLog :: FilePath -> [LogLine] -> IO ()
|
writeLog :: FilePath -> [LogLine] -> IO ()
|
||||||
|
@ -99,17 +100,16 @@ logNow status repo = do
|
||||||
return $ LogLine now status repo
|
return $ LogLine now status repo
|
||||||
|
|
||||||
{- Returns the filename of the log file for a given annexed file. -}
|
{- Returns the filename of the log file for a given annexed file. -}
|
||||||
logFile :: FilePath -> IO String
|
logFile :: GitRepo -> FilePath -> IO String
|
||||||
logFile annexedFile = do
|
logFile repo annexedFile = do
|
||||||
repo <- repoTop
|
|
||||||
return $ (gitStateDir repo) ++
|
return $ (gitStateDir repo) ++
|
||||||
(gitRelative repo annexedFile) ++ ".log"
|
(gitRelative repo annexedFile) ++ ".log"
|
||||||
|
|
||||||
{- Returns a list of repositories that, according to the log, have
|
{- Returns a list of repositories that, according to the log, have
|
||||||
- the content of a file -}
|
- the content of a file -}
|
||||||
fileLocations :: FilePath -> IO [String]
|
fileLocations :: GitRepo -> FilePath -> IO [String]
|
||||||
fileLocations file = do
|
fileLocations thisrepo file = do
|
||||||
log <- logFile file
|
log <- logFile thisrepo file
|
||||||
lines <- readLog log
|
lines <- readLog log
|
||||||
return $ map repo (filterPresent lines)
|
return $ map repo (filterPresent lines)
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import GitRepo
|
import GitRepo
|
||||||
import Backend
|
import Backend
|
||||||
|
import Annex
|
||||||
|
|
||||||
-- When adding a new backend, import it here and add it to the backends list.
|
-- When adding a new backend, import it here and add it to the backends list.
|
||||||
import qualified BackendFile
|
import qualified BackendFile
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue