mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

boilerplate reduction

Browse source
This commit is contained in:
Joey Hess 2011-03-30 14:00:54 -04:00
parent a47ed922e1
commit 619f07ee6a
6 changed files with 90 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Remote.hs
View file

@ -75,7 +75,8 @@ genList = do
mapM (gen m t) l' mapM (gen m t) l'
gen m t r = do gen m t r = do
u <- getUUID r u <- getUUID r
generate t r (M.lookup u m) cst <- remoteCost r
generate t r u cst (M.lookup u m)
{- Looks up a remote by name. (Or by UUID.) -} {- Looks up a remote by name. (Or by UUID.) -}
byName :: String -> Annex (Remote Annex) byName :: String -> Annex (Remote Annex)

36
Remote/Directory.hs
View file

@ -11,7 +11,6 @@ import IO
import Control.Exception.Extensible (IOException) import Control.Exception.Extensible (IOException)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import Data.String.Utils
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import System.Directory (doesDirectoryExist, doesFileExist, removeFile) import System.Directory (doesDirectoryExist, doesFileExist, removeFile)
@ -22,41 +21,21 @@ import Types
import qualified GitRepo as Git import qualified GitRepo as Git
import qualified Annex import qualified Annex
import UUID import UUID
import Config
import Utility import Utility
import Locations import Locations
import CopyFile import CopyFile
import Remote.Special
remote :: RemoteType Annex remote :: RemoteType Annex
remote = RemoteType { remote = RemoteType {
typename = "directory", typename = "directory",
enumerate = list, enumerate = findSpecialRemotes "directory",
generate = gen, generate = gen,
setup = dosetup setup = directorySetup
} }
list :: Annex [Git.Repo] gen :: Git.Repo -> UUID -> Cost -> Maybe (M.Map String String) -> Annex (Remote Annex)
list = do gen r u cst c = return this
g <- Annex.gitRepo
return $ findDirectoryRemotes g
findDirectoryRemotes :: Git.Repo -> [Git.Repo]
findDirectoryRemotes r = map construct remotepairs
where
remotepairs = M.toList $ filterremotes $ Git.configMap r
filterremotes = M.filterWithKey (\k _ -> directoryremote k)
construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
directoryremote k = startswith "remote." k && endswith ".annex-directory" k
gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex)
gen r c = do
u <- getUUID r
cst <- remoteCost r
return $ genRemote r u c cst
where
genRemote :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Int -> Remote Annex
genRemote r u c cst = this
where where
this = Remote { this = Remote {
uuid = u, uuid = u,
@ -70,8 +49,8 @@ genRemote r u c cst = this
config = c config = c
} }
dosetup :: UUID -> M.Map String String -> Annex (M.Map String String) directorySetup :: UUID -> M.Map String String -> Annex (M.Map String String)
dosetup u c = do directorySetup u c = do
-- verify configuration is sane -- verify configuration is sane
let dir = case M.lookup "directory" c of let dir = case M.lookup "directory" c of
Nothing -> error "Specify directory=" Nothing -> error "Specify directory="
@ -79,6 +58,7 @@ dosetup u c = do
e <- liftIO $ doesDirectoryExist dir e <- liftIO $ doesDirectoryExist dir
when (not e) $ error $ "Directory does not exist: " ++ dir when (not e) $ error $ "Directory does not exist: " ++ dir
gitConfigSpecialRemote "directory" u c
g <- Annex.gitRepo g <- Annex.gitRepo
liftIO $ do liftIO $ do
Git.run g "config" [Param (configsetting "annex-directory"), Param "true"] Git.run g "config" [Param (configsetting "annex-directory"), Param "true"]

34
Remote/Git.hs
View file

@ -42,33 +42,27 @@ list = do
g <- Annex.gitRepo g <- Annex.gitRepo
return $ Git.remotes g return $ Git.remotes g
gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Cost -> Maybe (M.Map String String) -> Annex (Remote Annex)
gen repo _ = do gen r u cst _ = do
{- It's assumed to be cheap to read the config of non-URL remotes, {- It's assumed to be cheap to read the config of non-URL remotes,
- so this is done each time git-annex is run. Conversely, - so this is done each time git-annex is run. Conversely,
- the config of an URL remote is only read when there is no - the config of an URL remote is only read when there is no
- cached UUID value. -} - cached UUID value. -}
let cheap = not $ Git.repoIsUrl repo let cheap = not $ Git.repoIsUrl r
u <- getUUID repo r' <- case (cheap, u) of
repo' <- case (cheap, u) of (True, _) -> tryGitConfigRead r
(True, _) -> tryGitConfigRead repo (False, "") -> tryGitConfigRead r
(False, "") -> tryGitConfigRead repo _ -> return r
_ -> return repo
genRemote repo'
genRemote :: Git.Repo -> Annex (Remote Annex)
genRemote r = do
u <- getUUID r
c <- remoteCost r
return $ Remote { return $ Remote {
uuid = u, uuid = u,
cost = c, cost = cst,
name = Git.repoDescribe r, name = Git.repoDescribe r',
storeKey = copyToRemote r, storeKey = copyToRemote r',
retrieveKeyFile = copyFromRemote r, retrieveKeyFile = copyFromRemote r',
removeKey = dropKey r, removeKey = dropKey r',
hasKey = inAnnex r, hasKey = inAnnex r',
hasKeyCheap = not (Git.repoIsUrl r), hasKeyCheap = not (Git.repoIsUrl r'),
config = Nothing config = Nothing
} }

66
Remote/S3real.hs
View file

@ -15,7 +15,6 @@ import Network.AWS.AWSResult
import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import Data.String.Utils
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import System.Environment import System.Environment
@ -25,54 +24,29 @@ import Types
import qualified GitRepo as Git import qualified GitRepo as Git
import qualified Annex import qualified Annex
import UUID import UUID
import Config
import Utility
import Messages import Messages
import Locations import Locations
import Remote.Special
remote :: RemoteType Annex remote :: RemoteType Annex
remote = RemoteType { remote = RemoteType {
typename = "S3", typename = "S3",
enumerate = s3List, enumerate = findSpecialRemotes "s3",
generate = s3Gen, generate = gen,
setup = s3Setup setup = s3Setup
} }
s3List :: Annex [Git.Repo] gen :: Git.Repo -> UUID -> Cost -> Maybe (M.Map String String) -> Annex (Remote Annex)
s3List = do gen r u cst c = return this
g <- Annex.gitRepo
return $ findS3Remotes g
{- S3 remotes have a remote.<name>.annex-s3 config setting.
- Git.Repo does not normally generate remotes for things that
- have no configured url, so the Git.Repo objects have to be
- constructed as coming from an unknown location. -}
findS3Remotes :: Git.Repo -> [Git.Repo]
findS3Remotes r = map construct remotepairs
where
remotepairs = M.toList $ filterremotes $ Git.configMap r
filterremotes = M.filterWithKey (\k _ -> s3remote k)
construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
s3remote k = startswith "remote." k && endswith ".annex-s3" k
s3Gen :: Git.Repo -> Maybe (M.Map String String) -> Annex (Remote Annex)
s3Gen r c = do
u <- getUUID r
cst <- remoteCost r
return $ genRemote r u c cst
where
genRemote :: Git.Repo -> UUID -> Maybe (M.Map String String) -> Int -> Remote Annex
genRemote r u c cst = this
where where
this = Remote { this = Remote {
uuid = u, uuid = u,
cost = cst, cost = cst,
name = Git.repoDescribe r, name = Git.repoDescribe r,
storeKey = s3Store this, storeKey = store this,
retrieveKeyFile = s3Retrieve this, retrieveKeyFile = retrieve this,
removeKey = s3Remove this, removeKey = remove this,
hasKey = s3CheckPresent this, hasKey = checkPresent this,
hasKeyCheap = False, hasKeyCheap = False,
config = c config = c
} }
@ -114,15 +88,11 @@ s3Setup u c = do
Right _ -> return () Right _ -> return ()
Left err -> error $ prettyReqError err Left err -> error $ prettyReqError err
g <- Annex.gitRepo gitConfigSpecialRemote "s3" u fullconfig
liftIO $ do
Git.run g "config" [Param (configsetting "annex-s3"), Param "true"]
Git.run g "config" [Param (configsetting "annex-uuid"), Param u]
return fullconfig return fullconfig
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (M.lookup "name" c)
bucket = remotename ++ "-" ++ u bucket = remotename ++ "-" ++ u
configsetting s = "remote." ++ remotename ++ "." ++ s
defaults = M.fromList defaults = M.fromList
[ ("datacenter", "US") [ ("datacenter", "US")
, ("storageclass", "STANDARD") , ("storageclass", "STANDARD")
@ -142,8 +112,8 @@ s3Action r a = do
bucketKey :: String -> Key -> L.ByteString -> S3Object bucketKey :: String -> Key -> L.ByteString -> S3Object
bucketKey bucket k content = S3Object bucket (show k) "" [] content bucketKey bucket k content = S3Object bucket (show k) "" [] content
s3CheckPresent :: Remote Annex -> Key -> Annex (Either IOException Bool) checkPresent :: Remote Annex -> Key -> Annex (Either IOException Bool)
s3CheckPresent r k = s3Action r $ \(conn, bucket) -> do checkPresent r k = s3Action r $ \(conn, bucket) -> do
showNote ("checking " ++ name r ++ "...") showNote ("checking " ++ name r ++ "...")
res <- liftIO $ getObjectInfo conn $ bucketKey bucket k L.empty res <- liftIO $ getObjectInfo conn $ bucketKey bucket k L.empty
case res of case res of
@ -151,8 +121,8 @@ s3CheckPresent r k = s3Action r $ \(conn, bucket) -> do
Left (AWSError _ _) -> return $ Right False Left (AWSError _ _) -> return $ Right False
Left e -> return $ Left (error $ prettyReqError e) Left e -> return $ Left (error $ prettyReqError e)
s3Store :: Remote Annex -> Key -> Annex Bool store :: Remote Annex -> Key -> Annex Bool
s3Store r k = s3Action r $ \(conn, bucket) -> do store r k = s3Action r $ \(conn, bucket) -> do
g <- Annex.gitRepo g <- Annex.gitRepo
content <- liftIO $ L.readFile $ gitAnnexLocation g k content <- liftIO $ L.readFile $ gitAnnexLocation g k
let object = setStorageClass storageclass $ bucketKey bucket k content let object = setStorageClass storageclass $ bucketKey bucket k content
@ -168,8 +138,8 @@ s3Store r k = s3Action r $ \(conn, bucket) -> do
"REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY "REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY
_ -> STANDARD _ -> STANDARD
s3Retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
s3Retrieve r k f = s3Action r $ \(conn, bucket) -> do retrieve r k f = s3Action r $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey bucket k L.empty res <- liftIO $ getObject conn $ bucketKey bucket k L.empty
case res of case res of
Right o -> do Right o -> do
@ -179,8 +149,8 @@ s3Retrieve r k f = s3Action r $ \(conn, bucket) -> do
warning $ prettyReqError e warning $ prettyReqError e
return False return False
s3Remove :: Remote Annex -> Key -> Annex Bool remove :: Remote Annex -> Key -> Annex Bool
s3Remove r k = s3Action r $ \(conn, bucket) -> do remove r k = s3Action r $ \(conn, bucket) -> do
res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty
case res of case res of
Right _ -> return True Right _ -> return True

43
Remote/Special.hs Normal file
View file

@ -0,0 +1,43 @@
{- common functions for special remotes
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Special where
import qualified Data.Map as M
import Data.Maybe
import Data.String.Utils
import Control.Monad.State (liftIO)
import Types
import qualified GitRepo as Git
import qualified Annex
import UUID
import Utility
{- Special remotes don't have a configured url, so Git.Repo does not
- automatically generate remotes for them. This looks for a different
- configuration key instead.
-}
findSpecialRemotes :: String -> Annex [Git.Repo]
findSpecialRemotes s = do
g <- Annex.gitRepo
return $ map construct $ remotepairs g
where
remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r
construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
match k _ = startswith "remote." k && endswith (".annex-"++s) k
{- Sets up configuration for a special remote in .git/config. -}
gitConfigSpecialRemote :: String -> UUID -> M.Map String String -> Annex ()
gitConfigSpecialRemote s u c = do
g <- Annex.gitRepo
liftIO $ do
Git.run g "config" [Param (configsetting $ "annex-"++s), Param "true"]
Git.run g "config" [Param (configsetting $ "annex-uuid"), Param u]
where
remotename = fromJust (M.lookup "name" c)
configsetting v = "remote." ++ remotename ++ "." ++ v

6
RemoteClass.hs
View file

@ -15,6 +15,8 @@ import Data.Map as M
import qualified GitRepo as Git import qualified GitRepo as Git
import Key import Key
type Cost = Int
{- There are different types of remotes. -} {- There are different types of remotes. -}
data RemoteType a = RemoteType { data RemoteType a = RemoteType {
-- human visible type name -- human visible type name
@ -22,7 +24,7 @@ data RemoteType a = RemoteType {
-- enumerates remotes of this type -- enumerates remotes of this type
enumerate :: a [Git.Repo], enumerate :: a [Git.Repo],
-- generates a remote of this type -- generates a remote of this type
generate :: Git.Repo -> Maybe (M.Map String String) -> a (Remote a), generate :: Git.Repo -> String -> Cost -> Maybe (M.Map String String) -> a (Remote a),
-- initializes or changes a remote -- initializes or changes a remote
setup :: String -> M.Map String String -> a (M.Map String String) setup :: String -> M.Map String String -> a (M.Map String String)
} }
@ -34,7 +36,7 @@ data Remote a = Remote {
-- each Remote has a human visible name -- each Remote has a human visible name
name :: String, name :: String,
-- Remotes have a use cost; higher is more expensive -- Remotes have a use cost; higher is more expensive
cost :: Int, cost :: Cost,
-- Transfers a key to the remote. -- Transfers a key to the remote.
storeKey :: Key -> a Bool, storeKey :: Key -> a Bool,
-- retrieves a key's contents to a file -- retrieves a key's contents to a file