1{- git-annex remote log, pure operations 2 - 3 - Copyright 2011-2019 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8module Logs.Remote.Pure ( 9 calcRemoteConfigMap, 10 parseRemoteConfigLog, 11 buildRemoteConfigLog, 12 keyValToConfig, 13 configToKeyVal, 14 showConfig, 15 16 prop_isomorphic_configEscape, 17 prop_parse_show_Config, 18) where 19 20import Annex.Common 21import Types.Remote 22import Types.ProposedAccepted 23import Logs.UUIDBased 24import Annex.SpecialRemote.Config 25import Utility.QuickCheck 26 27import qualified Data.ByteString.Lazy as L 28import qualified Data.Map as M 29import Data.Char 30import qualified Data.Attoparsec.ByteString as A 31import Data.ByteString.Builder 32 33calcRemoteConfigMap :: L.ByteString -> M.Map UUID RemoteConfig 34calcRemoteConfigMap = (\m -> M.map (addSameasInherited m) m) 35 . simpleMap 36 . parseRemoteConfigLog 37 38parseRemoteConfigLog :: L.ByteString -> Log RemoteConfig 39parseRemoteConfigLog = parseLogOld remoteConfigParser 40 41buildRemoteConfigLog :: Log RemoteConfig -> Builder 42buildRemoteConfigLog = buildLogOld (byteString . encodeBS . showConfig) 43 44remoteConfigParser :: A.Parser RemoteConfig 45remoteConfigParser = keyValToConfig Accepted . words . decodeBS <$> A.takeByteString 46 47showConfig :: RemoteConfig -> String 48showConfig = unwords . configToKeyVal 49 50{- Given Strings like "key=value", generates a RemoteConfig. -} 51keyValToConfig :: (String -> ProposedAccepted String) -> [String] -> RemoteConfig 52keyValToConfig mk ws = M.fromList $ map (/=/) ws 53 where 54 (/=/) s = (mk k, mk v) 55 where 56 k = takeWhile (/= '=') s 57 v = configUnEscape $ drop (1 + length k) s 58 59configToKeyVal :: RemoteConfig -> [String] 60configToKeyVal m = map toword $ sort $ M.toList m 61 where 62 toword (k, v) = fromProposedAccepted k ++ "=" ++ configEscape (fromProposedAccepted v) 63 64configEscape :: String -> String 65configEscape = concatMap escape 66 where 67 escape c 68 | isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";" 69 | otherwise = [c] 70 71configUnEscape :: String -> String 72configUnEscape = unescape 73 where 74 unescape [] = [] 75 unescape (c:rest) 76 | c == '&' = entity rest 77 | otherwise = c : unescape rest 78 entity s 79 | not (null num) && ";" `isPrefixOf` r = 80 chr (Prelude.read num) : unescape rest 81 | otherwise = 82 '&' : unescape s 83 where 84 num = takeWhile isNumber s 85 r = drop (length num) s 86 rest = drop 1 r 87 88{- for quickcheck -} 89prop_isomorphic_configEscape :: TestableString -> Bool 90prop_isomorphic_configEscape ts = s == (configUnEscape . configEscape) s 91 where 92 s = fromTestableString ts 93 94prop_parse_show_Config :: RemoteConfig -> Bool 95prop_parse_show_Config c 96 -- whitespace and '=' are not supported in config keys 97 | any (\k -> any isSpace k || elem '=' k) (map fromProposedAccepted $ M.keys c) = True 98 | any (any excluded) (map fromProposedAccepted $ M.keys c) = True 99 | any (any excluded) (map fromProposedAccepted $ M.elems c) = True 100 | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c 101 where 102 normalize v = sort . M.toList <$> v 103 a ~~ b = normalize a == normalize b 104 -- limit to ascii alphanumerics for simplicity; characters not 105 -- allowed by the current character set in the config may not 106 -- round-trip in an identical representation due to the use of the 107 -- filesystem encoding. 108 excluded ch = not (isAlphaNum ch) || not (isAscii ch) 109