diff options
| -rw-r--r-- | AbstractTypes.hs | 47 | ||||
| -rw-r--r-- | Annex.hs | 221 | ||||
| -rw-r--r-- | Backend.hs | 7 | ||||
| -rw-r--r-- | CmdLine.hs | 4 | ||||
| -rw-r--r-- | Commands.hs | 189 | ||||
| -rw-r--r-- | LocationLog.hs | 2 | ||||
| -rw-r--r-- | Locations.hs | 2 | ||||
| -rw-r--r-- | Remotes.hs | 13 | ||||
| -rw-r--r-- | Types.hs | 10 | ||||
| -rw-r--r-- | UUID.hs | 11 | ||||
| -rw-r--r-- | git-annex.hs | 8 |
11 files changed, 262 insertions, 252 deletions
diff --git a/AbstractTypes.hs b/AbstractTypes.hs deleted file mode 100644 index 935d1de2f..000000000 --- a/AbstractTypes.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- git-annex data types, abstract only -} - -module AbstractTypes ( - Annex, - AnnexState, - makeAnnexState, - runAnnexState, - gitAnnex, - gitAnnexChange, - backendsAnnex, - backendsAnnexChange, - - Key, - Backend -) where - -import Control.Monad.State -import qualified GitRepo as Git -import BackendTypes - --- constructor -makeAnnexState :: Git.Repo -> AnnexState -makeAnnexState g = AnnexState { repo = g, backends = [] } - --- performs an action in the Annex monad -runAnnexState state action = runStateT (action) state - --- Annex monad state accessors -gitAnnex :: Annex Git.Repo -gitAnnex = do - state <- get - return (repo state) -gitAnnexChange :: Git.Repo -> 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 () - @@ -1,189 +1,42 @@ -{- git-annex toplevel code - -} +{- git-annex monad -} module Annex ( - start, - annexCmd, - unannexCmd, - getCmd, - wantCmd, - dropCmd, - pushCmd, - pullCmd + new, + run, + gitRepo, + gitRepoChange, + backends, + backendsChange, ) where -import Control.Monad.State (liftIO) -import System.Posix.Files -import System.Directory -import Data.String.Utils -import List +import Control.Monad.State import qualified GitRepo as Git -import Utility -import Locations -import qualified Backend -import BackendList -import UUID -import LocationLog -import AbstractTypes - -{- Create and returns an Annex state object. - - Examines and prepares the git repo. - -} -start :: IO AnnexState -start = do - g <- Git.repoFromCwd - let s = makeAnnexState g - (_,s') <- runAnnexState s (prep g) - return s' - where - prep g = do - -- setup git and read its config; update state - g' <- liftIO $ Git.configRead g - gitAnnexChange g' - liftIO $ gitSetup g' - backendsAnnexChange $ parseBackendList $ - Git.configGet g' "annex.backends" "" - prepUUID - -inBackend file yes no = do - r <- liftIO $ Backend.lookupFile file - case (r) of - Just v -> yes v - Nothing -> no -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. -} -annexCmd :: FilePath -> Annex () -annexCmd file = inBackend file err $ do - liftIO $ checkLegal file - stored <- Backend.storeFile file - g <- gitAnnex - case (stored) of - Nothing -> error $ "no backend could store: " ++ file - Just (key, backend) -> do - logStatus key ValuePresent - liftIO $ setup g key backend - where - err = error $ "already annexed " ++ file - checkLegal file = do - s <- getSymbolicLinkStatus file - if ((isSymbolicLink s) || (not $ isRegularFile s)) - then error $ "not a regular file: " ++ file - else return () - 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 - Git.run g ["add", file] - Git.run g ["commit", "-m", - ("git-annex annexed " ++ file), file] - linkTarget file = - -- relies on file being relative to the top of the - -- git repo; just replace each subdirectory with ".." - if (subdirs > 0) - then (join "/" $ take subdirs $ repeat "..") ++ "/" - else "" - where - subdirs = (length $ split "/" file) - 1 - - -{- Inverse of annexCmd. -} -unannexCmd :: FilePath -> Annex () -unannexCmd file = notinBackend file err $ \(key, backend) -> do - Backend.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 - Git.run g ["rm", file] - Git.run 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. -} -getCmd :: FilePath -> Annex () -getCmd file = notinBackend file err $ \(key, backend) -> do - inannex <- inAnnex backend key - if (inannex) - then return () - else do - g <- gitAnnex - let dest = annexLocation g backend key - liftIO $ createDirectoryIfMissing True (parentDir dest) - success <- Backend.retrieveFile backend key dest - if (success) - then do - logStatus key ValuePresent - return () - else error $ "failed to get " ++ file - where - err = error $ "not annexed " ++ file - -{- Indicates a file is wanted. -} -wantCmd :: FilePath -> Annex () -wantCmd file = do error "not implemented" -- TODO - -{- Indicates a file is not wanted. -} -dropCmd :: FilePath -> Annex () -dropCmd file = do error "not implemented" -- TODO - -{- Pushes all files to a remote repository. -} -pushCmd :: String -> Annex () -pushCmd reponame = do error "not implemented" -- TODO - -{- Pulls all files from a remote repository. -} -pullCmd :: String -> Annex () -pullCmd reponame = do error "not implemented" -- TODO - -{- Sets up a git repo for git-annex. May be called repeatedly. -} -gitSetup :: Git.Repo -> IO () -gitSetup repo = do - -- configure git to use union merge driver on state files - exists <- doesFileExist attributes - if (not exists) - then do - writeFile attributes $ attrLine ++ "\n" - commit - else do - content <- readFile attributes - if (all (/= attrLine) (lines content)) - then do - appendFile attributes $ attrLine ++ "\n" - commit - else return () - where - attrLine = stateLoc ++ "/*.log merge=union" - attributes = Git.attributes repo - commit = do - Git.run repo ["add", attributes] - Git.run repo ["commit", "-m", "git-annex setup", - attributes] - -{- Updates the LocationLog when a key's presence changes. -} -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 - Git.run g ["add", f] - Git.run g ["commit", "-m", "git-annex log update", f] - -{- Checks if a given key is currently present in the annexLocation -} -inAnnex :: Backend -> Key -> Annex Bool -inAnnex backend key = do - g <- gitAnnex - liftIO $ doesFileExist $ annexLocation g backend key +import Types +import qualified BackendTypes as Backend + +-- constructor +new :: Git.Repo -> AnnexState +new g = Backend.AnnexState { Backend.repo = g, Backend.backends = [] } + +-- performs an action in the Annex monad +run state action = runStateT (action) state + +-- Annex monad state accessors +gitRepo :: Annex Git.Repo +gitRepo = do + state <- get + return (Backend.repo state) +gitRepoChange :: Git.Repo -> Annex () +gitRepoChange r = do + state <- get + put state { Backend.repo = r } + return () +backends :: Annex [Backend] +backends = do + state <- get + return (Backend.backends state) +backendsChange :: [Backend] -> Annex () +backendsChange b = do + state <- get + put state { Backend.backends = b } + return () diff --git a/Backend.hs b/Backend.hs index 251e436c7..2829fef9d 100644 --- a/Backend.hs +++ b/Backend.hs @@ -29,16 +29,17 @@ import System.Posix.Files import BackendList import Locations import qualified GitRepo as Git +import qualified Annex import Utility -import AbstractTypes +import Types import BackendTypes {- Attempts to store a file in one of the backends. -} storeFile :: FilePath -> Annex (Maybe (Key, Backend)) storeFile file = do - g <- gitAnnex + g <- Annex.gitRepo let relfile = Git.relative g file - b <- backendsAnnex + b <- Annex.backends storeFile' b file relfile storeFile' [] _ _ = return Nothing storeFile' (b:bs) file relfile = do diff --git a/CmdLine.hs b/CmdLine.hs index 479be7e8b..9737e0eb0 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -11,8 +11,8 @@ module CmdLine ( ) where import System.Console.GetOpt -import AbstractTypes -import Annex +import Types +import Commands data Mode = Add | Push | Pull | Want | Get | Drop | Unannex deriving Show diff --git a/Commands.hs b/Commands.hs new file mode 100644 index 000000000..98e65b126 --- /dev/null +++ b/Commands.hs @@ -0,0 +1,189 @@ +{- git-annex subcommands -} + +module Commands ( + start, + annexCmd, + unannexCmd, + getCmd, + wantCmd, + dropCmd, + pushCmd, + pullCmd +) where + +import Control.Monad.State (liftIO) +import System.Posix.Files +import System.Directory +import Data.String.Utils +import List +import qualified GitRepo as Git +import qualified Annex +import Utility +import Locations +import qualified Backend +import BackendList +import UUID +import LocationLog +import Types + +{- Create and returns an Annex state object. + - Examines and prepares the git repo. + -} +start :: IO AnnexState +start = do + g <- Git.repoFromCwd + let s = Annex.new g + (_,s') <- Annex.run s (prep g) + return s' + where + prep g = do + -- setup git and read its config; update state + g' <- liftIO $ Git.configRead g + Annex.gitRepoChange g' + liftIO $ gitSetup g' + Annex.backendsChange $ parseBackendList $ + Git.configGet g' "annex.backends" "" + prepUUID + +inBackend file yes no = do + r <- liftIO $ Backend.lookupFile file + case (r) of + Just v -> yes v + Nothing -> no +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. -} +annexCmd :: FilePath -> Annex () +annexCmd file = inBackend file err $ do + liftIO $ checkLegal file + stored <- Backend.storeFile file + g <- Annex.gitRepo + case (stored) of + Nothing -> error $ "no backend could store: " ++ file + Just (key, backend) -> do + logStatus key ValuePresent + liftIO $ setup g key backend + where + err = error $ "already annexed " ++ file + checkLegal file = do + s <- getSymbolicLinkStatus file + if ((isSymbolicLink s) || (not $ isRegularFile s)) + then error $ "not a regular file: " ++ file + else return () + 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 + Git.run g ["add", file] + Git.run g ["commit", "-m", + ("git-annex annexed " ++ file), file] + linkTarget file = + -- relies on file being relative to the top of the + -- git repo; just replace each subdirectory with ".." + if (subdirs > 0) + then (join "/" $ take subdirs $ repeat "..") ++ "/" + else "" + where + subdirs = (length $ split "/" file) - 1 + + +{- Inverse of annexCmd. -} +unannexCmd :: FilePath -> Annex () +unannexCmd file = notinBackend file err $ \(key, backend) -> do + Backend.dropFile backend key + logStatus key ValueMissing + g <- Annex.gitRepo + let src = annexLocation g backend key + liftIO $ moveout g src + where + err = error $ "not annexed " ++ file + moveout g src = do + removeFile file + Git.run g ["rm", file] + Git.run 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. -} +getCmd :: FilePath -> Annex () +getCmd file = notinBackend file err $ \(key, backend) -> do + inannex <- inAnnex backend key + if (inannex) + then return () + else do + g <- Annex.gitRepo + let dest = annexLocation g backend key + liftIO $ createDirectoryIfMissing True (parentDir dest) + success <- Backend.retrieveFile backend key dest + if (success) + then do + logStatus key ValuePresent + return () + else error $ "failed to get " ++ file + where + err = error $ "not annexed " ++ file + +{- Indicates a file is wanted. -} +wantCmd :: FilePath -> Annex () +wantCmd file = do error "not implemented" -- TODO + +{- Indicates a file is not wanted. -} +dropCmd :: FilePath -> Annex () +dropCmd file = do error "not implemented" -- TODO + +{- Pushes all files to a remote repository. -} +pushCmd :: String -> Annex () +pushCmd reponame = do error "not implemented" -- TODO + +{- Pulls all files from a remote repository. -} +pullCmd :: String -> Annex () +pullCmd reponame = do error "not implemented" -- TODO + +{- Sets up a git repo for git-annex. May be called repeatedly. -} +gitSetup :: Git.Repo -> IO () +gitSetup repo = do + -- configure git to use union merge driver on state files + exists <- doesFileExist attributes + if (not exists) + then do + writeFile attributes $ attrLine ++ "\n" + commit + else do + content <- readFile attributes + if (all (/= attrLine) (lines content)) + then do + appendFile attributes $ attrLine ++ "\n" + commit + else return () + where + attrLine = stateLoc ++ "/*.log merge=union" + attributes = Git.attributes repo + commit = do + Git.run repo ["add", attributes] + Git.run repo ["commit", "-m", "git-annex setup", + attributes] + +{- Updates the LocationLog when a key's presence changes. -} +logStatus :: Key -> LogStatus -> Annex () +logStatus key status = do + g <- Annex.gitRepo + u <- getUUID g + f <- liftIO $ logChange g key u status + liftIO $ commit g f + where + commit g f = do + Git.run g ["add", f] + Git.run g ["commit", "-m", "git-annex log update", f] + +{- Checks if a given key is currently present in the annexLocation -} +inAnnex :: Backend -> Key -> Annex Bool +inAnnex backend key = do + g <- Annex.gitRepo + liftIO $ doesFileExist $ annexLocation g backend key diff --git a/LocationLog.hs b/LocationLog.hs index 7953b345f..ba9178704 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -32,7 +32,7 @@ import Data.Char import qualified GitRepo as Git import Utility import UUID -import AbstractTypes +import Types import Locations data LogLine = LogLine { diff --git a/Locations.hs b/Locations.hs index 8c1915b02..7b8beb14f 100644 --- a/Locations.hs +++ b/Locations.hs @@ -11,7 +11,7 @@ module Locations ( ) where import Data.String.Utils -import AbstractTypes +import Types import qualified BackendTypes as Backend import qualified GitRepo as Git diff --git a/Remotes.hs b/Remotes.hs index 918ae2290..1802ff28e 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -9,8 +9,9 @@ module Remotes ( import Control.Monad.State (liftIO) import qualified Data.Map as Map import Data.String.Utils -import AbstractTypes +import Types import qualified GitRepo as Git +import qualified Annex import LocationLog import Locations import UUID @@ -23,7 +24,7 @@ list remotes = join " " $ map Git.repoDescribe remotes {- Cost ordered list of remotes that the LocationLog indicate may have a key. -} withKey :: Key -> Annex [Git.Repo] withKey key = do - g <- gitAnnex + g <- Annex.gitRepo uuids <- liftIO $ keyLocations g key allremotes <- remotesByCost remotes <- reposByUUID allremotes uuids @@ -36,7 +37,7 @@ withKey key = do {- Cost Ordered list of remotes. -} remotesByCost :: Annex [Git.Repo] remotesByCost = do - g <- gitAnnex + g <- Annex.gitRepo reposByCost $ Git.remotes g {- Orders a list of git repos by cost. -} @@ -57,7 +58,7 @@ reposByCost l = do -} repoCost :: Git.Repo -> Annex Int repoCost r = do - g <- gitAnnex + g <- Annex.gitRepo if ((length $ config g r) > 0) then return $ read $ config g r else if (Git.repoIsLocal r) @@ -76,10 +77,10 @@ ensureGitConfigRead r = do if (Map.null $ Git.configMap r) then do r' <- liftIO $ Git.configRead r - g <- gitAnnex + g <- Annex.gitRepo let l = Git.remotes g let g' = Git.remotesAdd g $ exchange l r' - gitAnnexChange g' + Annex.gitRepoChange g' return r' else return r where diff --git a/Types.hs b/Types.hs new file mode 100644 index 000000000..4262ed567 --- /dev/null +++ b/Types.hs @@ -0,0 +1,10 @@ +{- git-annex abstract data types -} + +module Types ( + Annex, + AnnexState, + Key, + Backend +) where + +import BackendTypes @@ -20,7 +20,8 @@ import List import System.Cmd.Utils import System.IO import qualified GitRepo as Git -import AbstractTypes +import Types +import qualified Annex type UUID = String @@ -45,22 +46,22 @@ getUUID r = do where configured r = Git.configGet r "annex.uuid" "" cached r = do - g <- gitAnnex + g <- Annex.gitRepo return $ Git.configGet g (configkey r) "" configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-uuid" {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () prepUUID = do - g <- gitAnnex + g <- Annex.gitRepo u <- getUUID g if ("" == u) then do uuid <- genUUID liftIO $ Git.run g ["config", configkey, uuid] -- re-read git config and update the repo's state - u' <- liftIO $ Git.configRead g - gitAnnexChange u' + g' <- liftIO $ Git.configRead g + Annex.gitRepoChange g' return () else return () diff --git a/git-annex.hs b/git-annex.hs index 2cf1c5305..ce3b2ac42 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -6,8 +6,9 @@ import System.IO import System.Environment import Control.Exception import CmdLine -import AbstractTypes -import Annex +import Types +import Commands +import qualified Annex main = do args <- getArgs @@ -30,7 +31,8 @@ tryRun state mode errnum oknum [] = do then error $ (show errnum) ++ " failed ; " ++ show (oknum) ++ " ok" else return () tryRun state mode errnum oknum (f:fs) = do - result <- try (runAnnexState state (dispatch mode f))::IO (Either SomeException ((), AnnexState)) + result <- try + (Annex.run state (dispatch mode f))::IO (Either SomeException ((), AnnexState)) case (result) of Left err -> do showErr err |