Finished encapsulation of KeyDB.

2 files changed, 145 insertions, 89 deletions

diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 8af8198..cd1bae9 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -185,8 +185,7 @@ buildKeyDB ctx grip0 keyring = do
         db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed
                     where
                       mergeIt db f (_,dbtrans)
-                        = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans)
-                                }
+                        = mergeKeyDB mergeKeyData db dbtrans
         -- | reportTrans
         -- events, indexed by file
         reportTrans :: [(FilePath, KikiReportAction)]
@@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do
             -- TODO: KikiCondition reporting for spill/fill usage mismatch?
             -- TODO: parseSpec3
             let (topspec,subspec) = parseSpec grip usage
-                ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db)
+                ms = map fst $ filterMatches topspec (kkData db)
                 cmd = initializer stream
             return (n,subspec,ms,stream, cmd)
 
@@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma
         case p of
             _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
             _ | isKey p && is_subkey p       -> (top,p,ret p)
-            _ | isUserID p                   -> (top,p,ret p)
+            _ | isJust (isUserID p)          -> (top,p,ret p)
             _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
             _                                -> (top,sub,ret p)
 
@@ -385,10 +384,14 @@ doImportG
      -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
 doImportG transcode db m0 tags fname key = do
     let kk = head m0
-        Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
+    {-
+    let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
     kdr <- insertSubkey transcode kk kd tags fname key
-    try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) }
-                                                 , rrs)
+    try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db
+                                                 , rrs )
+    -}
+    let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key
+    transmuteAt go kk db
 
 
 iswallet :: FileType -> Bool
@@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do
     guard $ all (null . Hosts.namesForAddress addr) hostdbs0
     return addr
   where
-    gpgnames = map getHostnames $ Map.elems $ byKeyKey db
+    gpgnames = map getHostnames $ keyData db
 
 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
 filterMatches spec ks = filter (matchSpec spec . snd) ks
@@ -513,14 +516,13 @@ generateInternals ::
     -> [(GenerateKeyParams,StreamInfo)]
     -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
 generateInternals transcode mwk db gens = do
-    case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of
-        Just kd0 -> do
-            kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
-            try kd $ \(kd,reportGens) -> do
-            let kk = keykey $ packet $ fromJust mwk
-            return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) }
-                                 , reportGens )
+    case mwk of
         Nothing -> return $ KikiSuccess (db,[])
+        Just mpkt -> do
+            let kk = keykey (packet mpkt)
+            transmuteAt (go kk) kk db
+        where
+         go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
 
 mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
      -> IO
@@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do
 
     hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
 
-    let gpgnames = map getHostnames $ Map.elems (byKeyKey db)
+    let gpgnames = map getHostnames $ keyData db
         os = do
             Hostnames addr ns _ _ <- gpgnames
             n <- ns
@@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do
 
     -- 2. replace gpg annotations with those in U
     -- forM use_db
-    db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db)
-            <&> \m -> db { byKeyKey = m }
+    db' <- mapKeyDB (setHostnames addrs u1) db
 
     return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[])
 
@@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
     -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
     mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
     mergeit db adding@(n,(top,sub,ptt@(p,trustmap)))
-        | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) }
+        | isKey top = alterKeyDB update (keykey top) db
       where
         update Nothing   = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
         update (Just kd) = dbInsertPacket kd filename adding
@@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
     uids0 = fmap zapIfHasName uids
     fstuid = head $ do
         p <- map packet $ flattenAllUids "" True uids
-        guard $ isUserID p
-        return $ uidkey p
+        maybeToList $ isUserID p
     uids1 = Map.adjust addnames fstuid uids0
     addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
      where
@@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
                                          ,show (fingerprint top, fingerprint p)]
     update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
           = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
-    update (Just (KeyData key sigs uids subkeys)) | isUserID p
-          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
+    update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids)
                                     subkeys
     update (Just (KeyData key sigs uids subkeys))
           = case sub of
              MarkerPacket    -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
-             UserIDPacket {} -> Just $ KeyData key
+             UserIDPacket uid-> Just $ KeyData key
                                                sigs
-                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
+                                               (Map.alter (mergeUidSig n ptt) uid uids)
                                                subkeys
              _  | isKey sub  -> Just $ KeyData key
                                                sigs
@@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do
         nlen = S.length bs
 
 
-selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
-selectKey0 wantPublic (spec,mtag) db = do
-    let Message ps = flattenKeys wantPublic $ byKeyKey db
-        ys = snd $ seek_key spec ps
-    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
-      case ys of
-          y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
-          []    -> Nothing
-
 -- TODO: Data.ByteString.Lazy now exports this.
 toStrict :: L.ByteString -> S.ByteString
 toStrict = foldr1 (<>) . L.toChunks
@@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e =
                     , v3_days_of_validity = Nothing
                     }
 
-flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
-flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
-                                              (prefilter . Map.assocs $ db)
- where
-    prefilter = if isPublic then id else filter isSecret
-                 where
-                  isSecret (_,(KeyData
-                                  (MappedPacket { packet=(SecretKeyPacket {})})
-                                  _
-                                  _
-                                  _)) = True
-                  isSecret _          = False
-
-seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
-seek_key (KeyGrip grip) sec = (pre, subs)
-  where
-    (pre,subs) = break pred sec
-    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
-    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
-    pred _                      = False
-
-seek_key (KeyTag key tag) ps
-    | null bs = (ps, [])
-    | null qs =
-      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
-        (as ++ (head bs : as'), bs')
-    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
-  where
-    (as,bs) = break (\p -> isSignaturePacket p
-                        && has_tag tag p
-                        && isJust (signature_issuer p)
-                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
-                    ps
-    (rs,qs) = break isKey (reverse as)
-
-    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
-                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
-
-seek_key (KeyUidMatch pat) ps
-    | null bs = (ps, [])
-    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
-                    (as ++ (head bs : as'), bs')
-    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
-  where
-    (as,bs) = break (isInfixOf pat . uidStr) ps
-    (rs,qs) = break isKey (reverse as)
-
-    uidStr (UserIDPacket s) = s
-    uidStr _                = ""
-
diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs
index 3c1f0a5..4a0b34e 100644
--- a/lib/KeyRing/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -3,12 +3,13 @@
 {-# LANGUAGE PatternSynonyms   #-}
 module KeyRing.Types where
 
+import           Data.Bits
 import           Data.Char (isLower,toLower)
 import           Data.Functor
-import           Data.List (groupBy,find)
+import           Data.List (groupBy,find,isInfixOf)
 import           Data.Map as Map (Map)
 import qualified Data.Map as Map
-import           Data.Maybe (maybeToList)
+import           Data.Maybe (maybeToList,isJust,fromJust,mapMaybe)
 import           Data.OpenPGP
 import           Data.OpenPGP.Util
 import           Data.Time.Clock
@@ -335,9 +336,9 @@ isSecretKey (SecretKeyPacket {}) = True
 isSecretKey _                    = False
 
 
-isUserID :: Packet -> Bool
-isUserID (UserIDPacket {}) = True
-isUserID _                 = False
+isUserID :: Packet -> Maybe String
+isUserID (UserIDPacket str) = Just str
+isUserID _                  = Nothing
 
 isTrust :: Packet -> Bool
 isTrust (TrustPacket {}) = True
@@ -408,3 +409,117 @@ data SingleKeySpec = FingerprintMatch String
                    | WorkingKeyMatch
  deriving (Show,Eq,Ord)
 
+secretToPublic :: Packet -> Packet
+secretToPublic pkt@(SecretKeyPacket {}) =
+    PublicKeyPacket { version = version pkt
+                    , timestamp = timestamp pkt
+                    , key_algorithm = key_algorithm pkt
+                    -- , ecc_curve = ecc_curve pkt
+                    , key = let seckey = key pkt
+                                pubs = public_key_fields (key_algorithm pkt)
+                            in filter (\(k,v) -> k `elem` pubs) seckey
+                    , is_subkey = is_subkey pkt
+                    , v3_days_of_validity = Nothing
+                    }
+secretToPublic pkt = pkt
+
+seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
+seek_key (KeyGrip grip) sec = (pre, subs)
+  where
+    (pre,subs) = break pred sec
+    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
+    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
+    pred _                      = False
+
+seek_key (KeyTag key tag) ps
+    | null bs = (ps, [])
+    | null qs =
+      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
+        (as ++ (head bs : as'), bs')
+    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (\p -> isSignaturePacket p
+                        && has_tag tag p
+                        && isJust (signature_issuer p)
+                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
+                    ps
+    (rs,qs) = break isKey (reverse as)
+
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+seek_key (KeyUidMatch pat) ps
+    | null bs = (ps, [])
+    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
+                    (as ++ (head bs : as'), bs')
+    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
+  where
+    (as,bs) = break (isInfixOf pat . uidStr) ps
+    (rs,qs) = break isKey (reverse as)
+
+    uidStr (UserIDPacket s) = s
+    uidStr _                = ""
+
+usageString :: PGPKeyFlags -> String
+usageString flgs =
+ case flgs of
+    Special                -> "special"
+    Vouch                  -> "vouch" -- signkey
+    Sign                   -> "sign"
+    VouchSign              -> "vouch-sign"
+    Communication          -> "communication"
+    VouchCommunication     -> "vouch-communication"
+    SignCommunication      -> "sign-communication"
+    VouchSignCommunication -> "vouch-sign-communication"
+    Storage                -> "storage"
+    VouchStorage           -> "vouch-storage"
+    SignStorage            -> "sign-storage"
+    VouchSignStorage       -> "vouch-sign-storage"
+    Encrypt                -> "encrypt"
+    VouchEncrypt           -> "vouch-encrypt"
+    SignEncrypt            -> "sign-encrypt"
+    VouchSignEncrypt       -> "vouch-sign-encrypt"
+
+usage :: SignatureSubpacket -> Maybe String
+usage (NotationDataPacket
+        { human_readable = True
+        , notation_name  = "usage@"
+        , notation_value = u
+        }) = Just u
+usage _    = Nothing
+
+data PGPKeyFlags =
+    Special
+    | Vouch                  -- 0001 C -- Signkey
+    | Sign                   -- 0010 S
+    | VouchSign              -- 0011
+    | Communication          -- 0100 E
+    | VouchCommunication     -- 0101
+    | SignCommunication      -- 0110
+    | VouchSignCommunication -- 0111
+    | Storage                -- 1000 E
+    | VouchStorage           -- 1001
+    | SignStorage            -- 1010
+    | VouchSignStorage       -- 1011
+    | Encrypt                -- 1100 E
+    | VouchEncrypt           -- 1101
+    | SignEncrypt            -- 1110
+    | VouchSignEncrypt       -- 1111
+ deriving (Eq,Show,Read,Enum)
+
+-- XXX keyFlags and keyflags are different functions.
+keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
+keyflags flgs@(KeyFlagsPacket {}) =
+    Just . toEnum $
+        (   bit 0x1 certify_keys
+        .|. bit 0x2 sign_data
+        .|. bit 0x4 encrypt_communication
+        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
+    -- other flags:
+    --  split_key
+    --  authentication (ssh-client)
+    --  group_key
+ where
+    bit v f = if f flgs then v else 0
+keyflags _ = Nothing
+