From 3f29bdc88a068ec3eab91a8bac12757e3a106ceb Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Sat, 13 Jul 2019 21:18:22 -0400
Subject: Finished encapsulation of KeyDB.

---
 lib/KeyDB.hs | 110 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 107 insertions(+), 3 deletions(-)

(limited to 'lib/KeyDB.hs')

diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs
index f5a4357..1f0849c 100644
--- a/lib/KeyDB.hs
+++ b/lib/KeyDB.hs
@@ -1,5 +1,4 @@
 module KeyDB
-    {-
     ( TrustMap
     , SigAndTrust
     , SubKey(..)
@@ -7,15 +6,31 @@ module KeyDB
     , KeyDB
     , emptyKeyDB
     , keyData
+    , kkData
+    , lookupKeyData
     , transmute
-    ) -} where
+    , transmuteAt
+    , alterKeyDB
+    , mergeKeyDB
+    , mapKeyDB
+    -- These probably don't belong here
+    , selectKey0
+    , flattenTop
+    , flattenAllUids
+    , flattenSub
+    , sortByHint
+    , flattenKeys
+    , flattenFiltered
+    ) where
 
 import Control.Monad
 import Data.Functor
+import Data.List
 import qualified Data.Map.Strict as Map
+import Data.Maybe
 import Data.OpenPGP
+import Data.Ord
 
-import FunctorToMaybe
 import KeyRing.Types
 
 type TrustMap = Map.Map FilePath Packet
@@ -43,6 +58,11 @@ emptyKeyDB = KeyDB { byKeyKey = Map.empty }
 keyData :: KeyDB -> [KeyData]
 keyData db = Map.elems (byKeyKey db)
 
+kkData :: KeyDB -> [(KeyKey, KeyData)]
+kkData db = Map.toList (byKeyKey db)
+
+lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData
+lookupKeyData kk db = Map.lookup kk (byKeyKey db)
 
 transmute :: (Monad m, Monad kiki, Traversable kiki) =>
        ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter
@@ -56,3 +76,87 @@ transmute perform update db = do
     r <- sequenceA <$> mapM performAll (byKeyKey db)
     return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk }
                            , concatMap snd $ Map.elems bkk )
+
+alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB
+alterKeyDB update kk db = db { byKeyKey = Map.alter update kk (byKeyKey db) }
+
+transmuteAt :: ( Monad m
+               , Functor kiki
+               ) => (Maybe KeyData -> m (kiki (KeyData,[info]))) -> KeyKey -> KeyDB -> m (kiki (KeyDB,[info]))
+transmuteAt go kk db = do
+    kdr <- go (Map.lookup kk $ byKeyKey db)
+    return $ kdr <&> \(kd',rrs) -> ( alterKeyDB (const $ Just kd') kk db
+                                   , rrs )
+
+mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB
+mergeKeyDB mergeKeyData db dbtrans =
+    KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) }
+
+mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB
+mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db)
+
+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
+
+
+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
+
+flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
+flattenUid fname ispub (str,(sigs,om)) =
+    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
+
+flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
+flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
+
+flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
+flattenAllUids fname ispub uids =
+    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+
+flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
+flattenTop fname ispub (KeyData key sigs uids subkeys) =
+    unk ispub key :
+            ( flattenAllUids fname ispub uids
+             ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
+
+sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
+sortByHint fname f = sortBy (comparing gethint)
+  where
+    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
+    defnum = -1
+
+concatSort ::
+  FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
+concatSort fname getp f = concat . sortByHint fname getp . map f
+
+unk :: Bool -> MappedPacket -> MappedPacket
+unk isPublic = if isPublic then toPacket secretToPublic else id
+                where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
+
+
+unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
+unsig fname isPublic (sig,trustmap) =
+    sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
+  where
+    f n _ = n==fname -- && trace ("fname=n="++show n) True
+    asMapped n p = let m = mappedPacket fname p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
+
+flattenFiltered :: Bool -> (KeyData -> Bool) -> KeyDB -> Message
+flattenFiltered wantPublic pred db = flattenKeys wantPublic $ Map.filter pred (byKeyKey db)
-- 
cgit v1.2.3