diff options
| -rw-r--r-- | Commands.hs | 58 | ||||
| -rw-r--r-- | Core.hs | 87 | ||||
| -rw-r--r-- | git-annex.hs | 41 |
3 files changed, 98 insertions, 88 deletions
diff --git a/Commands.hs b/Commands.hs index 98e65b126..be61c7c64 100644 --- a/Commands.hs +++ b/Commands.hs @@ -1,7 +1,6 @@ {- git-annex subcommands -} module Commands ( - start, annexCmd, unannexCmd, getCmd, @@ -26,32 +25,6 @@ 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 () @@ -146,30 +119,6 @@ pushCmd reponame = do error "not implemented" -- TODO 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 @@ -182,6 +131,13 @@ logStatus key status = do Git.run g ["add", f] Git.run g ["commit", "-m", "git-annex log update", f] +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 + {- Checks if a given key is currently present in the annexLocation -} inAnnex :: Backend -> Key -> Annex Bool inAnnex backend key = do diff --git a/Core.hs b/Core.hs new file mode 100644 index 000000000..e3d2c6403 --- /dev/null +++ b/Core.hs @@ -0,0 +1,87 @@ +{- git-annex core functions -} + +module Core where + +import System.IO +import System.Directory +import Control.Monad.State (liftIO) +import Control.Exception +import CmdLine +import Types +import BackendList +import Locations +import UUID +import qualified GitRepo as Git +import qualified Annex + +{- 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 + +{- 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 -> [String] -> IO () +tryRun state mode params = tryRun' state mode 0 0 params +tryRun' state mode errnum oknum [] = do + if (errnum > 0) + then error $ (show errnum) ++ " failed ; " ++ show (oknum) ++ " ok" + else return () +tryRun' state mode errnum oknum (f:fs) = do + result <- try + (Annex.run state (dispatch mode f))::IO (Either SomeException ((), AnnexState)) + case (result) of + Left err -> do + showErr err + tryRun' state mode (errnum + 1) oknum fs + Right (_,state') -> tryRun' state' mode errnum (oknum + 1) fs + +{- Exception pretty-printing. -} +showErr e = do + hPutStrLn stderr $ "git-annex: " ++ (show e) + return () + +{- 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] diff --git a/git-annex.hs b/git-annex.hs index ce3b2ac42..b326b2b19 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -1,45 +1,12 @@ -{- git-annex main program - - -} +{- git-annex main program -} -import Control.Monad.State -import System.IO import System.Environment -import Control.Exception -import CmdLine -import Types -import Commands import qualified Annex +import Core +import CmdLine main = do args <- getArgs (mode, params) <- argvToMode args state <- start - tryRun state mode 0 0 params - -{- 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 state mode errnum oknum (f:fs) = do - result <- try - (Annex.run state (dispatch mode f))::IO (Either SomeException ((), AnnexState)) - case (result) of - Left err -> do - showErr err - tryRun state mode (errnum + 1) oknum fs - Right (_,state') -> tryRun state' mode errnum (oknum + 1) fs - -{- Exception pretty-printing. -} -showErr e = do - hPutStrLn stderr $ "git-annex: " ++ (show e) - return () + tryRun state mode params |