1{- git-annex special remote configuration 2 - 3 - Copyright 2019-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 9{-# OPTIONS_GHC -fno-warn-orphans #-} 10 11module Annex.SpecialRemote.Config where 12 13import Common 14import Types.Remote (configParser) 15import Types 16import Types.UUID 17import Types.ProposedAccepted 18import Types.RemoteConfig 19import Types.GitConfig 20 21import qualified Data.Map as M 22import qualified Data.Set as S 23import Data.Typeable 24import GHC.Stack 25 26newtype Sameas t = Sameas t 27 deriving (Show) 28 29newtype ConfigFrom t = ConfigFrom t 30 deriving (Show) 31 32{- The name of a configured remote is stored in its config using this key. -} 33nameField :: RemoteConfigField 34nameField = Accepted "name" 35 36{- The name of a sameas remote is stored using this key instead. 37 - This prevents old versions of git-annex getting confused. -} 38sameasNameField :: RemoteConfigField 39sameasNameField = Accepted "sameas-name" 40 41lookupName :: RemoteConfig -> Maybe String 42lookupName c = fmap fromProposedAccepted $ 43 M.lookup nameField c <|> M.lookup sameasNameField c 44 45instance RemoteNameable RemoteConfig where 46 getRemoteName c = fromMaybe "" (lookupName c) 47 48{- The uuid that a sameas remote is the same as is stored in this key. -} 49sameasUUIDField :: RemoteConfigField 50sameasUUIDField = Accepted "sameas-uuid" 51 52{- The type of a remote is stored in its config using this key. -} 53typeField :: RemoteConfigField 54typeField = Accepted "type" 55 56autoEnableField :: RemoteConfigField 57autoEnableField = Accepted "autoenable" 58 59encryptionField :: RemoteConfigField 60encryptionField = Accepted "encryption" 61 62macField :: RemoteConfigField 63macField = Accepted "mac" 64 65cipherField :: RemoteConfigField 66cipherField = Accepted "cipher" 67 68cipherkeysField :: RemoteConfigField 69cipherkeysField = Accepted "cipherkeys" 70 71pubkeysField :: RemoteConfigField 72pubkeysField = Accepted "pubkeys" 73 74chunkField :: RemoteConfigField 75chunkField = Accepted "chunk" 76 77chunksizeField :: RemoteConfigField 78chunksizeField = Accepted "chunksize" 79 80embedCredsField :: RemoteConfigField 81embedCredsField = Accepted "embedcreds" 82 83preferreddirField :: RemoteConfigField 84preferreddirField = Accepted "preferreddir" 85 86exportTreeField :: RemoteConfigField 87exportTreeField = Accepted "exporttree" 88 89importTreeField :: RemoteConfigField 90importTreeField = Accepted "importtree" 91 92exportTree :: ParsedRemoteConfig -> Bool 93exportTree = fromMaybe False . getRemoteConfigValue exportTreeField 94 95importTree :: ParsedRemoteConfig -> Bool 96importTree = fromMaybe False . getRemoteConfigValue importTreeField 97 98{- Parsers for fields that are common to all special remotes. -} 99commonFieldParsers :: [RemoteConfigFieldParser] 100commonFieldParsers = 101 [ optionalStringParser nameField 102 (FieldDesc "name for the special remote") 103 , optionalStringParser sameasNameField HiddenField 104 , optionalStringParser sameasUUIDField HiddenField 105 , optionalStringParser typeField 106 (FieldDesc "type of special remote") 107 , trueFalseParser autoEnableField (Just False) 108 (FieldDesc "automatically enable special remote") 109 , yesNoParser exportTreeField (Just False) 110 (FieldDesc "export trees of files to this remote") 111 , yesNoParser importTreeField (Just False) 112 (FieldDesc "import trees of files from this remote") 113 , optionalStringParser preferreddirField 114 (FieldDesc "directory whose content is preferred") 115 ] 116 117{- A remote with sameas-uuid set will inherit these values from the config 118 - of that uuid. These values cannot be overridden in the remote's config. -} 119sameasInherits :: S.Set RemoteConfigField 120sameasInherits = S.fromList 121 -- encryption configuration is necessarily the same for two 122 -- remotes that access the same data store 123 [ encryptionField 124 , macField 125 , cipherField 126 , cipherkeysField 127 , pubkeysField 128 -- legacy chunking was either enabled or not, so has to be the same 129 -- across configs for remotes that access the same data 130 -- (new-style chunking does not have that limitation) 131 , chunksizeField 132 ] 133 134{- Each RemoteConfig that has a sameas-uuid inherits some fields 135 - from it. Such fields can only be set by inheritance; the RemoteConfig 136 - cannot provide values from them. -} 137addSameasInherited :: M.Map UUID RemoteConfig -> RemoteConfig -> RemoteConfig 138addSameasInherited m c = case findSameasUUID c of 139 Nothing -> c 140 Just (Sameas sameasuuid) -> case M.lookup sameasuuid m of 141 Nothing -> c 142 Just parentc -> 143 M.withoutKeys c sameasInherits 144 `M.union` 145 M.restrictKeys parentc sameasInherits 146 147findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID) 148findSameasUUID c = Sameas . toUUID . fromProposedAccepted 149 <$> M.lookup sameasUUIDField c 150 151{- Remove any fields inherited from a sameas-uuid. When storing a 152 - RemoteConfig, those fields don't get stored, since they were already 153 - inherited. -} 154removeSameasInherited :: RemoteConfig -> RemoteConfig 155removeSameasInherited c = case M.lookup sameasUUIDField c of 156 Nothing -> c 157 Just _ -> M.withoutKeys c sameasInherits 158 159{- Finds remote uuids with matching RemoteConfig. -} 160findByRemoteConfig :: (RemoteConfig -> Bool) -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig, Maybe (ConfigFrom UUID))] 161findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toList 162 where 163 sameasuuid (u, c) = case M.lookup sameasUUIDField c of 164 Nothing -> (u, c, Nothing) 165 Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u)) 166 167{- Extracts a value from ParsedRemoteConfig. -} 168getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v 169getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of 170 Just (RemoteConfigValue v) -> case cast v of 171 Just v' -> Just v' 172 Nothing -> error $ unwords 173 [ "getRemoteConfigValue" 174 , fromProposedAccepted f 175 , "found value of unexpected type" 176 , show (typeOf v) ++ "." 177 , "This is a bug in git-annex!" 178 ] 179 Nothing -> Nothing 180 181{- Gets all fields that remoteConfigRestPassthrough matched. -} 182getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String 183getRemoteConfigPassedThrough (ParsedRemoteConfig m _) = 184 flip M.mapMaybe m $ \(RemoteConfigValue v) -> 185 case cast v of 186 Just (PassedThrough s) -> Just s 187 Nothing -> Nothing 188 189newtype PassedThrough = PassedThrough String 190 191parsedRemoteConfig :: RemoteType -> RemoteConfig -> Annex ParsedRemoteConfig 192parsedRemoteConfig t c = either (const emptycfg) id . parseRemoteConfig c 193 <$> configParser t c 194 where 195 emptycfg = ParsedRemoteConfig mempty c 196 197parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig 198parseRemoteConfig c rpc = 199 go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers) 200 where 201 go l c' [] = 202 let (passover, leftovers) = partition 203 (maybe (const False) fst (remoteConfigRestPassthrough rpc) . fst) 204 (M.toList c') 205 leftovers' = filter (notaccepted . fst) leftovers 206 in if not (null leftovers') 207 then Left $ "Unexpected parameters: " ++ 208 unwords (map (fromProposedAccepted . fst) leftovers') 209 else 210 let m = M.fromList $ 211 l ++ map (uncurry passthrough) passover 212 in Right (ParsedRemoteConfig m c) 213 go l c' (p:rest) = do 214 let f = parserForField p 215 (valueParser p) (M.lookup f c) c >>= \case 216 Just v -> go ((f,v):l) (M.delete f c') rest 217 Nothing -> go l (M.delete f c') rest 218 219 passthrough f v = (f, RemoteConfigValue (PassedThrough (fromProposedAccepted v))) 220 221 notaccepted (Proposed _) = True 222 notaccepted (Accepted _) = False 223 224optionalStringParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser 225optionalStringParser f fielddesc = RemoteConfigFieldParser 226 { parserForField = f 227 , valueParser = p 228 , fieldDesc = fielddesc 229 , valueDesc = Nothing 230 } 231 where 232 p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v))) 233 p Nothing _c = Right Nothing 234 235yesNoParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser 236yesNoParser f mdef fd = genParser yesno f mdef fd 237 (Just (ValueDesc "yes or no")) 238 where 239 yesno "yes" = Just True 240 yesno "no" = Just False 241 yesno _ = Nothing 242 243trueFalseParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser 244trueFalseParser f mdef fd = genParser trueFalseParser' f mdef fd 245 (Just (ValueDesc "true or false")) 246 247-- Not using Git.Config.isTrueFalse because git supports 248-- a lot of other values for true and false in its configs, 249-- and this is not a git config and we want to avoid that mess. 250trueFalseParser' :: String -> Maybe Bool 251trueFalseParser' "true" = Just True 252trueFalseParser' "false" = Just False 253trueFalseParser' _ = Nothing 254 255genParser 256 :: Typeable t 257 => (String -> Maybe t) 258 -> RemoteConfigField 259 -> Maybe t -- ^ default if not configured 260 -> FieldDesc 261 -> Maybe ValueDesc 262 -> RemoteConfigFieldParser 263genParser parse f mdef fielddesc valuedesc = RemoteConfigFieldParser 264 { parserForField = f 265 , valueParser = p 266 , fieldDesc = fielddesc 267 , valueDesc = valuedesc 268 } 269 where 270 p Nothing _c = Right (fmap RemoteConfigValue mdef) 271 p (Just v) _c = case parse (fromProposedAccepted v) of 272 Just b -> Right (Just (RemoteConfigValue b)) 273 Nothing -> case v of 274 Accepted _ -> Right (fmap RemoteConfigValue mdef) 275 Proposed _ -> Left $ 276 "Bad value for " ++ fromProposedAccepted f ++ 277 case valuedesc of 278 Just (ValueDesc vd) -> 279 " (expected " ++ vd ++ ")" 280 Nothing -> "" 281