function to parse Triple-Field Specs

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
 Flag unixEnv
   Default: False
 
+Executable xx
+    Main-is: xx.hs
+    Build-Depends: base, kiki
+
 Executable kiki
     Main-is: kiki.hs
     -- 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
     , 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.
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)
 import ProcessUtils
 import Data.Bool
 import Data.Char
+import KeyRing
 
 #if !MIN_VERSION_base(4,7,0)
 setEnv k v = System.Posix.Env.setEnv k v True
@@ -80,6 +81,134 @@ didFirstEportSecret = unsafePerformIO $ newIORef False
 
 doTests :: TestKikiSettings -> IO ()
 doTests tkConfig = hspec $ do
+    describe "parseSpec3" $ do
+        it "succeeds as expected" $ do
+            let resultOf x = (x,parseSpec3 Nothing x)
+                rslt y x = (x, parseSpec3 (Just y) x)
+            let typ = Just KeyTypeField
+                user = Just UserIDField
+                circ = Just GroupIDField
+            resultOf "u:joe//fp:4abf30"
+                `shouldBe` ("u:joe//fp:4abf30",Right (SubstringMatch user "joe",AnyMatch, FingerprintMatch "4abf30"))
+            resultOf "t:tor"
+                `shouldBe` ("t:tor",Right (AnyMatch,           AnyMatch,       SubstringMatch typ "tor"))
+            resultOf "u:joe"
+                `shouldBe` ("u:joe",Right (AnyMatch,           SubstringMatch user "joe", AnyMatch     ))
+            resultOf "u:joe/"
+                `shouldBe` ("u:joe/",Right (AnyMatch,          SubstringMatch user "joe", AnyMatch    ))
+            resultOf "fp:4A39F/tor"
+                `shouldBe` ("fp:4A39F/tor",Right (AnyMatch,    FingerprintMatch "4A39F",  SubstringMatch typ "tor"))
+            resultOf "u:joe/tor"
+                `shouldBe` ("u:joe/tor",Right (AnyMatch,       SubstringMatch user "joe", SubstringMatch typ "tor"))
+            resultOf "u:joe/t:tor"
+                `shouldBe` ("u:joe/t:tor",Right (AnyMatch,     SubstringMatch user "joe", SubstringMatch typ "tor"))
+            resultOf "u:joe/fp:4abf30"
+                `shouldBe` ("u:joe/fp:4abf30",Right (AnyMatch, SubstringMatch user "joe", FingerprintMatch "4abf30"))
+            resultOf "joe/tor"
+                `shouldBe` ("joe/tor",Right (AnyMatch,         SubstringMatch user "joe", SubstringMatch typ "tor"))
+            resultOf "c:buds//fp:4abf3"
+                `shouldBe` ("c:buds//fp:4abf3",Right (SubstringMatch circ "buds", AnyMatch, FingerprintMatch "4abf3" ))
+
+        it "succeeds as expected, with context: UserIDField" $ do
+            let resultOf x = (x,parseSpec3 Nothing x)
+                rslt y x = (x, parseSpec3 (Just y) x)
+            let typ = Just KeyTypeField
+                user = Just UserIDField
+                circ = Just GroupIDField
+            rslt UserIDField "t:tor"
+                `shouldBe` ("t:tor",Right (AnyMatch,        SubstringMatch typ "tor", AnyMatch      ))
+            rslt UserIDField "u:joe"
+                `shouldBe` ("u:joe",Right (AnyMatch,           SubstringMatch user "joe", AnyMatch     ))
+            rslt UserIDField "u:joe/"
+                `shouldBe` ("u:joe/",Right (AnyMatch,          SubstringMatch user "joe", AnyMatch    ))
+            rslt UserIDField "fp:4A39F/tor"
+                `shouldBe` ("fp:4A39F/tor",Right (AnyMatch,    FingerprintMatch "4A39F",  SubstringMatch typ "tor"))
+            rslt UserIDField "u:joe/tor"
+                `shouldBe` ("u:joe/tor",Right (AnyMatch,       SubstringMatch user "joe", SubstringMatch typ "tor"))
+            rslt UserIDField "u:joe/t:tor"
+                `shouldBe` ("u:joe/t:tor",Right (AnyMatch,     SubstringMatch user "joe", SubstringMatch typ "tor"))
+            rslt UserIDField "u:joe/fp:4abf30"
+                `shouldBe` ("u:joe/fp:4abf30",Right (AnyMatch, SubstringMatch user "joe", FingerprintMatch "4abf30"))
+            rslt UserIDField "joe/tor"
+                `shouldBe` ("joe/tor",Right (AnyMatch,         SubstringMatch user "joe", SubstringMatch typ "tor"))
+
+        it "succeeds as expected, with context: GroupIDField" $ do
+            let resultOf x = (x,parseSpec3 Nothing x)
+                rslt y x = (x, parseSpec3 (Just y) x)
+            let typ = Just KeyTypeField
+                user = Just UserIDField
+                circ = Just GroupIDField
+            rslt GroupIDField "u:joe//fp:4abf30"
+                `shouldBe` ("u:joe//fp:4abf30",Right (SubstringMatch user "joe",AnyMatch, FingerprintMatch "4abf30"))
+            rslt GroupIDField "t:tor"
+                `shouldBe` ("t:tor",Right (SubstringMatch typ "tor", AnyMatch,  AnyMatch))
+            rslt GroupIDField "u:joe"
+                `shouldBe` ("u:joe",Right (SubstringMatch user "joe", AnyMatch, AnyMatch     ))
+            rslt GroupIDField "u:joe/"
+                `shouldBe` ("u:joe/",Right (SubstringMatch user "joe", AnyMatch, AnyMatch    ))
+            rslt GroupIDField "fp:4A39F/tor"
+                `shouldBe` ("fp:4A39F/tor",Right (FingerprintMatch "4A39F", AnyMatch, SubstringMatch typ "tor"))
+            rslt GroupIDField "u:joe/tor"
+                `shouldBe` ("u:joe/tor",Right (SubstringMatch user "joe", AnyMatch,  SubstringMatch typ "tor"))
+            rslt GroupIDField "u:joe/t:tor"
+                `shouldBe` ("u:joe/t:tor",Right (SubstringMatch user "joe", AnyMatch,     SubstringMatch typ "tor"))
+            rslt GroupIDField "u:joe/fp:4abf30"
+                `shouldBe` ("u:joe/fp:4abf30",Right (SubstringMatch user "joe", AnyMatch, FingerprintMatch "4abf30"))
+            rslt GroupIDField "joe/tor"
+                `shouldBe` ("joe/tor",Right (SubstringMatch user "joe",AnyMatch,          SubstringMatch typ "tor"))
+            rslt GroupIDField "c:buds//fp:4abf3"
+                `shouldBe` ("c:buds//fp:4abf3",Right (SubstringMatch circ "buds", AnyMatch, FingerprintMatch "4abf3" ))
+
+        it "succeeds as expected, with context: KeyTypeField" $ do
+            let resultOf x = (x,parseSpec3 Nothing x)
+                rslt y x = (x, parseSpec3 (Just y) x)
+            let typ = Just KeyTypeField
+                user = Just UserIDField
+                circ = Just GroupIDField
+            rslt KeyTypeField "t:tor"
+                `shouldBe` ("t:tor",Right (AnyMatch,           AnyMatch,       SubstringMatch typ "tor"))
+            rslt KeyTypeField "u:joe"
+                `shouldBe` ("u:joe",Right (AnyMatch,           AnyMatch, SubstringMatch user "joe" ))
+            rslt KeyTypeField "u:joe/"
+                `shouldBe` ("u:joe/",Right (AnyMatch,          AnyMatch, SubstringMatch user "joe" ))
+            rslt KeyTypeField "fp:4A39F/tor"
+                `shouldBe` ("fp:4A39F/tor",Right (AnyMatch,    FingerprintMatch "4A39F",  SubstringMatch typ "tor"))
+            rslt KeyTypeField "u:joe/tor"
+                `shouldBe` ("u:joe/tor",Right (AnyMatch,       SubstringMatch user "joe", SubstringMatch typ "tor"))
+            rslt KeyTypeField "u:joe/t:tor"
+                `shouldBe` ("u:joe/t:tor",Right (AnyMatch,     SubstringMatch user "joe", SubstringMatch typ "tor"))
+            rslt KeyTypeField "u:joe/fp:4abf30"
+                `shouldBe` ("u:joe/fp:4abf30",Right (AnyMatch, SubstringMatch user "joe", FingerprintMatch "4abf30"))
+            rslt KeyTypeField "joe/tor"
+                `shouldBe` ("joe/tor",Right (AnyMatch,         SubstringMatch user "joe", SubstringMatch typ "tor"))
+
+
+        it "fails as expected" $ do
+            let resultOf x = (x,parseSpec3 Nothing x)
+                rslt y x = (x, parseSpec3 (Just y) x)
+            let typ = Just KeyTypeField
+                user = Just UserIDField
+                circ = Just GroupIDField
+            -- TODO: Should be error:
+            resultOf "//c:buds"
+                `shouldBe` ("//c:buds",
+                    (Left $ SpecEMissMatch "buds" (Just GroupIDField) KeyTypeField))
+            resultOf "/c:buds/"
+                `shouldBe` ("/c:buds/",
+                    (Left $ SpecEMissMatch "buds" (Just GroupIDField) UserIDField))
+            rslt UserIDField "c:buds//fp:4abf3"
+                `shouldBe` ("c:buds//fp:4abf3",
+                    (Left . SpecETooBig) (SubstringMatch (Just GroupIDField) "buds",AnyMatch, FingerprintMatch "4abf3"))
+            rslt UserIDField "u:joe//fp:4abf30"
+                `shouldBe` ("u:joe//fp:4abf30",
+                    (Left . SpecETooBig) (SubstringMatch (Just UserIDField) "joe",AnyMatch, FingerprintMatch "4abf30"))
+            rslt KeyTypeField "u:joe//fp:4abf30"
+                `shouldBe` ("u:joe//fp:4abf30",
+                    Left (SpecETooBig (SubstringMatch user "joe",AnyMatch, FingerprintMatch "4abf30")))
+            rslt KeyTypeField "c:buds//fp:4abf3"
+                `shouldBe` ("c:buds//fp:4abf3",
+                    (Left . SpecETooBig) (SubstringMatch circ "buds", AnyMatch, FingerprintMatch "4abf3" ))
+
     {-
     -- Example of shouldThrow
     describe "TODO: error" $