use a state monad

enormous reworking

Annex.hs

@@ -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
+{- Create and returns an Annex state object. 
- - later. -}
+ - Examines and prepares the git repo.
-startAnnex :: IO State
+ -}
+startAnnex :: IO AnnexState
 startAnnex = do
-	r <- gitRepoFromCwd
+	g <- gitRepoFromCwd
-	r' <- gitConfigRead r
+	let s = makeAnnexState g
-	r'' <- prepUUID r'
+	(_,s') <- runAnnexState s (prep g)
-	gitSetup r''
+	return s'
-
+	where
-	return State {
+		prep g = do
-		repo = r',
+			-- setup git and read its config; update state
-		backends = parseBackendList $ gitConfig r' "annex.backends" ""
+			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 :: FilePath -> Annex ()
-annexFile state file = inBackend file err $ do
+annexFile file = inBackend file err $ do
-	checkLegal file
+	liftIO $ checkLegal file
-	stored <- storeFile state 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
+		setup g key backend = do
-			logStatus state key ValuePresent
+			let dest = annexLocation g backend key
-			let dest = annexLocation (repo state) backend key
+			let reldest = annexLocationRelative g backend key
-			let reldest = annexLocationRelative (repo state) backend key
 			createDirectoryIfMissing True (parentDir dest)
 			renameFile file dest
 			createSymbolicLink ((linkTarget file) ++ reldest) file
-			gitRun (repo state) ["add", file]
+			gitRun g ["add", file]
-			gitRun (repo state) ["commit", "-m", 
+			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 :: FilePath -> Annex ()
-unannexFile state file = notinBackend file err $ \(key, backend) -> do
+unannexFile file = notinBackend file err $ \(key, backend) -> do
-	dropFile state backend key
+	dropFile backend key
-	logStatus state key ValueMissing
+	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 (repo state) ["rm", file]
+			gitRun g ["rm", file]
-	gitRun (repo state) ["commit", "-m",
+			gitRun g ["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 ()
-	where
-		err = error $ "not annexed " ++ file
 
 {- Gets an annexed file from one of the backends. -}
-annexGetFile :: State -> FilePath -> IO ()
+annexGetFile :: FilePath -> Annex ()
-annexGetFile state file = notinBackend file err $ \(key, backend) -> do
+annexGetFile file = notinBackend file err $ \(key, backend) -> do
-	inannex <- inAnnex state backend key
+	inannex <- inAnnex backend key
 	if (inannex)
 		then return ()
 		else do
-			let dest = annexLocation (repo state) backend key
+			g <- gitAnnex
-			createDirectoryIfMissing True (parentDir dest)
+			let dest = annexLocation g backend key
-			success <- retrieveFile state backend key dest
+			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 :: FilePath -> Annex ()
-annexWantFile state file = do error "not implemented" -- TODO
+annexWantFile file = do error "not implemented" -- TODO
 
 {- Indicates a file is not wanted. -}
-annexDropFile :: State -> FilePath -> IO ()
+annexDropFile :: FilePath -> Annex ()
-annexDropFile state file = do error "not implemented" -- TODO
+annexDropFile file = do error "not implemented" -- TODO
 
 {- Pushes all files to a remote repository. -}
-annexPushRepo :: State -> String -> IO ()
+annexPushRepo :: String -> Annex ()
-annexPushRepo state reponame = do error "not implemented" -- TODO
+annexPushRepo reponame = do error "not implemented" -- TODO
 
 {- Pulls all files from a remote repository. -}
-annexPullRepo :: State -> String -> IO ()
+annexPullRepo :: String -> Annex ()
-annexPullRepo state reponame = do error "not implemented" -- TODO
+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
+logStatus :: Key -> LogStatus -> Annex ()
-	f <- logChange (repo state) key (getUUID state (repo state)) status
+logStatus key status = do
-	gitRun (repo state) ["add", f]
+	g <- gitAnnex
-	gitRun (repo state) ["commit", "-m", "git-annex log update", f]
+	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 :: Backend -> Key -> Annex Bool
-inAnnex state backend key = doesFileExist $ annexLocation (repo state) backend key
+inAnnex backend key = do
+	g <- gitAnnex
+	liftIO $ doesFileExist $ annexLocation g backend key

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 :: FilePath -> Annex (Maybe (Key, Backend))
-storeFile state file = storeFile' (backends state) state file
+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
+storeFile' (b:bs) file relfile = do
-	try <- (getKey b) state (gitRelative (repo state) file)
+	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 :: Backend -> Key -> FilePath -> Annex Bool
-retrieveFile state backend key dest = (retrieveKeyFile backend) state key dest
+retrieveFile backend key dest = (retrieveKeyFile backend) key dest
 
 {- Drops a key from a backend. -}
-dropFile :: State -> Backend -> Key -> IO Bool
+dropFile :: Backend -> Key -> Annex Bool
-dropFile state backend key = (removeKey backend) state key
+dropFile backend key = (removeKey backend)  key
 
 {- Looks up the key and backend corresponding to an annexed file,
  - by examining what the file symlinks to. -}

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

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 :: FilePath -> Annex (Maybe Key)
-keyValue state file = return $ Just $ Key file
+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 :: FilePath -> Key -> Annex (Bool)
-dummyStore state file key = return True
+dummyStore file key = return True
-dummyRemove :: State -> Key -> IO Bool
+dummyRemove :: Key -> Annex Bool
-dummyRemove state url = return False
+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 :: Key -> FilePath -> Annex (Bool)
-copyKeyFile state key file = do
+copyKeyFile key file = do
-	remotes <- remotesWithKey state key
+	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: " ++

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 :: FilePath -> Annex (Maybe Key)
-keyValue repo file = return Nothing
+keyValue file = return Nothing
 
 -- cannot change url contents
-dummyStore :: State -> FilePath -> Key -> IO Bool
+dummyStore :: FilePath -> Key -> Annex Bool
-dummyStore repo file url = return False
+dummyStore file url = return False
-dummyRemove :: State -> Key -> IO Bool
+dummyRemove :: Key -> Annex Bool
-dummyRemove state url = return False
+dummyRemove url = return False
 
-downloadUrl :: State -> Key -> FilePath -> IO Bool
+downloadUrl :: Key -> FilePath -> Annex Bool
-downloadUrl state url file = do
+downloadUrl url file = do
-	putStrLn $ "download: " ++ (show url)
+	liftIO $ putStrLn $ "download: " ++ (show url)
-	result <- try $ rawSystem "curl" ["-#", "-o", file, (show url)]
+	result <- liftIO $ try $ rawSystem "curl" ["-#", "-o", file, (show url)]
 	case (result) of
 		Left _ -> return False
 		Right _ -> return True

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 :: Mode -> FilePath -> Annex ()
-dispatch state mode item = do
+dispatch mode item = do
 	case (mode) of
-		Add     -> annexFile state item
+		Add     -> annexFile item
-		Push    -> annexPushRepo state item
+		Push    -> annexPushRepo item
-		Pull    -> annexPullRepo state item
+		Pull    -> annexPullRepo item
-		Want    -> annexWantFile state item
+		Want    -> annexWantFile item
-		Get     -> annexGetFile state item
+		Get     -> annexGetFile item
-		Drop    -> annexDropFile state item
+		Drop    -> annexDropFile item
-		Unannex -> unannexFile state item
+		Unannex -> unannexFile item

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 :: Key -> Annex [GitRepo]
-remotesWithKey state key = do
+remotesWithKey key = do
-	uuids <- keyLocations (repo state) key
+	g <- gitAnnex
-	return $ reposByUUID state (remotesByCost state) uuids
+	uuids <- liftIO $ keyLocations g key
+	remotes <- remotesByCost
+	reposByUUID remotes uuids
 
 {- Cost Ordered list of remotes. -}
-remotesByCost :: State -> [GitRepo]
+remotesByCost :: Annex [GitRepo]
-remotesByCost state = reposByCost state $ gitConfigRemotes (repo state)
+remotesByCost = do
+	g <- gitAnnex
+	reposByCost $ gitConfigRemotes g
 
 {- Orders a list of git repos by cost. -}
-reposByCost :: State -> [GitRepo] -> [GitRepo]
+reposByCost :: [GitRepo] -> Annex [GitRepo]
-reposByCost state l =
+reposByCost l = do
-	fst $ unzip $ sortBy (\(r1, c1) (r2, c2) -> compare c1 c2) $ costpairs l
+	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 :: GitRepo -> Annex Int
-repoCost state r = 
+repoCost r = do
-	if ((length $ config state r) > 0)
+	g <- gitAnnex
-		then read $ config state r
+	if ((length $ config g r) > 0)
+		then return $ read $ config g r
 		else if (gitRepoIsLocal r)
-			then 100
+			then return 100
-			else 200
+			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"

TODO

@@ -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
 

Types.hs

@@ -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

UUID.hs

@@ -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 :: Annex UUID
-genUUID = do
+genUUID = liftIO $ pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h
-	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 :: GitRepo -> Annex UUID
-getUUID s r = 
+getUUID r = do
-	if ("" /= getUUID' r)
+	if ("" /= configured r)
-		then getUUID' r
+		then return $ configured r
-		else cached s 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 :: Annex ()
-prepUUID repo =
+prepUUID = do
-	if ("" == getUUID' repo)
+	g <- gitAnnex
+	u <- getUUID g
+	if ("" == u)
 		then do
 			uuid <- genUUID
-			gitRun repo ["config", configkey, uuid]
+			liftIO $ gitRun g ["config", configkey, uuid]
-			-- return new repo with updated config
+			-- re-read git config and update the repo's state
-			gitConfigRead repo
+			u' <- liftIO $ gitConfigRead g
-		else return repo
+			gitAnnexChange u'
+			return ()
+		else return ()
 
 {- Filters a list of repos to ones that have listed UUIDs. -}
-reposByUUID :: State -> [GitRepo] -> [UUID] -> [GitRepo]
+reposByUUID :: [GitRepo] -> [UUID] -> Annex [GitRepo]
-reposByUUID state repos uuids =
+reposByUUID repos uuids = do
-	filter (\r -> isJust $ elemIndex (getUUID state r) uuids) repos
+	filterM match repos
+	where
+		match r = do
+			u <- getUUID r
+			return $ isJust $ elemIndex u uuids

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
+{- Processes each param in the list by dispatching the handler function
-
+ - for the user-selection operation mode. Catches exceptions, not stopping
-{- Tries to run a series of actions, not stopping if some error out,
+ - if some error out, and propigates an overall error status at the end.
- - and propigating an overall error status at the end. -}
+ -
-tryRun errnum oknum [] = do
+ - 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
+tryRun state mode errnum oknum (f:fs) = do
-	result <- try (a)::IO (Either SomeException ())
+	result <- try (runAnnexState state (dispatch mode f))::IO (Either SomeException ((), AnnexState))
 	case (result) of
 		Left err -> do
 			showErr err
-			tryRun (errnum + 1) oknum as
+			tryRun state mode (errnum + 1) oknum fs
-		Right _ -> tryRun errnum (oknum + 1) as
+		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 ()