summaryrefslogtreecommitdiff
path: root/lib/KeyRing.hs
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 /lib/KeyRing.hs
parentbaf38b1c4aebebae1a3a93b9336d147ab7ce84c3 (diff)
function to parse Triple-Field Specs
Diffstat (limited to 'lib/KeyRing.hs')
-rw-r--r--lib/KeyRing.hs165
1 files changed, 150 insertions, 15 deletions
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.