update
This commit is contained in:
		
					parent
					
						
							
								e5514e0cb0
							
						
					
				
			
			
				commit
				
					
						026adce5a0
					
				
			
		
					 5 changed files with 27 additions and 17 deletions
				
			
		
							
								
								
									
										18
									
								
								Annex.hs
									
										
									
									
									
								
							
							
						
						
									
										18
									
								
								Annex.hs
									
										
									
									
									
								
							| 
						 | 
					@ -10,26 +10,32 @@ import Utility
 | 
				
			||||||
import Locations
 | 
					import Locations
 | 
				
			||||||
import Types
 | 
					import Types
 | 
				
			||||||
import Backend
 | 
					import Backend
 | 
				
			||||||
 | 
					import BackendList
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					startAnnex :: IO State
 | 
				
			||||||
 | 
					startAnnex = do
 | 
				
			||||||
 | 
						r <- currentRepo
 | 
				
			||||||
 | 
						return State { repo = r,  backends = supportedBackends }
 | 
				
			||||||
 | 
					
 | 
				
			||||||
{- Annexes a file, storing it in a backend, and then moving it into
 | 
					{- 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. -}
 | 
					 - the annex directory and setting up the symlink pointing to its content. -}
 | 
				
			||||||
annexFile :: [Backend] -> GitRepo -> FilePath -> IO ()
 | 
					annexFile :: State -> FilePath -> IO ()
 | 
				
			||||||
annexFile backends repo file = do
 | 
					annexFile state file = do
 | 
				
			||||||
	alreadyannexed <- lookupBackend backends repo file
 | 
						alreadyannexed <- lookupBackend (backends state) (repo state) file
 | 
				
			||||||
	case (alreadyannexed) of
 | 
						case (alreadyannexed) of
 | 
				
			||||||
		Just _ -> error $ "already annexed " ++ file
 | 
							Just _ -> error $ "already annexed " ++ file
 | 
				
			||||||
		Nothing -> do
 | 
							Nothing -> do
 | 
				
			||||||
			stored <- storeFile backends repo file
 | 
								stored <- storeFile (backends state) (repo state) file
 | 
				
			||||||
			case (stored) of
 | 
								case (stored) of
 | 
				
			||||||
				Nothing -> error $ "no backend could store " ++ file
 | 
									Nothing -> error $ "no backend could store " ++ file
 | 
				
			||||||
				Just key -> symlink key
 | 
									Just key -> symlink key
 | 
				
			||||||
	where
 | 
						where
 | 
				
			||||||
		symlink key = do
 | 
							symlink key = do
 | 
				
			||||||
			dest <- annexDir repo key
 | 
								dest <- annexDir (repo state) key
 | 
				
			||||||
			createDirectoryIfMissing True (parentDir dest)
 | 
								createDirectoryIfMissing True (parentDir dest)
 | 
				
			||||||
			renameFile file dest
 | 
								renameFile file dest
 | 
				
			||||||
			createSymbolicLink dest file
 | 
								createSymbolicLink dest file
 | 
				
			||||||
			gitAdd repo file
 | 
								gitAdd (repo state) file
 | 
				
			||||||
 | 
					
 | 
				
			||||||
{- 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 ()
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -34,8 +34,8 @@ argvToFlags argv = do
 | 
				
			||||||
		(_,n,errs) -> ioError (userError (concat errs ++ usageInfo header options))
 | 
							(_,n,errs) -> ioError (userError (concat errs ++ usageInfo header options))
 | 
				
			||||||
	where header = "Usage: git-annex [option] file"
 | 
						where header = "Usage: git-annex [option] file"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
dispatch :: Flag -> [Backend] -> GitRepo -> IO ()
 | 
					dispatch :: Flag -> State -> IO ()
 | 
				
			||||||
dispatch flag backends repo = do
 | 
					dispatch flag state = do
 | 
				
			||||||
	case (flag) of
 | 
						case (flag) of
 | 
				
			||||||
		Add f -> annexFile backends repo f
 | 
							Add f -> annexFile state f
 | 
				
			||||||
		_ -> error "not implemented"
 | 
							_ -> error "not implemented"
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -8,7 +8,6 @@ import System.Path
 | 
				
			||||||
import Data.String.Utils
 | 
					import Data.String.Utils
 | 
				
			||||||
import Utility
 | 
					import Utility
 | 
				
			||||||
import Types
 | 
					import Types
 | 
				
			||||||
import BackendList
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
{- GitRepo constructor -}
 | 
					{- GitRepo constructor -}
 | 
				
			||||||
gitRepo :: FilePath -> IO GitRepo
 | 
					gitRepo :: FilePath -> IO GitRepo
 | 
				
			||||||
| 
						 | 
					@ -16,8 +15,7 @@ gitRepo dir = do
 | 
				
			||||||
	-- TOOD query repo for configuration settings; other repositories; etc
 | 
						-- TOOD query repo for configuration settings; other repositories; etc
 | 
				
			||||||
	return GitRepo {
 | 
						return GitRepo {
 | 
				
			||||||
		top = dir,
 | 
							top = dir,
 | 
				
			||||||
		remotes = [],
 | 
							remotes = []
 | 
				
			||||||
		backends = supportedBackends
 | 
					 | 
				
			||||||
	}
 | 
						}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
{- Path to a repository's gitattributes file. -}
 | 
					{- Path to a repository's gitattributes file. -}
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
							
								
								
									
										11
									
								
								Types.hs
									
										
									
									
									
								
							
							
						
						
									
										11
									
								
								Types.hs
									
										
									
									
									
								
							| 
						 | 
					@ -3,8 +3,10 @@
 | 
				
			||||||
 | 
					
 | 
				
			||||||
module Types where
 | 
					module Types where
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					-- annexed filenames are mapped into keys
 | 
				
			||||||
type Key = String
 | 
					type Key = String
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					-- this structure represents a key/value backend
 | 
				
			||||||
data Backend = Backend {
 | 
					data Backend = Backend {
 | 
				
			||||||
	-- name of this backend
 | 
						-- name of this backend
 | 
				
			||||||
	name :: String,
 | 
						name :: String,
 | 
				
			||||||
| 
						 | 
					@ -16,9 +18,14 @@ data Backend = Backend {
 | 
				
			||||||
	retrieveKeyFile :: IO Key -> FilePath -> IO (Bool)
 | 
						retrieveKeyFile :: IO Key -> FilePath -> IO (Bool)
 | 
				
			||||||
}
 | 
					}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					-- a git repository
 | 
				
			||||||
data GitRepo = GitRepo {
 | 
					data GitRepo = GitRepo {
 | 
				
			||||||
	top :: FilePath,
 | 
						top :: FilePath,
 | 
				
			||||||
	remotes :: [GitRepo],
 | 
						remotes :: [GitRepo]
 | 
				
			||||||
	backends :: [Backend]
 | 
					 | 
				
			||||||
}
 | 
					}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					-- git-annex's runtime state
 | 
				
			||||||
 | 
					data State = State {
 | 
				
			||||||
 | 
						repo :: GitRepo,
 | 
				
			||||||
 | 
						backends :: [Backend]
 | 
				
			||||||
 | 
					}
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -11,7 +11,6 @@ main = do
 | 
				
			||||||
	args <- getArgs
 | 
						args <- getArgs
 | 
				
			||||||
	flags <- argvToFlags args
 | 
						flags <- argvToFlags args
 | 
				
			||||||
	
 | 
						
 | 
				
			||||||
	repo <- currentRepo
 | 
						state <- startAnnex
 | 
				
			||||||
	gitPrep repo
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
	mapM (\f -> dispatch f supportedBackends repo) flags
 | 
						mapM (\f -> dispatch f state) flags
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue