summaryrefslogtreecommitdiff
path: root/Logs/Remote.hs
blob: 47a339a5f00bb5a528a1468efcdfb70cc065cd71 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
{- git-annex remote log
 - 
 - Copyright 2011 Joey Hess <id@joeyh.name>
 - 
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Remote (
	remoteLog,
	readRemoteLog,
	configSet,
	keyValToConfig,
	configToKeyVal,
	showConfig,
	parseConfig,

	prop_isomorphic_configEscape,
	prop_parse_show_Config,
) where

import Annex.Common
import qualified Annex.Branch
import Types.Remote
import Logs
import Logs.UUIDBased

import qualified Data.Map as M
import Data.Char

{- Adds or updates a remote's config in the log. -}
configSet :: UUID -> RemoteConfig -> Annex ()
configSet u cfg = do
	c <- liftIO currentVectorClock
	Annex.Branch.change remoteLog $
		showLog showConfig . changeLog c u cfg . parseLog parseConfig

{- Map of remotes by uuid containing key/value config maps. -}
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
readRemoteLog = simpleMap . parseLog parseConfig <$> Annex.Branch.get remoteLog

parseConfig :: String -> Maybe RemoteConfig
parseConfig = Just . keyValToConfig . words

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 keys
	| any (\k -> any isSpace k || elem '=' k) (M.keys c) = True
	| otherwise = parseConfig (showConfig c) ~~ Just c
  where
	normalize v = sort . M.toList <$> v
	a ~~ b = normalize a == normalize b