parameterize Backend type
This allows the Backend type to not depend on the Annex type, and so the Annex type can later be moved out of TypeInternals.
This commit is contained in:
parent
f8e303e1c9
commit
109a719b03
14 changed files with 43 additions and 41 deletions
11
Annex.hs
11
Annex.hs
|
@ -33,14 +33,15 @@ import Types
|
||||||
import qualified TypeInternals as Internals
|
import qualified TypeInternals as Internals
|
||||||
|
|
||||||
{- Create and returns an Annex state object for the specified git repo. -}
|
{- Create and returns an Annex state object for the specified git repo. -}
|
||||||
new :: Git.Repo -> [Backend] -> IO AnnexState
|
new :: Git.Repo -> [Backend Annex] -> IO AnnexState
|
||||||
new gitrepo allbackends = do
|
new gitrepo allbackends = do
|
||||||
let s = Internals.AnnexState {
|
let s = Internals.AnnexState {
|
||||||
Internals.repo = gitrepo,
|
Internals.repo = gitrepo,
|
||||||
Internals.backends = [],
|
Internals.backends = [],
|
||||||
Internals.supportedBackends = allbackends,
|
Internals.supportedBackends = allbackends,
|
||||||
Internals.flags = M.empty,
|
Internals.flags = M.empty,
|
||||||
Internals.repoqueue = GitQueue.empty
|
Internals.repoqueue = GitQueue.empty,
|
||||||
|
Internals.quiet = False
|
||||||
}
|
}
|
||||||
(_,s') <- Annex.run s prep
|
(_,s') <- Annex.run s prep
|
||||||
return s'
|
return s'
|
||||||
|
@ -69,19 +70,19 @@ gitRepoChange r = do
|
||||||
put state { Internals.repo = r }
|
put state { Internals.repo = r }
|
||||||
|
|
||||||
{- Returns the backends being used. -}
|
{- Returns the backends being used. -}
|
||||||
backends :: Annex [Backend]
|
backends :: Annex [Backend Annex]
|
||||||
backends = do
|
backends = do
|
||||||
state <- get
|
state <- get
|
||||||
return (Internals.backends state)
|
return (Internals.backends state)
|
||||||
|
|
||||||
{- Sets the backends to use. -}
|
{- Sets the backends to use. -}
|
||||||
backendsChange :: [Backend] -> Annex ()
|
backendsChange :: [Backend Annex] -> Annex ()
|
||||||
backendsChange b = do
|
backendsChange b = do
|
||||||
state <- get
|
state <- get
|
||||||
put state { Internals.backends = b }
|
put state { Internals.backends = b }
|
||||||
|
|
||||||
{- Returns the full list of supported backends. -}
|
{- Returns the full list of supported backends. -}
|
||||||
supportedBackends :: Annex [Backend]
|
supportedBackends :: Annex [Backend Annex]
|
||||||
supportedBackends = do
|
supportedBackends = do
|
||||||
state <- get
|
state <- get
|
||||||
return (Internals.supportedBackends state)
|
return (Internals.supportedBackends state)
|
||||||
|
|
22
Backend.hs
22
Backend.hs
|
@ -42,7 +42,7 @@ import qualified TypeInternals as Internals
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
{- List of backends in the order to try them when storing a new key. -}
|
{- List of backends in the order to try them when storing a new key. -}
|
||||||
list :: Annex [Backend]
|
list :: Annex [Backend Annex]
|
||||||
list = do
|
list = do
|
||||||
l <- Annex.backends -- list is cached here
|
l <- Annex.backends -- list is cached here
|
||||||
if not $ null l
|
if not $ null l
|
||||||
|
@ -64,12 +64,12 @@ list = do
|
||||||
else map (lookupBackendName bs) $ words s
|
else map (lookupBackendName bs) $ words s
|
||||||
|
|
||||||
{- Looks up a backend in a list. May fail if unknown. -}
|
{- Looks up a backend in a list. May fail if unknown. -}
|
||||||
lookupBackendName :: [Backend] -> String -> Backend
|
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
|
||||||
lookupBackendName bs s =
|
lookupBackendName bs s =
|
||||||
case maybeLookupBackendName bs s of
|
case maybeLookupBackendName bs s of
|
||||||
Just b -> b
|
Just b -> b
|
||||||
Nothing -> error $ "unknown backend " ++ s
|
Nothing -> error $ "unknown backend " ++ s
|
||||||
maybeLookupBackendName :: [Backend] -> String -> Maybe Backend
|
maybeLookupBackendName :: [Backend Annex] -> String -> Maybe (Backend Annex)
|
||||||
maybeLookupBackendName bs s =
|
maybeLookupBackendName bs s =
|
||||||
if 1 /= length matches
|
if 1 /= length matches
|
||||||
then Nothing
|
then Nothing
|
||||||
|
@ -77,14 +77,14 @@ maybeLookupBackendName bs s =
|
||||||
where matches = filter (\b -> s == Internals.name b) bs
|
where matches = filter (\b -> s == Internals.name b) bs
|
||||||
|
|
||||||
{- Attempts to store a file in one of the backends. -}
|
{- Attempts to store a file in one of the backends. -}
|
||||||
storeFileKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend))
|
storeFileKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
|
||||||
storeFileKey file trybackend = do
|
storeFileKey file trybackend = do
|
||||||
bs <- list
|
bs <- list
|
||||||
let bs' = case trybackend of
|
let bs' = case trybackend of
|
||||||
Nothing -> bs
|
Nothing -> bs
|
||||||
Just backend -> backend:bs
|
Just backend -> backend:bs
|
||||||
storeFileKey' bs' file
|
storeFileKey' bs' file
|
||||||
storeFileKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend))
|
storeFileKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
|
||||||
storeFileKey' [] _ = return Nothing
|
storeFileKey' [] _ = return Nothing
|
||||||
storeFileKey' (b:bs) file = do
|
storeFileKey' (b:bs) file = do
|
||||||
result <- (Internals.getKey b) file
|
result <- (Internals.getKey b) file
|
||||||
|
@ -100,11 +100,11 @@ storeFileKey' (b:bs) file = do
|
||||||
|
|
||||||
{- Attempts to retrieve an key from one of the backends, saving it to
|
{- Attempts to retrieve an key from one of the backends, saving it to
|
||||||
- a specified location. -}
|
- a specified location. -}
|
||||||
retrieveKeyFile :: Backend -> Key -> FilePath -> Annex Bool
|
retrieveKeyFile :: Backend Annex -> Key -> FilePath -> Annex Bool
|
||||||
retrieveKeyFile backend key dest = (Internals.retrieveKeyFile backend) key dest
|
retrieveKeyFile backend key dest = (Internals.retrieveKeyFile backend) key dest
|
||||||
|
|
||||||
{- Removes a key from a backend. -}
|
{- Removes a key from a backend. -}
|
||||||
removeKey :: Backend -> Key -> Maybe Int -> Annex Bool
|
removeKey :: Backend Annex -> Key -> Maybe Int -> Annex Bool
|
||||||
removeKey backend key numcopies = (Internals.removeKey backend) key numcopies
|
removeKey backend key numcopies = (Internals.removeKey backend) key numcopies
|
||||||
|
|
||||||
{- Checks if a key is present in its backend. -}
|
{- Checks if a key is present in its backend. -}
|
||||||
|
@ -114,12 +114,12 @@ hasKey key = do
|
||||||
(Internals.hasKey backend) key
|
(Internals.hasKey backend) key
|
||||||
|
|
||||||
{- Checks a key's backend for problems. -}
|
{- Checks a key's backend for problems. -}
|
||||||
fsckKey :: Backend -> Key -> Maybe Int -> Annex Bool
|
fsckKey :: Backend Annex -> Key -> Maybe Int -> Annex Bool
|
||||||
fsckKey backend key numcopies = (Internals.fsckKey backend) key numcopies
|
fsckKey backend key numcopies = (Internals.fsckKey backend) key numcopies
|
||||||
|
|
||||||
{- Looks up the key and backend corresponding to an annexed file,
|
{- Looks up the key and backend corresponding to an annexed file,
|
||||||
- by examining what the file symlinks to. -}
|
- by examining what the file symlinks to. -}
|
||||||
lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
|
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex))
|
||||||
lookupFile file = do
|
lookupFile file = do
|
||||||
bs <- Annex.supportedBackends
|
bs <- Annex.supportedBackends
|
||||||
tl <- liftIO $ try getsymlink
|
tl <- liftIO $ try getsymlink
|
||||||
|
@ -147,7 +147,7 @@ lookupFile file = do
|
||||||
{- Looks up the backends that should be used for each file in a list.
|
{- Looks up the backends that should be used for each file in a list.
|
||||||
- That can be configured on a per-file basis in the gitattributes file.
|
- That can be configured on a per-file basis in the gitattributes file.
|
||||||
-}
|
-}
|
||||||
chooseBackends :: [FilePath] -> Annex [(FilePath, Maybe Backend)]
|
chooseBackends :: [FilePath] -> Annex [(FilePath, Maybe (Backend Annex))]
|
||||||
chooseBackends fs = do
|
chooseBackends fs = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
bs <- Annex.supportedBackends
|
bs <- Annex.supportedBackends
|
||||||
|
@ -155,7 +155,7 @@ chooseBackends fs = do
|
||||||
return $ map (\(f,b) -> (f, maybeLookupBackendName bs b)) pairs
|
return $ map (\(f,b) -> (f, maybeLookupBackendName bs b)) pairs
|
||||||
|
|
||||||
{- Returns the backend to use for a key. -}
|
{- Returns the backend to use for a key. -}
|
||||||
keyBackend :: Key -> Annex Backend
|
keyBackend :: Key -> Annex (Backend Annex)
|
||||||
keyBackend key = do
|
keyBackend key = do
|
||||||
bs <- Annex.supportedBackends
|
bs <- Annex.supportedBackends
|
||||||
return $ lookupBackendName bs $ backendName key
|
return $ lookupBackendName bs $ backendName key
|
||||||
|
|
|
@ -27,7 +27,7 @@ import qualified Annex
|
||||||
import UUID
|
import UUID
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
backend :: Backend
|
backend :: Backend Annex
|
||||||
backend = Backend {
|
backend = Backend {
|
||||||
name = mustProvide,
|
name = mustProvide,
|
||||||
getKey = mustProvide,
|
getKey = mustProvide,
|
||||||
|
|
|
@ -20,7 +20,7 @@ import qualified Annex
|
||||||
import Locations
|
import Locations
|
||||||
import Content
|
import Content
|
||||||
|
|
||||||
backend :: Backend
|
backend :: Backend Annex
|
||||||
backend = Backend.File.backend {
|
backend = Backend.File.backend {
|
||||||
name = "SHA1",
|
name = "SHA1",
|
||||||
getKey = keyValue,
|
getKey = keyValue,
|
||||||
|
|
|
@ -14,7 +14,7 @@ import TypeInternals
|
||||||
import Utility
|
import Utility
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
backend :: Backend
|
backend :: Backend Annex
|
||||||
backend = Backend {
|
backend = Backend {
|
||||||
name = "URL",
|
name = "URL",
|
||||||
getKey = keyValue,
|
getKey = keyValue,
|
||||||
|
|
|
@ -21,7 +21,7 @@ import qualified Annex
|
||||||
import Content
|
import Content
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
backend :: Backend
|
backend :: Backend Annex
|
||||||
backend = Backend.File.backend {
|
backend = Backend.File.backend {
|
||||||
name = "WORM",
|
name = "WORM",
|
||||||
getKey = keyValue,
|
getKey = keyValue,
|
||||||
|
|
|
@ -13,7 +13,7 @@ import qualified Backend.SHA1
|
||||||
import qualified Backend.URL
|
import qualified Backend.URL
|
||||||
import Types
|
import Types
|
||||||
|
|
||||||
allBackends :: [Backend]
|
allBackends :: [Backend Annex]
|
||||||
allBackends =
|
allBackends =
|
||||||
[ Backend.WORM.backend
|
[ Backend.WORM.backend
|
||||||
, Backend.SHA1.backend
|
, Backend.SHA1.backend
|
||||||
|
|
|
@ -43,7 +43,7 @@ type CommandCleanup = Annex Bool
|
||||||
- functions. -}
|
- functions. -}
|
||||||
type CommandSeekStrings = CommandStartString -> CommandSeek
|
type CommandSeekStrings = CommandStartString -> CommandSeek
|
||||||
type CommandStartString = String -> CommandStart
|
type CommandStartString = String -> CommandStart
|
||||||
type BackendFile = (FilePath, Maybe Backend)
|
type BackendFile = (FilePath, Maybe (Backend Annex))
|
||||||
type CommandSeekBackendFiles = CommandStartBackendFile -> CommandSeek
|
type CommandSeekBackendFiles = CommandStartBackendFile -> CommandSeek
|
||||||
type CommandStartBackendFile = BackendFile -> CommandStart
|
type CommandStartBackendFile = BackendFile -> CommandStart
|
||||||
type AttrFile = (FilePath, String)
|
type AttrFile = (FilePath, String)
|
||||||
|
@ -95,7 +95,7 @@ notAnnexed file a = do
|
||||||
Just _ -> return Nothing
|
Just _ -> return Nothing
|
||||||
Nothing -> a
|
Nothing -> a
|
||||||
|
|
||||||
isAnnexed :: FilePath -> ((Key, Backend) -> Annex (Maybe a)) -> Annex (Maybe a)
|
isAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex (Maybe a)) -> Annex (Maybe a)
|
||||||
isAnnexed file a = do
|
isAnnexed file a = do
|
||||||
r <- Backend.lookupFile file
|
r <- Backend.lookupFile file
|
||||||
case r of
|
case r of
|
||||||
|
|
|
@ -37,7 +37,7 @@ start (file, attr) = isAnnexed file $ \(key, backend) -> do
|
||||||
where
|
where
|
||||||
numcopies = readMaybe attr :: Maybe Int
|
numcopies = readMaybe attr :: Maybe Int
|
||||||
|
|
||||||
perform :: Key -> Backend -> Maybe Int -> CommandPerform
|
perform :: Key -> Backend Annex -> Maybe Int -> CommandPerform
|
||||||
perform key backend numcopies = do
|
perform key backend numcopies = do
|
||||||
success <- Backend.removeKey backend key numcopies
|
success <- Backend.removeKey backend key numcopies
|
||||||
if success
|
if success
|
||||||
|
|
|
@ -28,7 +28,7 @@ start (file, attr) = isAnnexed file $ \(key, backend) -> do
|
||||||
where
|
where
|
||||||
numcopies = readMaybe attr :: Maybe Int
|
numcopies = readMaybe attr :: Maybe Int
|
||||||
|
|
||||||
perform :: Key -> Backend -> Maybe Int -> CommandPerform
|
perform :: Key -> Backend Annex -> Maybe Int -> CommandPerform
|
||||||
perform key backend numcopies = do
|
perform key backend numcopies = do
|
||||||
success <- Backend.fsckKey backend key numcopies
|
success <- Backend.fsckKey backend key numcopies
|
||||||
if success
|
if success
|
||||||
|
|
|
@ -30,7 +30,7 @@ start file = isAnnexed file $ \(key, backend) -> do
|
||||||
showStart "get" file
|
showStart "get" file
|
||||||
return $ Just $ perform key backend
|
return $ Just $ perform key backend
|
||||||
|
|
||||||
perform :: Key -> Backend -> CommandPerform
|
perform :: Key -> Backend Annex -> CommandPerform
|
||||||
perform key backend = do
|
perform key backend = do
|
||||||
ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
|
ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
|
||||||
if ok
|
if ok
|
||||||
|
|
|
@ -42,7 +42,7 @@ start (file, b) = isAnnexed file $ \(key, oldbackend) -> do
|
||||||
return $ head backends
|
return $ head backends
|
||||||
choosebackend (Just backend) = return backend
|
choosebackend (Just backend) = return backend
|
||||||
|
|
||||||
perform :: FilePath -> Key -> Backend -> CommandPerform
|
perform :: FilePath -> Key -> Backend Annex -> CommandPerform
|
||||||
perform file oldkey newbackend = do
|
perform file oldkey newbackend = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
|
|
||||||
|
|
|
@ -36,7 +36,7 @@ start file = isAnnexed file $ \(key, backend) -> do
|
||||||
return $ Just $ perform file key backend
|
return $ Just $ perform file key backend
|
||||||
else return Nothing
|
else return Nothing
|
||||||
|
|
||||||
perform :: FilePath -> Key -> Backend -> CommandPerform
|
perform :: FilePath -> Key -> Backend Annex -> CommandPerform
|
||||||
perform file key backend = do
|
perform file key backend = do
|
||||||
-- force backend to always remove
|
-- force backend to always remove
|
||||||
ok <- Backend.removeKey backend key (Just 0)
|
ok <- Backend.removeKey backend key (Just 0)
|
||||||
|
|
|
@ -28,10 +28,11 @@ data Flag =
|
||||||
-- but it uses Backend, so has to be here to avoid a depends loop.
|
-- but it uses Backend, so has to be here to avoid a depends loop.
|
||||||
data AnnexState = AnnexState {
|
data AnnexState = AnnexState {
|
||||||
repo :: Git.Repo,
|
repo :: Git.Repo,
|
||||||
backends :: [Backend],
|
backends :: [Backend Annex],
|
||||||
supportedBackends :: [Backend],
|
supportedBackends :: [Backend Annex],
|
||||||
flags :: M.Map FlagName Flag,
|
flags :: M.Map FlagName Flag,
|
||||||
repoqueue :: GitQueue.Queue
|
repoqueue :: GitQueue.Queue,
|
||||||
|
quiet :: Bool
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
-- git-annex's monad
|
-- git-annex's monad
|
||||||
|
@ -43,7 +44,7 @@ type BackendName = String
|
||||||
data Key = Key (BackendName, KeyName) deriving (Eq, Ord)
|
data Key = Key (BackendName, KeyName) deriving (Eq, Ord)
|
||||||
|
|
||||||
-- constructs a key in a backend
|
-- constructs a key in a backend
|
||||||
genKey :: Backend -> KeyName -> Key
|
genKey :: Backend a -> KeyName -> Key
|
||||||
genKey b f = Key (name b,f)
|
genKey b f = Key (name b,f)
|
||||||
|
|
||||||
-- show a key to convert it to a string; the string includes the
|
-- show a key to convert it to a string; the string includes the
|
||||||
|
@ -77,28 +78,28 @@ keyName :: Key -> KeyName
|
||||||
keyName (Key (_,k)) = k
|
keyName (Key (_,k)) = k
|
||||||
|
|
||||||
-- this structure represents a key-value backend
|
-- this structure represents a key-value backend
|
||||||
data Backend = Backend {
|
data Backend a = Backend {
|
||||||
-- name of this backend
|
-- name of this backend
|
||||||
name :: String,
|
name :: String,
|
||||||
-- converts a filename to a key
|
-- converts a filename to a key
|
||||||
getKey :: FilePath -> Annex (Maybe Key),
|
getKey :: FilePath -> a (Maybe Key),
|
||||||
-- stores a file's contents to a key
|
-- stores a file's contents to a key
|
||||||
storeFileKey :: FilePath -> Key -> Annex Bool,
|
storeFileKey :: FilePath -> Key -> a Bool,
|
||||||
-- retrieves a key's contents to a file
|
-- retrieves a key's contents to a file
|
||||||
retrieveKeyFile :: Key -> FilePath -> Annex Bool,
|
retrieveKeyFile :: Key -> FilePath -> a Bool,
|
||||||
-- removes a key, optionally checking that enough copies are stored
|
-- removes a key, optionally checking that enough copies are stored
|
||||||
-- elsewhere
|
-- elsewhere
|
||||||
removeKey :: Key -> Maybe Int -> Annex Bool,
|
removeKey :: Key -> Maybe Int -> a Bool,
|
||||||
-- checks if a backend is storing the content of a key
|
-- checks if a backend is storing the content of a key
|
||||||
hasKey :: Key -> Annex Bool,
|
hasKey :: Key -> a Bool,
|
||||||
-- called during fsck to check a key
|
-- called during fsck to check a key
|
||||||
-- (second parameter may be the number of copies that there should
|
-- (second parameter may be the number of copies that there should
|
||||||
-- be of the key)
|
-- be of the key)
|
||||||
fsckKey :: Key -> Maybe Int -> Annex Bool
|
fsckKey :: Key -> Maybe Int -> a Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show Backend where
|
instance Show (Backend a) where
|
||||||
show backend = "Backend { name =\"" ++ name backend ++ "\" }"
|
show backend = "Backend { name =\"" ++ name backend ++ "\" }"
|
||||||
|
|
||||||
instance Eq Backend where
|
instance Eq (Backend a) where
|
||||||
a == b = name a == name b
|
a == b = name a == name b
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue