summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2016-04-29 02:49:31 -0400
committerJames Crayne <jim.crayne@gmail.com>2016-04-29 16:12:22 -0400
commit20d17eef898d342ef62812d2b74b590e73cc1180 (patch)
treedffa84a3469ecc40f1e2999f9a21adeea6877c22
parentbaf38b1c4aebebae1a3a93b9336d147ab7ce84c3 (diff)
function to parse Triple-Field Specs
-rw-r--r--kiki.cabal4
-rw-r--r--lib/KeyRing.hs165
-rw-r--r--testkiki/testkiki.hs129
3 files changed, 283 insertions, 15 deletions
diff --git a/kiki.cabal b/kiki.cabal
index 80e322f..ff424eb 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -26,6 +26,10 @@ Flag needlocale
26Flag unixEnv 26Flag unixEnv
27 Default: False 27 Default: False
28 28
29Executable xx
30 Main-is: xx.hs
31 Build-Depends: base, kiki
32
29Executable kiki 33Executable kiki
30 Main-is: kiki.hs 34 Main-is: kiki.hs
31 -- base >=4.6 due to use of readEither in KikiD.Message 35 -- base >=4.6 due to use of readEither in KikiD.Message
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 9c734fc..1f193b3 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -64,6 +64,7 @@ module KeyRing
64 , isCryptoCoinKey 64 , isCryptoCoinKey
65 , matchpr 65 , matchpr
66 , parseSpec 66 , parseSpec
67 , Spec
67 , parseUID 68 , parseUID
68 , UserIDRecord(..) 69 , UserIDRecord(..)
69 , pkcs8 70 , pkcs8
@@ -97,6 +98,10 @@ module KeyRing
97 , keykey 98 , keykey
98 , keyPacket 99 , keyPacket
99 , KeySpec(..) 100 , KeySpec(..)
101 , MatchingField(..)
102 , SpecError(..)
103 , SingleKeySpec(..)
104 , parseSpec3
100 , getHostnames 105 , getHostnames
101 , secretPemFromPacket 106 , secretPemFromPacket
102 , SubkeyStatus(..) 107 , SubkeyStatus(..)
@@ -948,7 +953,7 @@ data KeySpec =
948 | KeyUidMatch String -- u: 953 | KeyUidMatch String -- u:
949 deriving Show 954 deriving Show
950 955
951data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum) 956data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
952data SingleKeySpec = FingerprintMatch String 957data SingleKeySpec = FingerprintMatch String
953 | SubstringMatch (Maybe MatchingField) String 958 | SubstringMatch (Maybe MatchingField) String
954 | EmptyMatch 959 | EmptyMatch
@@ -956,13 +961,28 @@ data SingleKeySpec = FingerprintMatch String
956 | WorkingKeyMatch 961 | WorkingKeyMatch
957 deriving (Show,Eq,Ord) 962 deriving (Show,Eq,Ord)
958 963
959-- A pair of specs. The first specifies an identity and the second 964getStr (FingerprintMatch x) = x
960-- specifies a specific key (possibly master) associated with that 965getStr (SubstringMatch _ x) = x
961-- identity. 966getStr _ = ""
967
968-- | Spec
969--
970-- The product type, SingleKeySpec³ = Circle × Identity × Key.
971--
972-- Key - A single public or private key (subkey, or master without subkeys) (eg, pem file)
973-- Identity - A single master key with all its subkeys
974-- Circle - A collection of master keys with their subkeys (eg, gpg file)
975--
976-- The three fields are deliminated by slashes.
962-- 977--
963-- When no slash is specified, context will decide whether the SingleKeySpec 978-- When context does not disambiguate, use the following default rules:
964-- is specifying an identity or a key belonging to the working identity. 979-- There are(is)
965type Spec = (SingleKeySpec,SingleKeySpec) 980-- - no slashes, so interpret as Key
981-- - one slash, so interpret as Identity/Key
982-- - two slashes, so interpret as Circle/Identity/Key
983--
984-- (Any of the fields may be left empty.)
985type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec)
966 986
967parseSingleSpec :: String -> SingleKeySpec 987parseSingleSpec :: String -> SingleKeySpec
968parseSingleSpec "*" = AnyMatch 988parseSingleSpec "*" = AnyMatch
@@ -970,6 +990,7 @@ parseSingleSpec "-" = WorkingKeyMatch
970parseSingleSpec "" = EmptyMatch 990parseSingleSpec "" = EmptyMatch
971parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag 991parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag
972parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag 992parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag
993parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag
973parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp 994parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
974parseSingleSpec str 995parseSingleSpec str
975 | is40digitHex str = FingerprintMatch str 996 | is40digitHex str = FingerprintMatch str
@@ -983,15 +1004,129 @@ is40digitHex xs = ys == xs && length ys==40
983 | 'a' <= c && c <= 'f' = True 1004 | 'a' <= c && c <= 'f' = True
984 ishex c = False 1005 ishex c = False
985 1006
1007data SpecError = SpecENone String
1008 | SpecEMissMatch String (Maybe MatchingField) MatchingField
1009 | SpecETooBig Spec
1010 | SpecETooMany String
1011 deriving (Eq,Show,Ord)
1012
1013 -- t:tor -- (AnyMatch , AnyMatch, SubstringMatch type "tor")
1014 -- u:joe -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "" )
1015 -- u:joe/ -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "!" )
1016 -- fp:4A39F/tor -- (AnyMatch , FingerprintMatch "4A39F", SubstringMatch type "tor")
1017 -- u:joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor")
1018 -- u:joe/t:tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor")
1019 -- u:joe/fp:4abf30 -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "4abf30")
1020 -- joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor")
1021 -- u:joe//fp:4abf30 -- (SubstringMatch user "joe", AnyMatch , FingerprintMatch "4abf30")
1022 -- c:buds//fp:4abf3 -- (SubstringMatch circ "buds", AnyMatch , FingerprintMatch "4abf3" )
1023 --
1024 -- where type = Just KeyTypeField
1025 -- user = Just UserIDField
1026 -- circ = Just GroupIDField
1027
1028-- | parseSpec3 - Parse a key specification.
1029parseSpec3 :: Maybe MatchingField -> String -> Either SpecError Spec
1030parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) =
1031 tooBigError maybeExpecting =<< applyContext maybeExpecting . fixUpSubstrMatch <$>
1032 case fields of
1033 [] -> Left (SpecENone spec)
1034 xs@[t] ->
1035 let ds = [0]
1036 x = l ds xs
1037 getTup1 [x] = tupSection1 (adjustPos x maybeExpecting) x
1038 where
1039 tupSection1 0 = (AnyMatch,AnyMatch,)
1040 tupSection1 1 = (AnyMatch,,AnyMatch)
1041 tupSection1 2 = (,AnyMatch,AnyMatch)
1042 tupSection1 _ = tupSection1 0
1043 in if all fst x then Right $ getTup1 (map (fst . snd) x)
1044 else Left $ mismatch x
1045 xs@[u,t] ->
1046 let ds = [1,0]
1047 x = l ds xs
1048 getTup2 [u,t] = indexHole (head (filter (`notElem` gots [u,t]) [0..2])) u t
1049 where gots xs = zipWith gotIndex [1,0] xs
1050 indexHole 0 = (,,AnyMatch)
1051 indexHole 1 = (,AnyMatch,)
1052 indexHole 2 = (AnyMatch,,)
1053 in if all fst x then Right $ getTup2 (map (fst . snd) x)
1054 else Left $ mismatch x
1055 xs@[c,u,t] ->
1056 let ds = [2,1,0]
1057 x = l ds xs
1058 getTup3 [a,b,c] = (a,b,c)
1059 in if all fst x then Right $ getTup3 (map (fst . snd) x)
1060 else Left $ mismatch x
1061 _ -> Left (SpecETooMany spec)
1062 where expectIndex dflt = maybe dflt fromEnum maybeExpecting
1063
1064 l :: [Int] -> [String] -> [(Bool, (SingleKeySpec,Int))]
1065 l defaults specs = zipWith (\x y -> (valid (p x) y, (p x,y))) specs defaults
1066 where p x = parseSingleSpec x
1067
1068 valid :: SingleKeySpec -> Int -> Bool
1069 valid spec dflt = ("tuc"::String) !! gotIndex dflt spec `notElem` forbidden (gotIndex dflt spec)
1070 where
1071 forbidden 0 = "uc"
1072 forbidden 1 = "tc"
1073 forbidden 2 = "tu"
1074
1075 adjustPos (SubstringMatch (Just KeyTypeField) _) Nothing = 0
1076 adjustPos (SubstringMatch (Just UserIDField) _) Nothing = 1
1077 adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2
1078 adjustPos _ (Just i) = fromEnum i
1079
1080 gotIndex :: Int -> SingleKeySpec -> Int
1081 gotIndex dflt (SubstringMatch (Just got) _) = fromEnum got
1082 gotIndex dflt _ = dflt
1083
1084 -- FIXME: This throws an exception if input is
1085 -- not an erroneous SubstringMatch.
1086 mismatch :: [(Bool,(SingleKeySpec,Int))] -> SpecError
1087 mismatch xs = case find (not . fst) (reverse xs) of
1088 Just (_,(SubstringMatch mbF s,n)) -> SpecEMissMatch s mbF (toEnum n)
1089
1090 fixUpSubstrMatch (g,u,t) = (set GroupIDField g, set UserIDField u, set KeyTypeField t)
1091 where
1092 set field (SubstringMatch Nothing xs) = SubstringMatch (Just field) xs
1093 set _ EmptyMatch = AnyMatch
1094 set field x = x
1095
1096 applyContext :: Maybe MatchingField -> Spec -> Spec
1097 applyContext Nothing x = x
1098
1099 applyContext (Just KeyTypeField) ((AnyMatch,u,AnyMatch)) = (AnyMatch,AnyMatch,u)
1100 applyContext (Just KeyTypeField) ((g,u,AnyMatch)) = (g,AnyMatch,u)
1101 applyContext (Just KeyTypeField) x = x
1102
1103 applyContext (Just UserIDField) ((AnyMatch,AnyMatch,x)) = (AnyMatch,x,AnyMatch)
1104 applyContext (Just UserIDField) ((AnyMatch,u,x)) = (AnyMatch,u,x)
1105 applyContext (Just UserIDField) x = x
1106
1107 applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch)
1108 applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x)
1109 applyContext (Just GroupIDField) x = x
1110
1111 --applyContext (Just UserIDField) (Right (g,u,x)) = Left $
1112 -- SpecEMissMatch (getStr g) (Just GroupIDField) UserIDField
1113 tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $
1114 SpecEMissMatch str (Just GroupIDField) KeyTypeField
1115 tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $
1116 SpecEMissMatch str (Just GroupIDField) UserIDField
1117
1118 tooBigError Nothing x = return x
1119 tooBigError (Just UserIDField) s@(g,u,t) | g /= AnyMatch = Left $
1120 SpecETooBig s -- (getStr g) (Just GroupIDField) UserIDField
1121 tooBigError (Just KeyTypeField) s@(g,u,t) | g /= AnyMatch = Left $
1122 SpecETooBig s --(getStr g) (Just GroupIDField) KeyTypeField
1123 tooBigError _ x = return x
1124
1125wordsBy _ [] = []
1126wordsBy c xs = let (b,a) = span (/=c) xs
1127 in b:wordsBy c (drop 1 a)
1128
986 1129
987 -- t:tor -- (FingerprintMatch "", SubstringMatch "tor")
988 -- u:joe -- (SubstringMatch "joe", FingerprintMatch "")
989 -- u:joe/ -- (SubstringMatch "joe", FingerprintMatch "!")
990 -- fp:4A39F/tor -- (FingerprintMatch "4A39F", SubstringMatch "tor")
991 -- u:joe/tor -- (SubstringMatch "joe", SubstringMatch "tor")
992 -- u:joe/t:tor -- (SubstringMatch "joe", SubstringMatch "tor")
993 -- u:joe/fp:4abf30 -- (SubstringMatch "joe", FingerprintMatch "4abf30")
994 -- joe/tor -- (SubstringMatch "joe", SubstringMatch "tor")
995 1130
996-- | Parse a key specification. 1131-- | Parse a key specification.
997-- The first argument is a grip for the default working key. 1132-- The first argument is a grip for the default working key.
diff --git a/testkiki/testkiki.hs b/testkiki/testkiki.hs
index c8b141b..d588336 100644
--- a/testkiki/testkiki.hs
+++ b/testkiki/testkiki.hs
@@ -29,6 +29,7 @@ import System.IO.Unsafe (unsafePerformIO)
29import ProcessUtils 29import ProcessUtils
30import Data.Bool 30import Data.Bool
31import Data.Char 31import Data.Char
32import KeyRing
32 33
33#if !MIN_VERSION_base(4,7,0) 34#if !MIN_VERSION_base(4,7,0)
34setEnv k v = System.Posix.Env.setEnv k v True 35setEnv k v = System.Posix.Env.setEnv k v True
@@ -80,6 +81,134 @@ didFirstEportSecret = unsafePerformIO $ newIORef False
80 81
81doTests :: TestKikiSettings -> IO () 82doTests :: TestKikiSettings -> IO ()
82doTests tkConfig = hspec $ do 83doTests tkConfig = hspec $ do
84 describe "parseSpec3" $ do
85 it "succeeds as expected" $ do
86 let resultOf x = (x,parseSpec3 Nothing x)
87 rslt y x = (x, parseSpec3 (Just y) x)
88 let typ = Just KeyTypeField
89 user = Just UserIDField
90 circ = Just GroupIDField
91 resultOf "u:joe//fp:4abf30"
92 `shouldBe` ("u:joe//fp:4abf30",Right (SubstringMatch user "joe",AnyMatch, FingerprintMatch "4abf30"))
93 resultOf "t:tor"
94 `shouldBe` ("t:tor",Right (AnyMatch, AnyMatch, SubstringMatch typ "tor"))
95 resultOf "u:joe"
96 `shouldBe` ("u:joe",Right (AnyMatch, SubstringMatch user "joe", AnyMatch ))
97 resultOf "u:joe/"
98 `shouldBe` ("u:joe/",Right (AnyMatch, SubstringMatch user "joe", AnyMatch ))
99 resultOf "fp:4A39F/tor"
100 `shouldBe` ("fp:4A39F/tor",Right (AnyMatch, FingerprintMatch "4A39F", SubstringMatch typ "tor"))
101 resultOf "u:joe/tor"
102 `shouldBe` ("u:joe/tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
103 resultOf "u:joe/t:tor"
104 `shouldBe` ("u:joe/t:tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
105 resultOf "u:joe/fp:4abf30"
106 `shouldBe` ("u:joe/fp:4abf30",Right (AnyMatch, SubstringMatch user "joe", FingerprintMatch "4abf30"))
107 resultOf "joe/tor"
108 `shouldBe` ("joe/tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
109 resultOf "c:buds//fp:4abf3"
110 `shouldBe` ("c:buds//fp:4abf3",Right (SubstringMatch circ "buds", AnyMatch, FingerprintMatch "4abf3" ))
111
112 it "succeeds as expected, with context: UserIDField" $ do
113 let resultOf x = (x,parseSpec3 Nothing x)
114 rslt y x = (x, parseSpec3 (Just y) x)
115 let typ = Just KeyTypeField
116 user = Just UserIDField
117 circ = Just GroupIDField
118 rslt UserIDField "t:tor"
119 `shouldBe` ("t:tor",Right (AnyMatch, SubstringMatch typ "tor", AnyMatch ))
120 rslt UserIDField "u:joe"
121 `shouldBe` ("u:joe",Right (AnyMatch, SubstringMatch user "joe", AnyMatch ))
122 rslt UserIDField "u:joe/"
123 `shouldBe` ("u:joe/",Right (AnyMatch, SubstringMatch user "joe", AnyMatch ))
124 rslt UserIDField "fp:4A39F/tor"
125 `shouldBe` ("fp:4A39F/tor",Right (AnyMatch, FingerprintMatch "4A39F", SubstringMatch typ "tor"))
126 rslt UserIDField "u:joe/tor"
127 `shouldBe` ("u:joe/tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
128 rslt UserIDField "u:joe/t:tor"
129 `shouldBe` ("u:joe/t:tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
130 rslt UserIDField "u:joe/fp:4abf30"
131 `shouldBe` ("u:joe/fp:4abf30",Right (AnyMatch, SubstringMatch user "joe", FingerprintMatch "4abf30"))
132 rslt UserIDField "joe/tor"
133 `shouldBe` ("joe/tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
134
135 it "succeeds as expected, with context: GroupIDField" $ do
136 let resultOf x = (x,parseSpec3 Nothing x)
137 rslt y x = (x, parseSpec3 (Just y) x)
138 let typ = Just KeyTypeField
139 user = Just UserIDField
140 circ = Just GroupIDField
141 rslt GroupIDField "u:joe//fp:4abf30"
142 `shouldBe` ("u:joe//fp:4abf30",Right (SubstringMatch user "joe",AnyMatch, FingerprintMatch "4abf30"))
143 rslt GroupIDField "t:tor"
144 `shouldBe` ("t:tor",Right (SubstringMatch typ "tor", AnyMatch, AnyMatch))
145 rslt GroupIDField "u:joe"
146 `shouldBe` ("u:joe",Right (SubstringMatch user "joe", AnyMatch, AnyMatch ))
147 rslt GroupIDField "u:joe/"
148 `shouldBe` ("u:joe/",Right (SubstringMatch user "joe", AnyMatch, AnyMatch ))
149 rslt GroupIDField "fp:4A39F/tor"
150 `shouldBe` ("fp:4A39F/tor",Right (FingerprintMatch "4A39F", AnyMatch, SubstringMatch typ "tor"))
151 rslt GroupIDField "u:joe/tor"
152 `shouldBe` ("u:joe/tor",Right (SubstringMatch user "joe", AnyMatch, SubstringMatch typ "tor"))
153 rslt GroupIDField "u:joe/t:tor"
154 `shouldBe` ("u:joe/t:tor",Right (SubstringMatch user "joe", AnyMatch, SubstringMatch typ "tor"))
155 rslt GroupIDField "u:joe/fp:4abf30"
156 `shouldBe` ("u:joe/fp:4abf30",Right (SubstringMatch user "joe", AnyMatch, FingerprintMatch "4abf30"))
157 rslt GroupIDField "joe/tor"
158 `shouldBe` ("joe/tor",Right (SubstringMatch user "joe",AnyMatch, SubstringMatch typ "tor"))
159 rslt GroupIDField "c:buds//fp:4abf3"
160 `shouldBe` ("c:buds//fp:4abf3",Right (SubstringMatch circ "buds", AnyMatch, FingerprintMatch "4abf3" ))
161
162 it "succeeds as expected, with context: KeyTypeField" $ do
163 let resultOf x = (x,parseSpec3 Nothing x)
164 rslt y x = (x, parseSpec3 (Just y) x)
165 let typ = Just KeyTypeField
166 user = Just UserIDField
167 circ = Just GroupIDField
168 rslt KeyTypeField "t:tor"
169 `shouldBe` ("t:tor",Right (AnyMatch, AnyMatch, SubstringMatch typ "tor"))
170 rslt KeyTypeField "u:joe"
171 `shouldBe` ("u:joe",Right (AnyMatch, AnyMatch, SubstringMatch user "joe" ))
172 rslt KeyTypeField "u:joe/"
173 `shouldBe` ("u:joe/",Right (AnyMatch, AnyMatch, SubstringMatch user "joe" ))
174 rslt KeyTypeField "fp:4A39F/tor"
175 `shouldBe` ("fp:4A39F/tor",Right (AnyMatch, FingerprintMatch "4A39F", SubstringMatch typ "tor"))
176 rslt KeyTypeField "u:joe/tor"
177 `shouldBe` ("u:joe/tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
178 rslt KeyTypeField "u:joe/t:tor"
179 `shouldBe` ("u:joe/t:tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
180 rslt KeyTypeField "u:joe/fp:4abf30"
181 `shouldBe` ("u:joe/fp:4abf30",Right (AnyMatch, SubstringMatch user "joe", FingerprintMatch "4abf30"))
182 rslt KeyTypeField "joe/tor"
183 `shouldBe` ("joe/tor",Right (AnyMatch, SubstringMatch user "joe", SubstringMatch typ "tor"))
184
185
186 it "fails as expected" $ do
187 let resultOf x = (x,parseSpec3 Nothing x)
188 rslt y x = (x, parseSpec3 (Just y) x)
189 let typ = Just KeyTypeField
190 user = Just UserIDField
191 circ = Just GroupIDField
192 -- TODO: Should be error:
193 resultOf "//c:buds"
194 `shouldBe` ("//c:buds",
195 (Left $ SpecEMissMatch "buds" (Just GroupIDField) KeyTypeField))
196 resultOf "/c:buds/"
197 `shouldBe` ("/c:buds/",
198 (Left $ SpecEMissMatch "buds" (Just GroupIDField) UserIDField))
199 rslt UserIDField "c:buds//fp:4abf3"
200 `shouldBe` ("c:buds//fp:4abf3",
201 (Left . SpecETooBig) (SubstringMatch (Just GroupIDField) "buds",AnyMatch, FingerprintMatch "4abf3"))
202 rslt UserIDField "u:joe//fp:4abf30"
203 `shouldBe` ("u:joe//fp:4abf30",
204 (Left . SpecETooBig) (SubstringMatch (Just UserIDField) "joe",AnyMatch, FingerprintMatch "4abf30"))
205 rslt KeyTypeField "u:joe//fp:4abf30"
206 `shouldBe` ("u:joe//fp:4abf30",
207 Left (SpecETooBig (SubstringMatch user "joe",AnyMatch, FingerprintMatch "4abf30")))
208 rslt KeyTypeField "c:buds//fp:4abf3"
209 `shouldBe` ("c:buds//fp:4abf3",
210 (Left . SpecETooBig) (SubstringMatch circ "buds", AnyMatch, FingerprintMatch "4abf3" ))
211
83 {- 212 {-
84 -- Example of shouldThrow 213 -- Example of shouldThrow
85 describe "TODO: error" $ 214 describe "TODO: error" $