function to parse Triple-Field Specs

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
     , isCryptoCoinKey
     , matchpr
     , parseSpec
+    , Spec
     , parseUID
     , UserIDRecord(..)
     , pkcs8
@@ -97,6 +98,10 @@ module KeyRing
     , keykey
     , keyPacket
     , KeySpec(..)
+    , MatchingField(..)
+    , SpecError(..)
+    , SingleKeySpec(..)
+    , parseSpec3
     , getHostnames
     , secretPemFromPacket
     , SubkeyStatus(..)
@@ -948,7 +953,7 @@ data KeySpec =
     | KeyUidMatch String   -- u:
  deriving Show
 
-data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum)
+data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
 data SingleKeySpec = FingerprintMatch String
                    | SubstringMatch (Maybe MatchingField) String
                    | EmptyMatch
@@ -956,13 +961,28 @@ data SingleKeySpec = FingerprintMatch String
                    | WorkingKeyMatch
  deriving (Show,Eq,Ord)
 
--- A pair of specs.  The first specifies an identity and the second
--- specifies a specific key (possibly master) associated with that
--- identity.
+getStr (FingerprintMatch x) = x
+getStr (SubstringMatch _ x) = x
+getStr _ = ""
+
+-- | Spec
+--
+-- The product type, SingleKeySpec³ = Circle × Identity × Key.
+--
+--  Key      -   A single public or private key (subkey, or master without subkeys) (eg, pem file)
+--  Identity -   A single master key with all its subkeys
+--  Circle   -   A collection of master keys with their subkeys                     (eg, gpg file)
+--
+-- The three fields are deliminated by slashes.
 --
--- When no slash is specified, context will decide whether the SingleKeySpec
--- is specifying an identity or a key belonging to the working identity.
-type Spec = (SingleKeySpec,SingleKeySpec)
+-- When context does not disambiguate, use the following default rules:
+-- There are(is)
+--    - no slashes,  so interpret as Key
+--    - one slash,   so interpret as Identity/Key
+--    - two slashes, so interpret as Circle/Identity/Key
+--
+-- (Any of the fields may be left empty.)
+type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec)
 
 parseSingleSpec :: String -> SingleKeySpec
 parseSingleSpec "*"              = AnyMatch
@@ -970,6 +990,7 @@ parseSingleSpec "-"              = WorkingKeyMatch
 parseSingleSpec ""               = EmptyMatch
 parseSingleSpec ('t':':':tag)    = SubstringMatch (Just KeyTypeField) tag
 parseSingleSpec ('u':':':tag)    = SubstringMatch (Just UserIDField) tag
+parseSingleSpec ('c':':':tag)    = SubstringMatch (Just GroupIDField) tag
 parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
 parseSingleSpec str
     | is40digitHex str = FingerprintMatch str
@@ -983,15 +1004,129 @@ is40digitHex xs = ys == xs && length ys==40
                 | 'a' <= c && c <= 'f' = True
         ishex c = False
 
+data SpecError = SpecENone String
+               | SpecEMissMatch String (Maybe MatchingField) MatchingField
+               | SpecETooBig    Spec
+               | SpecETooMany String
+        deriving (Eq,Show,Ord)
+
+  --  t:tor            -- (AnyMatch  ,                 AnyMatch,                  SubstringMatch type "tor")
+  --  u:joe            -- (AnyMatch  ,                 SubstringMatch user "joe", FingerprintMatch ""      )
+  --  u:joe/           -- (AnyMatch  ,                 SubstringMatch user "joe", FingerprintMatch "!"     )
+  --  fp:4A39F/tor     -- (AnyMatch  ,                 FingerprintMatch "4A39F",  SubstringMatch type "tor")
+  --  u:joe/tor        -- (AnyMatch  ,                 SubstringMatch user "joe", SubstringMatch type "tor")
+  --  u:joe/t:tor      -- (AnyMatch  ,                 SubstringMatch user "joe", SubstringMatch type "tor")
+  --  u:joe/fp:4abf30  -- (AnyMatch  ,                 SubstringMatch user "joe", FingerprintMatch "4abf30")
+  --  joe/tor          -- (AnyMatch  ,                 SubstringMatch user "joe", SubstringMatch type "tor")
+  --  u:joe//fp:4abf30 -- (SubstringMatch user "joe",  AnyMatch                 , FingerprintMatch "4abf30")
+  --  c:buds//fp:4abf3 -- (SubstringMatch circ "buds", AnyMatch                 , FingerprintMatch "4abf3" )
+  --
+  --                    where type = Just KeyTypeField
+  --                          user = Just UserIDField
+  --                          circ = Just GroupIDField
+
+-- | parseSpec3 - Parse a key specification.
+parseSpec3 :: Maybe MatchingField -> String -> Either SpecError Spec
+parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = 
+  tooBigError maybeExpecting =<< applyContext maybeExpecting . fixUpSubstrMatch <$> 
+    case fields of
+        []         -> Left (SpecENone spec)
+        xs@[t]     -> 
+                  let ds = [0]
+                      x  = l ds xs
+                      getTup1 [x] = tupSection1 (adjustPos x maybeExpecting) x
+                        where
+                          tupSection1 0 = (AnyMatch,AnyMatch,)
+                          tupSection1 1 = (AnyMatch,,AnyMatch)
+                          tupSection1 2 = (,AnyMatch,AnyMatch)
+                          tupSection1 _ = tupSection1 0 
+                      in if all fst x then Right $ getTup1 (map (fst . snd) x)
+                                      else Left $ mismatch x
+        xs@[u,t]   -> 
+                  let ds = [1,0]
+                      x  = l ds xs
+                      getTup2 [u,t] = indexHole (head (filter (`notElem` gots [u,t]) [0..2])) u t
+                        where gots xs = zipWith gotIndex [1,0] xs
+                              indexHole 0 = (,,AnyMatch)
+                              indexHole 1 = (,AnyMatch,)
+                              indexHole 2 = (AnyMatch,,)
+                      in if all fst x then Right $ getTup2 (map (fst . snd) x)
+                                      else Left $ mismatch x
+        xs@[c,u,t] ->
+                  let ds = [2,1,0]
+                      x  = l ds xs
+                      getTup3 [a,b,c] = (a,b,c)
+                      in if all fst x then Right $ getTup3 (map (fst . snd) x)
+                                      else Left $ mismatch x
+        _          -> Left (SpecETooMany spec)
+        where expectIndex dflt = maybe dflt fromEnum maybeExpecting
+
+              l :: [Int] -> [String] -> [(Bool, (SingleKeySpec,Int))]
+              l defaults specs = zipWith (\x y -> (valid (p x) y, (p x,y))) specs defaults
+                    where p x = parseSingleSpec x
+
+              valid :: SingleKeySpec -> Int -> Bool
+              valid spec dflt = ("tuc"::String) !! gotIndex dflt spec `notElem` forbidden (gotIndex dflt spec)
+                where
+                  forbidden 0 = "uc"
+                  forbidden 1 = "tc"
+                  forbidden 2 = "tu"
+
+              adjustPos (SubstringMatch (Just KeyTypeField) _) Nothing = 0
+              adjustPos (SubstringMatch (Just UserIDField)  _) Nothing = 1
+              adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2
+              adjustPos _ (Just i) = fromEnum i
+
+              gotIndex :: Int -> SingleKeySpec -> Int
+              gotIndex dflt (SubstringMatch (Just got) _) = fromEnum got
+              gotIndex dflt _ = dflt 
+
+              -- FIXME: This throws an exception if input is
+              --        not an erroneous SubstringMatch.
+              mismatch :: [(Bool,(SingleKeySpec,Int))] -> SpecError
+              mismatch xs = case find (not . fst)  (reverse xs) of
+                                    Just (_,(SubstringMatch mbF s,n)) -> SpecEMissMatch s mbF (toEnum n)
+
+              fixUpSubstrMatch (g,u,t) = (set GroupIDField g, set UserIDField u, set KeyTypeField t)
+                where
+                    set field (SubstringMatch Nothing xs) = SubstringMatch (Just field) xs
+                    set _ EmptyMatch = AnyMatch
+                    set field x = x
+
+              applyContext :: Maybe MatchingField -> Spec -> Spec
+              applyContext Nothing x = x
+
+              applyContext (Just KeyTypeField) ((AnyMatch,u,AnyMatch)) = (AnyMatch,AnyMatch,u)
+              applyContext (Just KeyTypeField) ((g,u,AnyMatch)) = (g,AnyMatch,u)
+              applyContext (Just KeyTypeField) x = x
+
+              applyContext (Just UserIDField) ((AnyMatch,AnyMatch,x)) = (AnyMatch,x,AnyMatch)
+              applyContext (Just UserIDField) ((AnyMatch,u,x)) = (AnyMatch,u,x)
+              applyContext (Just UserIDField) x = x
+
+              applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch)
+              applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x)
+              applyContext (Just GroupIDField) x = x
+
+              --applyContext (Just UserIDField) (Right (g,u,x)) = Left $ 
+              --  SpecEMissMatch (getStr g) (Just GroupIDField) UserIDField
+              tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $
+                SpecEMissMatch str (Just GroupIDField) KeyTypeField
+              tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $
+                SpecEMissMatch str (Just GroupIDField) UserIDField
+
+              tooBigError Nothing             x = return x
+              tooBigError (Just UserIDField) s@(g,u,t) | g /= AnyMatch = Left $
+                SpecETooBig s -- (getStr g) (Just GroupIDField) UserIDField
+              tooBigError (Just KeyTypeField) s@(g,u,t) | g /= AnyMatch = Left $
+                SpecETooBig s --(getStr g) (Just GroupIDField) KeyTypeField
+              tooBigError _ x = return x
+
+wordsBy _ [] = []
+wordsBy c xs = let (b,a) = span (/=c) xs
+                   in b:wordsBy c (drop 1 a)
+
 
-  --  t:tor                                    -- (FingerprintMatch "", SubstringMatch "tor")
-  --  u:joe                                    -- (SubstringMatch "joe", FingerprintMatch "")
-  --  u:joe/                                   -- (SubstringMatch "joe", FingerprintMatch "!")
-  --  fp:4A39F/tor                             -- (FingerprintMatch "4A39F", SubstringMatch "tor")
-  --  u:joe/tor                                -- (SubstringMatch "joe", SubstringMatch "tor")
-  --  u:joe/t:tor                              -- (SubstringMatch "joe", SubstringMatch "tor")
-  --  u:joe/fp:4abf30                          -- (SubstringMatch "joe", FingerprintMatch "4abf30")
-  --  joe/tor                                  -- (SubstringMatch "joe", SubstringMatch "tor")
 
 -- | Parse a key specification.
 -- The first argument is a grip for the default working key.