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