better types allowed breaking module dep loop
This commit is contained in:
parent
80efafe496
commit
971ab27e78
9 changed files with 64 additions and 70 deletions
27
Annex.hs
27
Annex.hs
|
@ -20,11 +20,12 @@ import Control.Monad.State
|
||||||
(liftIO, StateT, runStateT, evalStateT, liftM, get, put)
|
(liftIO, StateT, runStateT, evalStateT, liftM, get, put)
|
||||||
|
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
import qualified GitQueue
|
import GitQueue
|
||||||
import qualified BackendClass
|
import BackendClass
|
||||||
import qualified RemoteClass
|
import RemoteClass
|
||||||
import qualified CryptoTypes
|
import CryptoTypes
|
||||||
import TrustLevel
|
import TrustLevel
|
||||||
|
import UUIDType
|
||||||
|
|
||||||
-- git-annex's monad
|
-- git-annex's monad
|
||||||
type Annex = StateT AnnexState IO
|
type Annex = StateT AnnexState IO
|
||||||
|
@ -32,10 +33,10 @@ type Annex = StateT AnnexState IO
|
||||||
-- internal state storage
|
-- internal state storage
|
||||||
data AnnexState = AnnexState
|
data AnnexState = AnnexState
|
||||||
{ repo :: Git.Repo
|
{ repo :: Git.Repo
|
||||||
, backends :: [BackendClass.Backend Annex]
|
, backends :: [Backend Annex]
|
||||||
, supportedBackends :: [BackendClass.Backend Annex]
|
, supportedBackends :: [Backend Annex]
|
||||||
, remotes :: [RemoteClass.Remote Annex]
|
, remotes :: [Remote Annex]
|
||||||
, repoqueue :: GitQueue.Queue
|
, repoqueue :: Queue
|
||||||
, quiet :: Bool
|
, quiet :: Bool
|
||||||
, force :: Bool
|
, force :: Bool
|
||||||
, fast :: Bool
|
, fast :: Bool
|
||||||
|
@ -45,17 +46,17 @@ data AnnexState = AnnexState
|
||||||
, toremote :: Maybe String
|
, toremote :: Maybe String
|
||||||
, fromremote :: Maybe String
|
, fromremote :: Maybe String
|
||||||
, exclude :: [String]
|
, exclude :: [String]
|
||||||
, forcetrust :: [(String, TrustLevel)]
|
, forcetrust :: [(UUID, TrustLevel)]
|
||||||
, cipher :: Maybe CryptoTypes.Cipher
|
, cipher :: Maybe Cipher
|
||||||
}
|
}
|
||||||
|
|
||||||
newState :: Git.Repo -> [BackendClass.Backend Annex] -> AnnexState
|
newState :: Git.Repo -> [Backend Annex] -> AnnexState
|
||||||
newState gitrepo allbackends = AnnexState
|
newState gitrepo allbackends = AnnexState
|
||||||
{ repo = gitrepo
|
{ repo = gitrepo
|
||||||
, backends = []
|
, backends = []
|
||||||
, remotes = []
|
, remotes = []
|
||||||
, supportedBackends = allbackends
|
, supportedBackends = allbackends
|
||||||
, repoqueue = GitQueue.empty
|
, repoqueue = empty
|
||||||
, quiet = False
|
, quiet = False
|
||||||
, force = False
|
, force = False
|
||||||
, fast = False
|
, fast = False
|
||||||
|
@ -70,7 +71,7 @@ newState gitrepo allbackends = AnnexState
|
||||||
}
|
}
|
||||||
|
|
||||||
{- 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 -> [BackendClass.Backend Annex] -> IO AnnexState
|
new :: Git.Repo -> [Backend Annex] -> IO AnnexState
|
||||||
new gitrepo allbackends = do
|
new gitrepo allbackends = do
|
||||||
gitrepo' <- liftIO $ Git.configRead gitrepo
|
gitrepo' <- liftIO $ Git.configRead gitrepo
|
||||||
return $ newState gitrepo' allbackends
|
return $ newState gitrepo' allbackends
|
||||||
|
|
|
@ -21,7 +21,6 @@ import Data.String.Utils
|
||||||
import BackendClass
|
import BackendClass
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import qualified RemoteUtils
|
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
import Content
|
import Content
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
@ -54,7 +53,7 @@ dummyStore _ _ = return True
|
||||||
- and copy it to here. -}
|
- and copy it to here. -}
|
||||||
copyKeyFile :: Key -> FilePath -> Annex Bool
|
copyKeyFile :: Key -> FilePath -> Annex Bool
|
||||||
copyKeyFile key file = do
|
copyKeyFile key file = do
|
||||||
(remotes, _) <- RemoteUtils.keyPossibilities key
|
(remotes, _) <- Remote.keyPossibilities key
|
||||||
if null remotes
|
if null remotes
|
||||||
then do
|
then do
|
||||||
showNote "not available"
|
showNote "not available"
|
||||||
|
@ -97,7 +96,7 @@ checkRemoveKey key numcopiesM = do
|
||||||
if force || numcopiesM == Just 0
|
if force || numcopiesM == Just 0
|
||||||
then return True
|
then return True
|
||||||
else do
|
else do
|
||||||
(remotes, trusteduuids) <- RemoteUtils.keyPossibilities key
|
(remotes, trusteduuids) <- Remote.keyPossibilities key
|
||||||
untrusteduuids <- trustGet UnTrusted
|
untrusteduuids <- trustGet UnTrusted
|
||||||
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
|
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
|
||||||
numcopies <- getNumCopies numcopiesM
|
numcopies <- getNumCopies numcopiesM
|
||||||
|
|
|
@ -16,7 +16,6 @@ import LocationLog
|
||||||
import Types
|
import Types
|
||||||
import Content
|
import Content
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import qualified RemoteUtils
|
|
||||||
import UUID
|
import UUID
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
|
@ -90,7 +89,7 @@ toPerform dest move key = do
|
||||||
let fastcheck = fast && not move && not (Remote.hasKeyCheap dest)
|
let fastcheck = fast && not move && not (Remote.hasKeyCheap dest)
|
||||||
isthere <- if fastcheck
|
isthere <- if fastcheck
|
||||||
then do
|
then do
|
||||||
(remotes, _) <- RemoteUtils.keyPossibilities key
|
(remotes, _) <- Remote.keyPossibilities key
|
||||||
return $ Right $ dest `elem` remotes
|
return $ Right $ dest `elem` remotes
|
||||||
else Remote.hasKey dest key
|
else Remote.hasKey dest key
|
||||||
case isthere of
|
case isthere of
|
||||||
|
@ -124,7 +123,7 @@ fromStart :: Remote.Remote Annex -> Bool -> CommandStartString
|
||||||
fromStart src move file = isAnnexed file $ \(key, _) -> do
|
fromStart src move file = isAnnexed file $ \(key, _) -> do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
u <- getUUID g
|
u <- getUUID g
|
||||||
(remotes, _) <- RemoteUtils.keyPossibilities key
|
(remotes, _) <- Remote.keyPossibilities key
|
||||||
if (u == Remote.uuid src) || (null $ filter (== src) remotes)
|
if (u == Remote.uuid src) || (null $ filter (== src) remotes)
|
||||||
then stop
|
then stop
|
||||||
else do
|
else do
|
||||||
|
|
|
@ -16,6 +16,7 @@ import Options
|
||||||
import Utility
|
import Utility
|
||||||
import TrustLevel
|
import TrustLevel
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
import qualified Remote
|
||||||
|
|
||||||
import qualified Command.Add
|
import qualified Command.Add
|
||||||
import qualified Command.Unannex
|
import qualified Command.Unannex
|
||||||
|
@ -104,10 +105,12 @@ options = commonOptions ++
|
||||||
where
|
where
|
||||||
setto v = Annex.changeState $ \s -> s { Annex.toremote = Just v }
|
setto v = Annex.changeState $ \s -> s { Annex.toremote = Just v }
|
||||||
setfrom v = Annex.changeState $ \s -> s { Annex.fromremote = Just v }
|
setfrom v = Annex.changeState $ \s -> s { Annex.fromremote = Just v }
|
||||||
addexclude v = Annex.changeState $ \s -> s { Annex.exclude = v:(Annex.exclude s) }
|
addexclude v = Annex.changeState $ \s -> s { Annex.exclude = v:Annex.exclude s }
|
||||||
setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v }
|
setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v }
|
||||||
setkey v = Annex.changeState $ \s -> s { Annex.defaultkey = Just v }
|
setkey v = Annex.changeState $ \s -> s { Annex.defaultkey = Just v }
|
||||||
settrust t v = Annex.changeState $ \s -> s { Annex.forcetrust = (v, t):(Annex.forcetrust s) }
|
settrust t v = do
|
||||||
|
r <- Remote.nameToUUID v
|
||||||
|
Annex.changeState $ \s -> s { Annex.forcetrust = (r, t):Annex.forcetrust s }
|
||||||
|
|
||||||
header :: String
|
header :: String
|
||||||
header = "Usage: git-annex command [option ..]"
|
header = "Usage: git-annex command [option ..]"
|
||||||
|
|
28
Remote.hs
28
Remote.hs
|
@ -14,6 +14,7 @@ module Remote (
|
||||||
removeKey,
|
removeKey,
|
||||||
hasKey,
|
hasKey,
|
||||||
hasKeyCheap,
|
hasKeyCheap,
|
||||||
|
keyPossibilities,
|
||||||
|
|
||||||
remoteTypes,
|
remoteTypes,
|
||||||
genList,
|
genList,
|
||||||
|
@ -45,6 +46,8 @@ import qualified Annex
|
||||||
import Locations
|
import Locations
|
||||||
import Utility
|
import Utility
|
||||||
import Config
|
import Config
|
||||||
|
import Trust
|
||||||
|
import LocationLog
|
||||||
|
|
||||||
import qualified Remote.Git
|
import qualified Remote.Git
|
||||||
import qualified Remote.S3
|
import qualified Remote.S3
|
||||||
|
@ -110,6 +113,31 @@ remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
|
||||||
remotesWithoutUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
|
remotesWithoutUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
|
||||||
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
|
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
|
||||||
|
|
||||||
|
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
|
||||||
|
-
|
||||||
|
- Also returns a list of UUIDs that are trusted to have the key
|
||||||
|
- (some may not have configured remotes).
|
||||||
|
-}
|
||||||
|
keyPossibilities :: Key -> Annex ([Remote Annex], [UUID])
|
||||||
|
keyPossibilities key = do
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
u <- getUUID g
|
||||||
|
trusted <- trustGet Trusted
|
||||||
|
|
||||||
|
-- get uuids of all remotes that are recorded to have the key
|
||||||
|
uuids <- liftIO $ keyLocations g key
|
||||||
|
let validuuids = filter (/= u) uuids
|
||||||
|
|
||||||
|
-- note that validuuids is assumed to not have dups
|
||||||
|
let validtrusteduuids = intersect validuuids trusted
|
||||||
|
|
||||||
|
-- remotes that match uuids that have the key
|
||||||
|
allremotes <- genList
|
||||||
|
let validremotes = remotesWithUUID allremotes validuuids
|
||||||
|
|
||||||
|
return (sort validremotes, validtrusteduuids)
|
||||||
|
|
||||||
|
|
||||||
{- Filename of remote.log. -}
|
{- Filename of remote.log. -}
|
||||||
remoteLog :: Annex FilePath
|
remoteLog :: Annex FilePath
|
||||||
remoteLog = do
|
remoteLog = do
|
||||||
|
|
|
@ -1,42 +0,0 @@
|
||||||
{- git-annex remotes overflow (can't go in there due to dependency cycles)
|
|
||||||
-
|
|
||||||
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
||||||
-
|
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
|
||||||
-}
|
|
||||||
|
|
||||||
module RemoteUtils where
|
|
||||||
|
|
||||||
import Control.Monad.State (liftIO)
|
|
||||||
import Data.List
|
|
||||||
|
|
||||||
import Annex
|
|
||||||
import Trust
|
|
||||||
import Remote
|
|
||||||
import UUID
|
|
||||||
import LocationLog
|
|
||||||
import Key
|
|
||||||
|
|
||||||
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
|
|
||||||
-
|
|
||||||
- Also returns a list of UUIDs that are trusted to have the key
|
|
||||||
- (some may not have configured remotes).
|
|
||||||
-}
|
|
||||||
keyPossibilities :: Key -> Annex ([Remote Annex], [UUID])
|
|
||||||
keyPossibilities key = do
|
|
||||||
g <- Annex.gitRepo
|
|
||||||
u <- getUUID g
|
|
||||||
trusted <- trustGet Trusted
|
|
||||||
|
|
||||||
-- get uuids of all remotes that are recorded to have the key
|
|
||||||
uuids <- liftIO $ keyLocations g key
|
|
||||||
let validuuids = filter (/= u) uuids
|
|
||||||
|
|
||||||
-- note that validuuids is assumed to not have dups
|
|
||||||
let validtrusteduuids = intersect validuuids trusted
|
|
||||||
|
|
||||||
-- remotes that match uuids that have the key
|
|
||||||
allremotes <- genList
|
|
||||||
let validremotes = remotesWithUUID allremotes validuuids
|
|
||||||
|
|
||||||
return (sort validremotes, validtrusteduuids)
|
|
6
Trust.hs
6
Trust.hs
|
@ -23,7 +23,6 @@ import Types
|
||||||
import UUID
|
import UUID
|
||||||
import Locations
|
import Locations
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified Remote
|
|
||||||
import Utility
|
import Utility
|
||||||
|
|
||||||
{- Filename of trust.log. -}
|
{- Filename of trust.log. -}
|
||||||
|
@ -43,14 +42,11 @@ trustGet level = do
|
||||||
trustMap :: Annex (M.Map UUID TrustLevel)
|
trustMap :: Annex (M.Map UUID TrustLevel)
|
||||||
trustMap = do
|
trustMap = do
|
||||||
logfile <- trustLog
|
logfile <- trustLog
|
||||||
overrides <- Annex.getState Annex.forcetrust >>= mapM findoverride
|
overrides <- Annex.getState Annex.forcetrust
|
||||||
s <- liftIO $ catch (readFile logfile) ignoreerror
|
s <- liftIO $ catch (readFile logfile) ignoreerror
|
||||||
return $ M.fromList $ trustMapParse s ++ overrides
|
return $ M.fromList $ trustMapParse s ++ overrides
|
||||||
where
|
where
|
||||||
ignoreerror _ = return ""
|
ignoreerror _ = return ""
|
||||||
findoverride (name, t) = do
|
|
||||||
uuid <- Remote.nameToUUID name
|
|
||||||
return (uuid, t)
|
|
||||||
|
|
||||||
{- Trust map parser. -}
|
{- Trust map parser. -}
|
||||||
trustMapParse :: String -> [(UUID, TrustLevel)]
|
trustMapParse :: String -> [(UUID, TrustLevel)]
|
||||||
|
|
3
UUID.hs
3
UUID.hs
|
@ -36,8 +36,7 @@ import qualified Annex
|
||||||
import Utility
|
import Utility
|
||||||
import qualified SysConfig
|
import qualified SysConfig
|
||||||
import Config
|
import Config
|
||||||
|
import UUIDType
|
||||||
type UUID = String
|
|
||||||
|
|
||||||
configkey :: String
|
configkey :: String
|
||||||
configkey = "annex.uuid"
|
configkey = "annex.uuid"
|
||||||
|
|
11
UUIDType.hs
Normal file
11
UUIDType.hs
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
{- git-annex UUID type
|
||||||
|
-
|
||||||
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
||||||
|
-
|
||||||
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module UUIDType where
|
||||||
|
|
||||||
|
-- might be nice to have a newtype, but lots of stuff treats uuids as strings
|
||||||
|
type UUID = String
|
Loading…
Reference in a new issue