diff options
| -rw-r--r-- | Annex.hs | 138 | ||||
| -rw-r--r-- | Backend.hs | 25 | ||||
| -rw-r--r-- | BackendChecksum.hs | 2 | ||||
| -rw-r--r-- | BackendFile.hs | 21 | ||||
| -rw-r--r-- | BackendUrl.hs | 21 | ||||
| -rw-r--r-- | CmdLine.hs | 21 | ||||
| -rw-r--r-- | Remotes.hs | 44 | ||||
| -rw-r--r-- | TODO | 4 | ||||
| -rw-r--r-- | Types.hs | 51 | ||||
| -rw-r--r-- | UUID.hs | 50 | ||||
| -rw-r--r-- | git-annex.hs | 31 |
11 files changed, 251 insertions, 157 deletions
@@ -12,6 +12,7 @@ module Annex ( annexPullRepo ) where +import Control.Monad.State (liftIO) import System.Posix.Files import System.Directory import Data.String.Utils @@ -25,22 +26,27 @@ import UUID import LocationLog import Types -{- On startup, examine the git repo, prepare it, and record state for - - later. -} -startAnnex :: IO State +{- Create and returns an Annex state object. + - Examines and prepares the git repo. + -} +startAnnex :: IO AnnexState startAnnex = do - r <- gitRepoFromCwd - r' <- gitConfigRead r - r'' <- prepUUID r' - gitSetup r'' - - return State { - repo = r', - backends = parseBackendList $ gitConfig r' "annex.backends" "" - } + g <- gitRepoFromCwd + let s = makeAnnexState g + (_,s') <- runAnnexState s (prep g) + return s' + where + prep g = do + -- setup git and read its config; update state + liftIO $ gitSetup g + g' <- liftIO $ gitConfigRead g + gitAnnexChange g' + backendsAnnexChange $ parseBackendList $ + gitConfig g' "annex.backends" "" + prepUUID inBackend file yes no = do - r <- lookupFile file + r <- liftIO $ lookupFile file case (r) of Just v -> yes v Nothing -> no @@ -48,13 +54,16 @@ notinBackend file yes no = inBackend file no yes {- Annexes a file, storing it in a backend, and then moving it into - the annex directory and setting up the symlink pointing to its content. -} -annexFile :: State -> FilePath -> IO () -annexFile state file = inBackend file err $ do - checkLegal file - stored <- storeFile state file +annexFile :: FilePath -> Annex () +annexFile file = inBackend file err $ do + liftIO $ checkLegal file + stored <- storeFile file + g <- gitAnnex case (stored) of Nothing -> error $ "no backend could store: " ++ file - Just (key, backend) -> setup key backend + Just (key, backend) -> do + logStatus key ValuePresent + liftIO $ setup g key backend where err = error $ "already annexed " ++ file checkLegal file = do @@ -62,15 +71,14 @@ annexFile state file = inBackend file err $ do if ((isSymbolicLink s) || (not $ isRegularFile s)) then error $ "not a regular file: " ++ file else return () - setup key backend = do - logStatus state key ValuePresent - let dest = annexLocation (repo state) backend key - let reldest = annexLocationRelative (repo state) backend key + setup g key backend = do + let dest = annexLocation g backend key + let reldest = annexLocationRelative g backend key createDirectoryIfMissing True (parentDir dest) renameFile file dest createSymbolicLink ((linkTarget file) ++ reldest) file - gitRun (repo state) ["add", file] - gitRun (repo state) ["commit", "-m", + gitRun g ["add", file] + gitRun g ["commit", "-m", ("git-annex annexed " ++ file), file] linkTarget file = -- relies on file being relative to the top of the @@ -83,56 +91,60 @@ annexFile state file = inBackend file err $ do {- Inverse of annexFile. -} -unannexFile :: State -> FilePath -> IO () -unannexFile state file = notinBackend file err $ \(key, backend) -> do - dropFile state backend key - logStatus state key ValueMissing - removeFile file - gitRun (repo state) ["rm", file] - gitRun (repo state) ["commit", "-m", - ("git-annex unannexed " ++ file), file] - -- git rm deletes empty directories; - -- put them back - createDirectoryIfMissing True (parentDir file) - let src = annexLocation (repo state) backend key - renameFile src file - return () +unannexFile :: FilePath -> Annex () +unannexFile file = notinBackend file err $ \(key, backend) -> do + dropFile backend key + logStatus key ValueMissing + g <- gitAnnex + let src = annexLocation g backend key + liftIO $ moveout g src where err = error $ "not annexed " ++ file + moveout g src = do + removeFile file + gitRun g ["rm", file] + gitRun g ["commit", "-m", + ("git-annex unannexed " ++ file), file] + -- git rm deletes empty directories; + -- put them back + createDirectoryIfMissing True (parentDir file) + renameFile src file + return () {- Gets an annexed file from one of the backends. -} -annexGetFile :: State -> FilePath -> IO () -annexGetFile state file = notinBackend file err $ \(key, backend) -> do - inannex <- inAnnex state backend key +annexGetFile :: FilePath -> Annex () +annexGetFile file = notinBackend file err $ \(key, backend) -> do + inannex <- inAnnex backend key if (inannex) then return () else do - let dest = annexLocation (repo state) backend key - createDirectoryIfMissing True (parentDir dest) - success <- retrieveFile state backend key dest + g <- gitAnnex + let dest = annexLocation g backend key + liftIO $ createDirectoryIfMissing True (parentDir dest) + success <- retrieveFile backend key dest if (success) then do - logStatus state key ValuePresent + logStatus key ValuePresent return () else error $ "failed to get " ++ file where err = error $ "not annexed " ++ file {- Indicates a file is wanted. -} -annexWantFile :: State -> FilePath -> IO () -annexWantFile state file = do error "not implemented" -- TODO +annexWantFile :: FilePath -> Annex () +annexWantFile file = do error "not implemented" -- TODO {- Indicates a file is not wanted. -} -annexDropFile :: State -> FilePath -> IO () -annexDropFile state file = do error "not implemented" -- TODO +annexDropFile :: FilePath -> Annex () +annexDropFile file = do error "not implemented" -- TODO {- Pushes all files to a remote repository. -} -annexPushRepo :: State -> String -> IO () -annexPushRepo state reponame = do error "not implemented" -- TODO +annexPushRepo :: String -> Annex () +annexPushRepo reponame = do error "not implemented" -- TODO {- Pulls all files from a remote repository. -} -annexPullRepo :: State -> String -> IO () -annexPullRepo state reponame = do error "not implemented" -- TODO +annexPullRepo :: String -> Annex () +annexPullRepo reponame = do error "not implemented" -- TODO {- Sets up a git repo for git-annex. May be called repeatedly. -} gitSetup :: GitRepo -> IO () @@ -159,11 +171,19 @@ gitSetup repo = do attributes] {- Updates the LocationLog when a key's presence changes. -} -logStatus state key status = do - f <- logChange (repo state) key (getUUID state (repo state)) status - gitRun (repo state) ["add", f] - gitRun (repo state) ["commit", "-m", "git-annex log update", f] +logStatus :: Key -> LogStatus -> Annex () +logStatus key status = do + g <- gitAnnex + u <- getUUID g + f <- liftIO $ logChange g key u status + liftIO $ commit g f + where + commit g f = do + gitRun g ["add", f] + gitRun g ["commit", "-m", "git-annex log update", f] {- Checks if a given key is currently present in the annexLocation -} -inAnnex :: State -> Backend -> Key -> IO Bool -inAnnex state backend key = doesFileExist $ annexLocation (repo state) backend key +inAnnex :: Backend -> Key -> Annex Bool +inAnnex backend key = do + g <- gitAnnex + liftIO $ doesFileExist $ annexLocation g backend key diff --git a/Backend.hs b/Backend.hs index bc7eb206f..775c4a02f 100644 --- a/Backend.hs +++ b/Backend.hs @@ -20,6 +20,7 @@ module Backend ( lookupFile ) where +import Control.Monad.State import Control.Exception import System.Directory import System.FilePath @@ -32,30 +33,34 @@ import Utility import Types {- Attempts to store a file in one of the backends. -} -storeFile :: State -> FilePath -> IO (Maybe (Key, Backend)) -storeFile state file = storeFile' (backends state) state file +storeFile :: FilePath -> Annex (Maybe (Key, Backend)) +storeFile file = do + g <- gitAnnex + let relfile = gitRelative g file + b <- backendsAnnex + storeFile' b file relfile storeFile' [] _ _ = return Nothing -storeFile' (b:bs) state file = do - try <- (getKey b) state (gitRelative (repo state) file) +storeFile' (b:bs) file relfile = do + try <- (getKey b) relfile case (try) of Nothing -> nextbackend Just key -> do - stored <- (storeFileKey b) state file key + stored <- (storeFileKey b) file key if (not stored) then nextbackend else do return $ Just (key, b) where - nextbackend = storeFile' bs state file + nextbackend = storeFile' bs file relfile {- Attempts to retrieve an key from one of the backends, saving it to - a specified location. -} -retrieveFile :: State -> Backend -> Key -> FilePath -> IO Bool -retrieveFile state backend key dest = (retrieveKeyFile backend) state key dest +retrieveFile :: Backend -> Key -> FilePath -> Annex Bool +retrieveFile backend key dest = (retrieveKeyFile backend) key dest {- Drops a key from a backend. -} -dropFile :: State -> Backend -> Key -> IO Bool -dropFile state backend key = (removeKey backend) state key +dropFile :: Backend -> Key -> Annex Bool +dropFile backend key = (removeKey backend) key {- Looks up the key and backend corresponding to an annexed file, - by examining what the file symlinks to. -} diff --git a/BackendChecksum.hs b/BackendChecksum.hs index efa224412..c6e68ffed 100644 --- a/BackendChecksum.hs +++ b/BackendChecksum.hs @@ -14,5 +14,5 @@ backend = BackendFile.backend { } -- checksum the file to get its key -keyValue :: State -> FilePath -> IO (Maybe Key) +keyValue :: FilePath -> Annex (Maybe Key) keyValue k = error "checksum keyValue unimplemented" -- TODO diff --git a/BackendFile.hs b/BackendFile.hs index a31cbfeb1..9b82a0b20 100644 --- a/BackendFile.hs +++ b/BackendFile.hs @@ -3,6 +3,7 @@ module BackendFile (backend) where +import Control.Monad.State import System.IO import System.Cmd import Control.Exception @@ -21,28 +22,28 @@ backend = Backend { } -- direct mapping from filename to key -keyValue :: State -> FilePath -> IO (Maybe Key) -keyValue state file = return $ Just $ Key file +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 :: State -> FilePath -> Key -> IO (Bool) -dummyStore state file key = return True -dummyRemove :: State -> Key -> IO Bool -dummyRemove state url = return False +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 :: State -> Key -> FilePath -> IO (Bool) -copyKeyFile state key file = do - remotes <- remotesWithKey state key +copyKeyFile :: Key -> FilePath -> Annex (Bool) +copyKeyFile key file = do + remotes <- remotesWithKey key if (0 == length remotes) then error $ "no known remotes have: " ++ (keyFile key) ++ "\n" ++ "(Perhaps you need to git remote add a repository?)" - else trycopy remotes remotes + else liftIO $ trycopy remotes remotes where trycopy full [] = error $ "unable to get: " ++ (keyFile key) ++ "\n" ++ "To get that file, need access to one of these remotes: " ++ diff --git a/BackendUrl.hs b/BackendUrl.hs index 5b586497c..43b0bc75a 100644 --- a/BackendUrl.hs +++ b/BackendUrl.hs @@ -3,6 +3,7 @@ module BackendUrl (backend) where +import Control.Monad.State import System.Cmd import IO import Types @@ -16,19 +17,19 @@ backend = Backend { } -- cannot generate url from filename -keyValue :: State -> FilePath -> IO (Maybe Key) -keyValue repo file = return Nothing +keyValue :: FilePath -> Annex (Maybe Key) +keyValue file = return Nothing -- cannot change url contents -dummyStore :: State -> FilePath -> Key -> IO Bool -dummyStore repo file url = return False -dummyRemove :: State -> Key -> IO Bool -dummyRemove state url = return False +dummyStore :: FilePath -> Key -> Annex Bool +dummyStore file url = return False +dummyRemove :: Key -> Annex Bool +dummyRemove url = return False -downloadUrl :: State -> Key -> FilePath -> IO Bool -downloadUrl state url file = do - putStrLn $ "download: " ++ (show url) - result <- try $ rawSystem "curl" ["-#", "-o", file, (show url)] +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 diff --git a/CmdLine.hs b/CmdLine.hs index 9da2b6493..d23508aa2 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -6,7 +6,8 @@ module CmdLine ( argvToMode, - dispatch + dispatch, + Mode ) where import System.Console.GetOpt @@ -39,13 +40,13 @@ argvToMode argv = do (_,files,errs) -> ioError (userError (concat errs ++ usageInfo header options)) where header = "Usage: git-annex [mode] file" -dispatch :: State -> Mode -> FilePath -> IO () -dispatch state mode item = do +dispatch :: Mode -> FilePath -> Annex () +dispatch mode item = do case (mode) of - Add -> annexFile state item - Push -> annexPushRepo state item - Pull -> annexPullRepo state item - Want -> annexWantFile state item - Get -> annexGetFile state item - Drop -> annexDropFile state item - Unannex -> unannexFile state item + Add -> annexFile item + Push -> annexPushRepo item + Pull -> annexPullRepo item + Want -> annexWantFile item + Get -> annexGetFile item + Drop -> annexDropFile item + Unannex -> unannexFile item diff --git a/Remotes.hs b/Remotes.hs index ae709a3c2..399291467 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -5,6 +5,7 @@ module Remotes ( remotesWithKey ) where +import Control.Monad.State (liftIO) import Types import GitRepo import LocationLog @@ -17,34 +18,43 @@ remotesList :: [GitRepo] -> String remotesList remotes = join " " $ map gitRepoDescribe remotes {- Cost ordered list of remotes that the LocationLog indicate may have a key. -} -remotesWithKey :: State -> Key -> IO [GitRepo] -remotesWithKey state key = do - uuids <- keyLocations (repo state) key - return $ reposByUUID state (remotesByCost state) uuids +remotesWithKey :: Key -> Annex [GitRepo] +remotesWithKey key = do + g <- gitAnnex + uuids <- liftIO $ keyLocations g key + remotes <- remotesByCost + reposByUUID remotes uuids {- Cost Ordered list of remotes. -} -remotesByCost :: State -> [GitRepo] -remotesByCost state = reposByCost state $ gitConfigRemotes (repo state) +remotesByCost :: Annex [GitRepo] +remotesByCost = do + g <- gitAnnex + reposByCost $ gitConfigRemotes g {- Orders a list of git repos by cost. -} -reposByCost :: State -> [GitRepo] -> [GitRepo] -reposByCost state l = - fst $ unzip $ sortBy (\(r1, c1) (r2, c2) -> compare c1 c2) $ costpairs l +reposByCost :: [GitRepo] -> Annex [GitRepo] +reposByCost l = do + costpairs <- mapM costpair l + return $ fst $ unzip $ sortBy bycost $ costpairs where - costpairs l = map (\r -> (r, repoCost state r)) l + costpair r = do + cost <- repoCost r + return (r, cost) + bycost (_, c1) (_, c2) = compare c1 c2 {- Calculates cost for a repo. - - The default cost is 100 for local repositories, and 200 for remote - repositories; it can also be configured by remote.<name>.annex-cost -} -repoCost :: State -> GitRepo -> Int -repoCost state r = - if ((length $ config state r) > 0) - then read $ config state r +repoCost :: GitRepo -> Annex Int +repoCost r = do + g <- gitAnnex + if ((length $ config g r) > 0) + then return $ read $ config g r else if (gitRepoIsLocal r) - then 100 - else 200 + then return 100 + else return 200 where - config state r = gitConfig (repo state) (configkey r) "" + config g r = gitConfig g (configkey r) "" configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost" @@ -1,9 +1,9 @@ * bug when annexing files while in a subdir of a git repo * bug when specifying absolute path to files when annexing -* implement retrieval for backendfile +* state monad -* query remotes for their annex.uuid settings +* query remotes for their annex.uuid settings and cache * --push/--pull/--want/--drop @@ -1,20 +1,59 @@ {- git-annex core data types -} module Types ( - State(..), + Annex(..), + makeAnnexState, + runAnnexState, + gitAnnex, + gitAnnexChange, + backendsAnnex, + backendsAnnexChange, + + AnnexState(..), Key(..), Backend(..) ) where +import Control.Monad.State import Data.String.Utils import GitRepo -- git-annex's runtime state -data State = State { +data AnnexState = AnnexState { repo :: GitRepo, backends :: [Backend] } deriving (Show) +-- git-annex's monad +type Annex = StateT AnnexState IO + +-- constructor +makeAnnexState :: GitRepo -> AnnexState +makeAnnexState g = AnnexState { repo = g, backends = [] } + +-- performs an action in the Annex monad +runAnnexState state action = runStateT (action) state + +-- state accessors +gitAnnex :: Annex GitRepo +gitAnnex = do + state <- get + return (repo state) +gitAnnexChange :: GitRepo -> Annex () +gitAnnexChange r = do + state <- get + put state { repo = r } + return () +backendsAnnex :: Annex [Backend] +backendsAnnex = do + state <- get + return (backends state) +backendsAnnexChange :: [Backend] -> Annex () +backendsAnnexChange b = do + state <- get + put state { backends = b } + return () + -- annexed filenames are mapped into keys data Key = Key String deriving (Eq) @@ -27,13 +66,13 @@ data Backend = Backend { -- name of this backend name :: String, -- converts a filename to a key - getKey :: State -> FilePath -> IO (Maybe Key), + getKey :: FilePath -> Annex (Maybe Key), -- stores a file's contents to a key - storeFileKey :: State -> FilePath -> Key -> IO Bool, + storeFileKey :: FilePath -> Key -> Annex Bool, -- retrieves a key's contents to a file - retrieveKeyFile :: State -> Key -> FilePath -> IO Bool, + retrieveKeyFile :: Key -> FilePath -> Annex Bool, -- removes a key - removeKey :: State -> Key -> IO Bool + removeKey :: Key -> Annex Bool } instance Show Backend where @@ -13,6 +13,7 @@ module UUID ( reposByUUID ) where +import Control.Monad.State import Maybe import List import System.Cmd.Utils @@ -26,9 +27,8 @@ configkey="annex.uuid" {- Generates a UUID. There is a library for this, but it's not packaged, - so use the command line tool. -} -genUUID :: IO UUID -genUUID = do - pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h +genUUID :: Annex UUID +genUUID = liftIO $ pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h {- Looks up a repo's UUID. May return "" if none is known. - @@ -36,28 +36,38 @@ genUUID = do - remote.<name>.annex-uuid - - -} -getUUID :: State -> GitRepo -> UUID -getUUID s r = - if ("" /= getUUID' r) - then getUUID' r - else cached s r +getUUID :: GitRepo -> Annex UUID +getUUID r = do + if ("" /= configured r) + then return $ configured r + else cached r where - cached s r = gitConfig (repo s) (configkey r) "" + configured r = gitConfig r "annex.uuid" "" + cached r = do + g <- gitAnnex + return $ gitConfig g (configkey r) "" configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-uuid" -getUUID' r = gitConfig r "annex.uuid" "" {- Make sure that the repo has an annex.uuid setting. -} -prepUUID :: GitRepo -> IO GitRepo -prepUUID repo = - if ("" == getUUID' repo) +prepUUID :: Annex () +prepUUID = do + g <- gitAnnex + u <- getUUID g + if ("" == u) then do uuid <- genUUID - gitRun repo ["config", configkey, uuid] - -- return new repo with updated config - gitConfigRead repo - else return repo + liftIO $ gitRun g ["config", configkey, uuid] + -- re-read git config and update the repo's state + u' <- liftIO $ gitConfigRead g + gitAnnexChange u' + return () + else return () {- Filters a list of repos to ones that have listed UUIDs. -} -reposByUUID :: State -> [GitRepo] -> [UUID] -> [GitRepo] -reposByUUID state repos uuids = - filter (\r -> isJust $ elemIndex (getUUID state r) uuids) repos +reposByUUID :: [GitRepo] -> [UUID] -> Annex [GitRepo] +reposByUUID repos uuids = do + filterM match repos + where + match r = do + u <- getUUID r + return $ isJust $ elemIndex u uuids diff --git a/git-annex.hs b/git-annex.hs index 7785e4f2d..935be2f1e 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -1,36 +1,43 @@ {- git-annex main program - -} +import Control.Monad.State import System.IO import System.Environment import Control.Exception import CmdLine +import Types import Annex main = do args <- getArgs - (mode, files) <- argvToMode args - + (mode, params) <- argvToMode args state <- startAnnex + tryRun state mode 0 0 params - tryRun 0 0 $ map (\f -> dispatch state mode f) files - -{- Tries to run a series of actions, not stopping if some error out, - - and propigating an overall error status at the end. -} -tryRun errnum oknum [] = do +{- Processes each param in the list by dispatching the handler function + - for the user-selection operation mode. Catches exceptions, not stopping + - if some error out, and propigates an overall error status at the end. + - + - This runs in the IO monad, not in the Annex monad. It seems that + - exceptions can only be caught in the IO monad, not in a stacked monad; + - or more likely I missed an easy way to do it. So, I have to laboriously + - thread AnnexState through this function. + -} +tryRun :: AnnexState -> Mode -> Int -> Int -> [String] -> IO () +tryRun state mode errnum oknum [] = do if (errnum > 0) then error $ (show errnum) ++ " failed ; " ++ show (oknum) ++ " ok" else return () -tryRun errnum oknum (a:as) = do - result <- try (a)::IO (Either SomeException ()) +tryRun state mode errnum oknum (f:fs) = do + result <- try (runAnnexState state (dispatch mode f))::IO (Either SomeException ((), AnnexState)) case (result) of Left err -> do showErr err - tryRun (errnum + 1) oknum as - Right _ -> tryRun errnum (oknum + 1) as + tryRun state mode (errnum + 1) oknum fs + Right (_,state') -> tryRun state' mode errnum (oknum + 1) fs {- Exception pretty-printing. -} -showErr :: SomeException -> IO () showErr e = do hPutStrLn stderr $ "git-annex: " ++ (show e) return () |