301 lines
9.8 KiB
Haskell
301 lines
9.8 KiB
Haskell
{- git-annex special remote configuration
|
|
-
|
|
- Copyright 2019-2023 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Annex.SpecialRemote.Config where
|
|
|
|
import Common
|
|
import Types.Remote (configParser)
|
|
import Types
|
|
import Types.UUID
|
|
import Types.ProposedAccepted
|
|
import Types.RemoteConfig
|
|
import Types.GitConfig
|
|
import Config.Cost
|
|
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
import Text.Read
|
|
import Data.Typeable
|
|
import GHC.Stack
|
|
|
|
newtype Sameas t = Sameas t
|
|
deriving (Show)
|
|
|
|
newtype ConfigFrom t = ConfigFrom t
|
|
deriving (Show)
|
|
|
|
{- The name of a configured remote is stored in its config using this key. -}
|
|
nameField :: RemoteConfigField
|
|
nameField = Accepted "name"
|
|
|
|
{- The name of a sameas remote is stored using this key instead.
|
|
- This prevents old versions of git-annex getting confused. -}
|
|
sameasNameField :: RemoteConfigField
|
|
sameasNameField = Accepted "sameas-name"
|
|
|
|
lookupName :: RemoteConfig -> Maybe String
|
|
lookupName c = fmap fromProposedAccepted $
|
|
M.lookup nameField c <|> M.lookup sameasNameField c
|
|
|
|
instance RemoteNameable RemoteConfig where
|
|
getRemoteName c = fromMaybe "" (lookupName c)
|
|
|
|
{- The uuid that a sameas remote is the same as is stored in this key. -}
|
|
sameasUUIDField :: RemoteConfigField
|
|
sameasUUIDField = Accepted "sameas-uuid"
|
|
|
|
{- The type of a remote is stored in its config using this key. -}
|
|
typeField :: RemoteConfigField
|
|
typeField = Accepted "type"
|
|
|
|
autoEnableField :: RemoteConfigField
|
|
autoEnableField = Accepted "autoenable"
|
|
|
|
costField :: RemoteConfigField
|
|
costField = Accepted "cost"
|
|
|
|
encryptionField :: RemoteConfigField
|
|
encryptionField = Accepted "encryption"
|
|
|
|
macField :: RemoteConfigField
|
|
macField = Accepted "mac"
|
|
|
|
cipherField :: RemoteConfigField
|
|
cipherField = Accepted "cipher"
|
|
|
|
cipherkeysField :: RemoteConfigField
|
|
cipherkeysField = Accepted "cipherkeys"
|
|
|
|
pubkeysField :: RemoteConfigField
|
|
pubkeysField = Accepted "pubkeys"
|
|
|
|
chunkField :: RemoteConfigField
|
|
chunkField = Accepted "chunk"
|
|
|
|
chunksizeField :: RemoteConfigField
|
|
chunksizeField = Accepted "chunksize"
|
|
|
|
embedCredsField :: RemoteConfigField
|
|
embedCredsField = Accepted "embedcreds"
|
|
|
|
preferreddirField :: RemoteConfigField
|
|
preferreddirField = Accepted "preferreddir"
|
|
|
|
exportTreeField :: RemoteConfigField
|
|
exportTreeField = Accepted "exporttree"
|
|
|
|
importTreeField :: RemoteConfigField
|
|
importTreeField = Accepted "importtree"
|
|
|
|
exportTree :: ParsedRemoteConfig -> Bool
|
|
exportTree = fromMaybe False . getRemoteConfigValue exportTreeField
|
|
|
|
importTree :: ParsedRemoteConfig -> Bool
|
|
importTree = fromMaybe False . getRemoteConfigValue importTreeField
|
|
|
|
{- Parsers for fields that are common to all special remotes. -}
|
|
commonFieldParsers :: [RemoteConfigFieldParser]
|
|
commonFieldParsers =
|
|
[ optionalStringParser nameField
|
|
(FieldDesc "name for the special remote")
|
|
, optionalStringParser sameasNameField HiddenField
|
|
, optionalStringParser sameasUUIDField HiddenField
|
|
, optionalStringParser typeField
|
|
(FieldDesc "type of special remote")
|
|
, autoEnableFieldParser
|
|
, costParser costField
|
|
(FieldDesc "default cost of this special remote")
|
|
, yesNoParser exportTreeField (Just False)
|
|
(FieldDesc "export trees of files to this remote")
|
|
, yesNoParser importTreeField (Just False)
|
|
(FieldDesc "import trees of files from this remote")
|
|
, optionalStringParser preferreddirField
|
|
(FieldDesc "directory whose content is preferred")
|
|
]
|
|
|
|
autoEnableFieldParser :: RemoteConfigFieldParser
|
|
autoEnableFieldParser = trueFalseParser autoEnableField (Just False)
|
|
(FieldDesc "automatically enable special remote")
|
|
|
|
{- A remote with sameas-uuid set will inherit these values from the config
|
|
- of that uuid. These values cannot be overridden in the remote's config. -}
|
|
sameasInherits :: S.Set RemoteConfigField
|
|
sameasInherits = S.fromList
|
|
-- encryption configuration is necessarily the same for two
|
|
-- remotes that access the same data store
|
|
[ encryptionField
|
|
, macField
|
|
, cipherField
|
|
, cipherkeysField
|
|
, pubkeysField
|
|
-- legacy chunking was either enabled or not, so has to be the same
|
|
-- across configs for remotes that access the same data
|
|
, chunksizeField
|
|
-- (new-style chunking does not have that limitation)
|
|
-- but there is no benefit to picking a different chunk size
|
|
-- for the sameas remote, since it's reading whatever chunks were
|
|
-- stored
|
|
, chunkField
|
|
]
|
|
|
|
{- Each RemoteConfig that has a sameas-uuid inherits some fields
|
|
- from it. Such fields can only be set by inheritance; the RemoteConfig
|
|
- cannot provide values from them. -}
|
|
addSameasInherited :: M.Map UUID RemoteConfig -> RemoteConfig -> RemoteConfig
|
|
addSameasInherited m c = case findSameasUUID c of
|
|
Nothing -> c
|
|
Just (Sameas sameasuuid) -> case M.lookup sameasuuid m of
|
|
Nothing -> c
|
|
Just parentc ->
|
|
M.withoutKeys c sameasInherits
|
|
`M.union`
|
|
M.restrictKeys parentc sameasInherits
|
|
|
|
findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID)
|
|
findSameasUUID c = Sameas . toUUID . fromProposedAccepted
|
|
<$> M.lookup sameasUUIDField c
|
|
|
|
{- Remove any fields inherited from a sameas-uuid. When storing a
|
|
- RemoteConfig, those fields don't get stored, since they were already
|
|
- inherited. -}
|
|
removeSameasInherited :: RemoteConfig -> RemoteConfig
|
|
removeSameasInherited c = case M.lookup sameasUUIDField c of
|
|
Nothing -> c
|
|
Just _ -> M.withoutKeys c sameasInherits
|
|
|
|
{- Finds remote uuids with matching RemoteConfig. -}
|
|
findByRemoteConfig :: (RemoteConfig -> Bool) -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig, Maybe (ConfigFrom UUID))]
|
|
findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toList
|
|
where
|
|
sameasuuid (u, c) = case M.lookup sameasUUIDField c of
|
|
Nothing -> (u, c, Nothing)
|
|
Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u))
|
|
|
|
{- Extracts a value from ParsedRemoteConfig. -}
|
|
getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v
|
|
getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of
|
|
Just (RemoteConfigValue v) -> case cast v of
|
|
Just v' -> Just v'
|
|
Nothing -> error $ unwords
|
|
[ "getRemoteConfigValue"
|
|
, fromProposedAccepted f
|
|
, "found value of unexpected type"
|
|
, show (typeOf v) ++ "."
|
|
, "This is a bug in git-annex!"
|
|
]
|
|
Nothing -> Nothing
|
|
|
|
{- Gets all fields that remoteConfigRestPassthrough matched. -}
|
|
getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String
|
|
getRemoteConfigPassedThrough (ParsedRemoteConfig m _) =
|
|
flip M.mapMaybe m $ \(RemoteConfigValue v) ->
|
|
case cast v of
|
|
Just (PassedThrough s) -> Just s
|
|
Nothing -> Nothing
|
|
|
|
newtype PassedThrough = PassedThrough String
|
|
|
|
parsedRemoteConfig :: RemoteType -> RemoteConfig -> Annex ParsedRemoteConfig
|
|
parsedRemoteConfig t c = either (const emptycfg) id . parseRemoteConfig c
|
|
<$> configParser t c
|
|
where
|
|
emptycfg = ParsedRemoteConfig mempty c
|
|
|
|
parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig
|
|
parseRemoteConfig c rpc =
|
|
go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers)
|
|
where
|
|
go l c' [] =
|
|
let (passover, leftovers) = partition
|
|
(maybe (const False) fst (remoteConfigRestPassthrough rpc) . fst)
|
|
(M.toList c')
|
|
leftovers' = filter (notaccepted . fst) leftovers
|
|
in if not (null leftovers')
|
|
then Left $ "Unexpected parameters: " ++
|
|
unwords (map (fromProposedAccepted . fst) leftovers')
|
|
else
|
|
let m = M.fromList $
|
|
l ++ map (uncurry passthrough) passover
|
|
in Right (ParsedRemoteConfig m c)
|
|
go l c' (p:rest) = do
|
|
let f = parserForField p
|
|
(valueParser p) (M.lookup f c) c >>= \case
|
|
Just v -> go ((f,v):l) (M.delete f c') rest
|
|
Nothing -> go l (M.delete f c') rest
|
|
|
|
passthrough f v = (f, RemoteConfigValue (PassedThrough (fromProposedAccepted v)))
|
|
|
|
notaccepted (Proposed _) = True
|
|
notaccepted (Accepted _) = False
|
|
|
|
optionalStringParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser
|
|
optionalStringParser f fielddesc = RemoteConfigFieldParser
|
|
{ parserForField = f
|
|
, valueParser = p
|
|
, fieldDesc = fielddesc
|
|
, valueDesc = Nothing
|
|
}
|
|
where
|
|
p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v)))
|
|
p Nothing _c = Right Nothing
|
|
|
|
yesNoParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser
|
|
yesNoParser f mdef fd = genParser yesno f mdef fd
|
|
(Just (ValueDesc "yes or no"))
|
|
where
|
|
yesno "yes" = Just True
|
|
yesno "no" = Just False
|
|
yesno _ = Nothing
|
|
|
|
trueFalseParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser
|
|
trueFalseParser f mdef fd = genParser trueFalseParser' f mdef fd
|
|
(Just (ValueDesc "true or false"))
|
|
|
|
-- Not using Git.Config.isTrueFalse because git supports
|
|
-- a lot of other values for true and false in its configs,
|
|
-- and this is not a git config and we want to avoid that mess.
|
|
trueFalseParser' :: String -> Maybe Bool
|
|
trueFalseParser' "true" = Just True
|
|
trueFalseParser' "false" = Just False
|
|
trueFalseParser' _ = Nothing
|
|
|
|
costParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser
|
|
costParser f fd = genParser readcost f Nothing fd
|
|
(Just (ValueDesc "a number"))
|
|
where
|
|
readcost :: String -> Maybe Cost
|
|
readcost = readMaybe
|
|
|
|
genParser
|
|
:: Typeable t
|
|
=> (String -> Maybe t)
|
|
-> RemoteConfigField
|
|
-> Maybe t -- ^ default if not configured
|
|
-> FieldDesc
|
|
-> Maybe ValueDesc
|
|
-> RemoteConfigFieldParser
|
|
genParser parse f mdef fielddesc valuedesc = RemoteConfigFieldParser
|
|
{ parserForField = f
|
|
, valueParser = p
|
|
, fieldDesc = fielddesc
|
|
, valueDesc = valuedesc
|
|
}
|
|
where
|
|
p Nothing _c = Right (fmap RemoteConfigValue mdef)
|
|
p (Just v) _c = case parse (fromProposedAccepted v) of
|
|
Just b -> Right (Just (RemoteConfigValue b))
|
|
Nothing -> case v of
|
|
Accepted _ -> Right (fmap RemoteConfigValue mdef)
|
|
Proposed _ -> Left $
|
|
"Bad value for " ++ fromProposedAccepted f ++
|
|
case valuedesc of
|
|
Just (ValueDesc vd) ->
|
|
" (expected " ++ vd ++ ")"
|
|
Nothing -> ""
|