diff --git a/Logs/Remote/Pure.hs b/Logs/Remote/Pure.hs new file mode 100644 index 0000000000..0c405b9795 --- /dev/null +++ b/Logs/Remote/Pure.hs @@ -0,0 +1,96 @@ +{- git-annex remote log, pure operations + - + - Copyright 2011-2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Logs.Remote.Pure ( + calcRemoteConfigMap, + keyValToConfig, + configToKeyVal, + showConfig, + remoteConfigParser, + + prop_isomorphic_configEscape, + prop_parse_show_Config, +) where + +import Annex.Common +import Types.Remote +import Logs.UUIDBased +import Annex.SpecialRemote.Config + +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import Data.Char +import qualified Data.Attoparsec.ByteString.Lazy as A + +calcRemoteConfigMap :: L.ByteString -> M.Map UUID RemoteConfig +calcRemoteConfigMap = (\m -> M.map (addSameasInherited m) m) + . simpleMap + . parseLogOld remoteConfigParser + +remoteConfigParser :: A.Parser RemoteConfig +remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString + +showConfig :: RemoteConfig -> String +showConfig = unwords . configToKeyVal + +{- Given Strings like "key=value", generates a RemoteConfig. -} +keyValToConfig :: [String] -> RemoteConfig +keyValToConfig ws = M.fromList $ map (/=/) ws + where + (/=/) s = (k, v) + where + k = takeWhile (/= '=') s + v = configUnEscape $ drop (1 + length k) s + +configToKeyVal :: M.Map String String -> [String] +configToKeyVal m = map toword $ sort $ M.toList m + where + toword (k, v) = k ++ "=" ++ configEscape v + +configEscape :: String -> String +configEscape = concatMap escape + where + escape c + | isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";" + | otherwise = [c] + +configUnEscape :: String -> String +configUnEscape = unescape + where + unescape [] = [] + unescape (c:rest) + | c == '&' = entity rest + | otherwise = c : unescape rest + entity s + | not (null num) && ";" `isPrefixOf` r = + chr (Prelude.read num) : unescape rest + | otherwise = + '&' : unescape s + where + num = takeWhile isNumber s + r = drop (length num) s + rest = drop 1 r + +{- for quickcheck -} +prop_isomorphic_configEscape :: String -> Bool +prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s + +prop_parse_show_Config :: RemoteConfig -> Bool +prop_parse_show_Config c + -- whitespace and '=' are not supported in config keys + | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True + | any (any excluded) (M.keys c) = True + | any (any excluded) (M.elems c) = True + | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c + where + normalize v = sort . M.toList <$> v + a ~~ b = normalize a == normalize b + -- limit to ascii alphanumerics for simplicity; characters not + -- allowed by the current character set in the config may not + -- round-trip in an identical representation due to the use of the + -- filesystem encoding. + excluded ch = not (isAlphaNum ch) || not (isAscii ch)