update
This commit is contained in:
parent
93d2dc0d68
commit
344f13394f
7 changed files with 65 additions and 22 deletions
30
Annex.hs
30
Annex.hs
|
@ -44,14 +44,30 @@ annexFile state file = do
|
||||||
gitAdd (repo state) file
|
gitAdd (repo state) file
|
||||||
checkExists file = do
|
checkExists file = do
|
||||||
exists <- doesFileExist file
|
exists <- doesFileExist file
|
||||||
case (exists) of
|
if (not exists)
|
||||||
False -> error $ "does not exist: " ++ file
|
then error $ "does not exist: " ++ file
|
||||||
True -> return ()
|
else return ()
|
||||||
checkLegal file = do
|
checkLegal file = do
|
||||||
s <- getFileStatus file
|
s <- getSymbolicLinkStatus file
|
||||||
case (not (isSymbolicLink s) && not (isRegularFile s)) of
|
if ((isSymbolicLink s) || (not $ isRegularFile s))
|
||||||
False -> error $ "not a regular file: " ++ file
|
then error $ "not a regular file: " ++ file
|
||||||
True -> return ()
|
else return ()
|
||||||
|
|
||||||
|
{- Inverse of annexFile. -}
|
||||||
|
unannexFile :: State -> FilePath -> IO ()
|
||||||
|
unannexFile state file = do
|
||||||
|
alreadyannexed <- lookupBackend (backends state) (repo state) file
|
||||||
|
case (alreadyannexed) of
|
||||||
|
Nothing -> error $ "not annexed " ++ file
|
||||||
|
Just _ -> do
|
||||||
|
mkey <- dropFile (backends state) (repo state) file
|
||||||
|
case (mkey) of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just key -> do
|
||||||
|
src <- annexDir (repo state) key
|
||||||
|
removeFile file
|
||||||
|
renameFile src file
|
||||||
|
return ()
|
||||||
|
|
||||||
{- Sets up a git repo for git-annex. May be called repeatedly. -}
|
{- Sets up a git repo for git-annex. May be called repeatedly. -}
|
||||||
gitPrep :: GitRepo -> IO ()
|
gitPrep :: GitRepo -> IO ()
|
||||||
|
|
23
Backend.hs
23
Backend.hs
|
@ -57,14 +57,29 @@ storeFile (b:bs) repo file = do
|
||||||
|
|
||||||
{- Attempts to retrieve an file from one of the backends, saving it to
|
{- Attempts to retrieve an file from one of the backends, saving it to
|
||||||
- a specified location. -}
|
- a specified location. -}
|
||||||
retrieveFile :: [Backend] -> GitRepo -> FilePath -> FilePath -> IO (Bool)
|
retrieveFile :: [Backend] -> GitRepo -> FilePath -> FilePath -> IO Bool
|
||||||
retrieveFile backends repo file dest = do
|
retrieveFile backends repo file dest = do
|
||||||
result <- lookupBackend backends repo file
|
result <- lookupBackend backends repo file
|
||||||
case (result) of
|
case (result) of
|
||||||
Nothing -> return False
|
Nothing -> return False
|
||||||
Just b -> (retrieveKeyFile b) key dest
|
Just b -> do
|
||||||
where
|
key <- lookupKey b repo file
|
||||||
key = readFile (backendFile b repo file)
|
(retrieveKeyFile b) key dest
|
||||||
|
|
||||||
|
{- Drops the key for a file from the backend that has it. -}
|
||||||
|
dropFile :: [Backend] -> GitRepo -> FilePath -> IO (Maybe Key)
|
||||||
|
dropFile backends repo file = do
|
||||||
|
result <- lookupBackend backends repo file
|
||||||
|
case (result) of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just b -> do
|
||||||
|
key <- lookupKey b repo file
|
||||||
|
(removeKey b) key
|
||||||
|
return $ Just key
|
||||||
|
|
||||||
|
{- Looks up the key a backend uses for an already annexed file. -}
|
||||||
|
lookupKey :: Backend -> GitRepo -> FilePath -> IO Key
|
||||||
|
lookupKey backend repo file = readFile (backendFile backend 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)
|
||||||
|
|
|
@ -9,7 +9,8 @@ backend = Backend {
|
||||||
name = "file",
|
name = "file",
|
||||||
getKey = keyValue,
|
getKey = keyValue,
|
||||||
storeFileKey = dummyStore,
|
storeFileKey = dummyStore,
|
||||||
retrieveKeyFile = copyFromOtherRepo
|
retrieveKeyFile = copyFromOtherRepo,
|
||||||
|
removeKey = dummyRemove
|
||||||
}
|
}
|
||||||
|
|
||||||
-- direct mapping from filename to key
|
-- direct mapping from filename to key
|
||||||
|
@ -18,11 +19,14 @@ keyValue repo file = return $ Just file
|
||||||
|
|
||||||
{- This backend does not really do any independant data storage,
|
{- This backend does not really do any independant data storage,
|
||||||
- it relies on the file contents in .git/annex/ in this repo,
|
- it relies on the file contents in .git/annex/ in this repo,
|
||||||
- and other accessible repos. So storing a file is a no-op. -}
|
- and other accessible repos. So storing or removing a key is
|
||||||
|
- a no-op. -}
|
||||||
dummyStore :: GitRepo -> FilePath -> Key -> IO (Bool)
|
dummyStore :: GitRepo -> FilePath -> Key -> IO (Bool)
|
||||||
dummyStore repo file key = return True
|
dummyStore repo file key = return True
|
||||||
|
dummyRemove :: Key -> IO Bool
|
||||||
|
dummyRemove url = return False
|
||||||
|
|
||||||
{- Try to find a copy of the file in one of the other repos,
|
{- Try to find a copy of the file in one of the other repos,
|
||||||
- and copy it over to this one. -}
|
- and copy it over to this one. -}
|
||||||
copyFromOtherRepo :: IO Key -> FilePath -> IO (Bool)
|
copyFromOtherRepo :: Key -> FilePath -> IO (Bool)
|
||||||
copyFromOtherRepo key file = error "copyFromOtherRepo unimplemented" -- TODO
|
copyFromOtherRepo key file = error "copyFromOtherRepo unimplemented" -- TODO
|
||||||
|
|
|
@ -9,16 +9,19 @@ backend = Backend {
|
||||||
name = "url",
|
name = "url",
|
||||||
getKey = keyValue,
|
getKey = keyValue,
|
||||||
storeFileKey = dummyStore,
|
storeFileKey = dummyStore,
|
||||||
retrieveKeyFile = downloadUrl
|
retrieveKeyFile = downloadUrl,
|
||||||
|
removeKey = dummyRemove
|
||||||
}
|
}
|
||||||
|
|
||||||
-- cannot generate url from filename
|
-- cannot generate url from filename
|
||||||
keyValue :: GitRepo -> FilePath -> IO (Maybe Key)
|
keyValue :: GitRepo -> FilePath -> IO (Maybe Key)
|
||||||
keyValue repo file = return Nothing
|
keyValue repo file = return Nothing
|
||||||
|
|
||||||
-- cannot store to urls
|
-- cannot change urls
|
||||||
dummyStore :: GitRepo -> FilePath -> Key -> IO (Bool)
|
dummyStore :: GitRepo -> FilePath -> Key -> IO Bool
|
||||||
dummyStore repo file url = return False
|
dummyStore repo file url = return False
|
||||||
|
dummyRemove :: Key -> IO Bool
|
||||||
|
dummyRemove url = return False
|
||||||
|
|
||||||
downloadUrl :: IO Key -> FilePath -> IO (Bool)
|
downloadUrl :: Key -> FilePath -> IO Bool
|
||||||
downloadUrl url file = error "downloadUrl unimplemented"
|
downloadUrl url file = error "downloadUrl unimplemented"
|
||||||
|
|
|
@ -10,8 +10,8 @@ import System.Console.GetOpt
|
||||||
import Types
|
import Types
|
||||||
import Annex
|
import Annex
|
||||||
|
|
||||||
data Flag = Add FilePath | Push String | Pull String |
|
data Flag = Add FilePath | Push String | Pull String | Want FilePath |
|
||||||
Want FilePath | Get (Maybe FilePath) | Drop FilePath
|
Get (Maybe FilePath) | Drop FilePath | Unannex FilePath
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
options :: [OptDescr Flag]
|
options :: [OptDescr Flag]
|
||||||
|
@ -22,6 +22,7 @@ options =
|
||||||
, Option ['w'] ["want"] (ReqArg Want "FILE") "request file contents"
|
, Option ['w'] ["want"] (ReqArg Want "FILE") "request file contents"
|
||||||
, Option ['g'] ["get"] (OptArg Get "FILE") "transfer file contents"
|
, Option ['g'] ["get"] (OptArg Get "FILE") "transfer file contents"
|
||||||
, Option ['d'] ["drop"] (ReqArg Drop "FILE") "indicate file content not needed"
|
, Option ['d'] ["drop"] (ReqArg Drop "FILE") "indicate file content not needed"
|
||||||
|
, Option ['u'] ["unannex"] (ReqArg Unannex "FILE") "undo --add"
|
||||||
]
|
]
|
||||||
|
|
||||||
argvToFlags argv = do
|
argvToFlags argv = do
|
||||||
|
@ -38,4 +39,5 @@ dispatch :: Flag -> State -> IO ()
|
||||||
dispatch flag state = do
|
dispatch flag state = do
|
||||||
case (flag) of
|
case (flag) of
|
||||||
Add f -> annexFile state f
|
Add f -> annexFile state f
|
||||||
|
Unannex f -> unannexFile state f
|
||||||
_ -> error "not implemented"
|
_ -> error "not implemented"
|
||||||
|
|
6
Types.hs
6
Types.hs
|
@ -13,9 +13,11 @@ data Backend = Backend {
|
||||||
-- converts a filename to a key
|
-- converts a filename to a key
|
||||||
getKey :: GitRepo -> FilePath -> IO (Maybe Key),
|
getKey :: GitRepo -> FilePath -> IO (Maybe Key),
|
||||||
-- stores a file's contents to a key
|
-- stores a file's contents to a key
|
||||||
storeFileKey :: GitRepo -> FilePath -> Key -> IO (Bool),
|
storeFileKey :: GitRepo -> FilePath -> Key -> IO Bool,
|
||||||
-- retrieves a key's contents to a file
|
-- retrieves a key's contents to a file
|
||||||
retrieveKeyFile :: IO Key -> FilePath -> IO (Bool)
|
retrieveKeyFile :: Key -> FilePath -> IO Bool,
|
||||||
|
-- removes a key
|
||||||
|
removeKey :: Key -> IO Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
-- a git repository
|
-- a git repository
|
||||||
|
|
|
@ -36,6 +36,7 @@ Enough broad picture, here's how it actually looks:
|
||||||
downloaded.
|
downloaded.
|
||||||
* `git annex --drop $file` indicates that you no longer want the file's
|
* `git annex --drop $file` indicates that you no longer want the file's
|
||||||
content to be available in this repository.
|
content to be available in this repository.
|
||||||
|
* `git annex --unannex $file` undoes a `git annex --add`.
|
||||||
* `git annex $file` is a shorthand for either --add or --get. If the file
|
* `git annex $file` is a shorthand for either --add or --get. If the file
|
||||||
is already known, it does --get, otherwise it does --add.
|
is already known, it does --get, otherwise it does --add.
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue