summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-04-14 21:35:25 -0400
committerjoe <joe@jerkface.net>2014-04-14 21:35:25 -0400
commitdb0e17c179453e22cbadfb8b514d2e7efede170d (patch)
tree04d852a98afe43aa7d73bb0a2a89ebdc5d44c198 /KeyRing.hs
parent294cda407d82c6b98b63ac21fea3b937ed1c4bb5 (diff)
moved more code from kiki.hs to KeyRing.hs for buildKeyDB
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs475
1 files changed, 471 insertions, 4 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index 5547673..9fd65f8 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -9,23 +9,35 @@ import System.Environment
9import Control.Monad 9import Control.Monad
10import Data.Maybe 10import Data.Maybe
11import Data.Char 11import Data.Char
12import Data.Ord
12import Data.List 13import Data.List
13import Data.OpenPGP 14import Data.OpenPGP
14import Data.Functor 15import Data.Functor
15import Data.Bits ( (.|.) ) 16import Data.Bits ( (.|.) )
16-- import Control.Applicative ( (<$>) ) 17import Control.Applicative ( liftA2, (<$>) )
17import System.Directory ( getHomeDirectory, doesFileExist ) 18import System.Directory ( getHomeDirectory, doesFileExist )
18import Control.Arrow ( first, second ) 19import Control.Arrow ( first, second )
19import Data.OpenPGP.Util ( fingerprint ) 20import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
20import Data.ByteString.Lazy ( ByteString ) 21import Data.ByteString.Lazy ( ByteString )
21import Text.Show.Pretty as PP ( ppShow ) 22import Text.Show.Pretty as PP ( ppShow )
22import Data.Word ( Word8 ) 23import Data.Word ( Word8 )
23import Data.Binary ( decode ) 24import Data.Binary ( decode )
24import ControlMaybe ( handleIO_ ) 25import ControlMaybe ( handleIO_ )
26import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
27 , ASN1(Start,End,IntVal,OID,BitString), ASN1ConstructionType(Sequence) )
28import Data.ASN1.BitArray ( BitArray(..), toBitArray )
29import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1' )
30import Data.ASN1.BinaryEncoding ( DER(..) )
31import Data.Time.Clock.POSIX ( getPOSIXTime )
25import qualified Data.Map as Map 32import qualified Data.Map as Map
26import qualified Data.ByteString.Lazy as L ( null, readFile, ByteString ) 33import qualified Data.ByteString.Lazy as L ( null, readFile, ByteString )
34import qualified Data.ByteString as S ( unpack )
27import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break ) 35import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break )
28import qualified Crypto.Types.PubKey.ECC as ECC 36import qualified Crypto.Types.PubKey.ECC as ECC
37import qualified Codec.Binary.Base32 as Base32
38import qualified Crypto.Hash.SHA1 as SHA1
39import qualified Data.Text as T ( Text, unpack, pack,
40 strip, reverse, drop, break, dropAround )
29import System.Posix.Types (EpochTime) 41import System.Posix.Types (EpochTime)
30import System.Posix.Files ( modificationTime, getFileStatus ) 42import System.Posix.Files ( modificationTime, getFileStatus )
31 43
@@ -97,12 +109,69 @@ filesToLock k secring pubring = do
97 109
98todo = error "unimplemented" 110todo = error "unimplemented"
99 111
100data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] 112data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
113data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
114
115pkcs8 (RSAKey n e) = RSAKey8 n e
116
117instance ASN1Object RSAPublicKey where
118 -- PKCS #1 RSA Public Key
119 toASN1 (RSAKey (MPI n) (MPI e))
120 = \xs -> Start Sequence
121 : IntVal n
122 : IntVal e
123 : End Sequence
124 : xs
125 fromASN1 _ =
126 Left "fromASN1: RSAPublicKey: unexpected format"
127
128instance ASN1Object PKCS8_RSAPublicKey where
129
130 -- PKCS #8 Public key data
131 toASN1 (RSAKey8 (MPI n) (MPI e))
132 = \xs -> Start Sequence
133 : Start Sequence
134 : OID [1,2,840,113549,1,1,1]
135 : End Sequence
136 : BitString (toBitArray bs 0)
137 : End Sequence
138 : xs
139 where
140 pubkey = Start Sequence : IntVal n : IntVal e : End Sequence : []
141 bs = encodeASN1' DER pubkey
142
143 fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
144 Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
145 fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
146 case decodeASN1' DER bs of
147 Right as -> fromASN1 as
148 Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
149 where
150 BitArray _ bs = b
151
152 fromASN1 _ =
153 Left "fromASN1: RSAPublicKey: unexpected format"
154
155data RSAPrivateKey = RSAPrivateKey
156 { rsaN :: MPI
157 , rsaE :: MPI
158 , rsaD :: MPI
159 , rsaP :: MPI
160 , rsaQ :: MPI
161 , rsaDmodP1 :: MPI
162 , rsaDmodQminus1 :: MPI
163 , rsaCoefficient :: MPI
164 }
165 deriving Show
166
167
168data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] | BadPassphrase
101 169
102#define TRIVIAL(OP) fmap _ (OP) = OP 170#define TRIVIAL(OP) fmap _ (OP) = OP
103instance Functor KikiCondition where 171instance Functor KikiCondition where
104 fmap f (KikiSuccess a) = KikiSuccess (f a) 172 fmap f (KikiSuccess a) = KikiSuccess (f a)
105 TRIVIAL( FailedToLock x ) 173 TRIVIAL( FailedToLock x )
174 TRIVIAL( BadPassphrase )
106instance FunctorToMaybe KikiCondition where 175instance FunctorToMaybe KikiCondition where
107 functorToMaybe (KikiSuccess a) = Just a 176 functorToMaybe (KikiSuccess a) = Just a
108 functorToMaybe _ = Nothing 177 functorToMaybe _ = Nothing
@@ -115,6 +184,8 @@ data KikiReportAction =
115 | NewWalletKey String 184 | NewWalletKey String
116 | YieldSignature 185 | YieldSignature
117 | YieldSecretKeyPacket String 186 | YieldSecretKeyPacket String
187 | UnableToUpdateExpiredSignature
188 | FailedToMakeSignature
118 189
119data KikiResult a = KikiResult 190data KikiResult a = KikiResult
120 { kikiCondition :: KikiCondition a 191 { kikiCondition :: KikiCondition a
@@ -130,6 +201,45 @@ usage (NotationDataPacket
130 }) = Just u 201 }) = Just u
131usage _ = Nothing 202usage _ = Nothing
132 203
204-- torsig g topk wkun uid timestamp extras = todo
205torSigOver topk wkun uid extras
206 = CertificationSignature (secretToPublic topk)
207 uid
208 (sigpackets 0x13
209 subpackets
210 subpackets_unh)
211 where
212 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
213 tsign
214 ++ extras
215 subpackets_unh = [IssuerPacket (fingerprint wkun)]
216 tsign = if keykey wkun == keykey topk
217 then [] -- tsign doesnt make sense for self-signatures
218 else [ TrustSignaturePacket 1 120
219 , RegularExpressionPacket regex]
220 -- <[^>]+[@.]asdf\.nowhere>$
221 regex = "<[^>]+[@.]"++hostname++">$"
222 -- regex = username ++ "@" ++ hostname
223 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
224 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
225 pu = parseUID uidstr where UserIDPacket uidstr = uid
226 subdomain' = escape . T.unpack . uid_subdomain
227 topdomain' = escape . T.unpack . uid_topdomain
228 escape s = concatMap echar s
229 where
230 echar '|' = "\\|"
231 echar '*' = "\\*"
232 echar '+' = "\\+"
233 echar '?' = "\\?"
234 echar '.' = "\\."
235 echar '^' = "\\^"
236 echar '$' = "\\$"
237 echar '\\' = "\\\\"
238 echar '[' = "\\["
239 echar ']' = "\\]"
240 echar c = [c]
241
242
133keyflags flgs@(KeyFlagsPacket {}) = 243keyflags flgs@(KeyFlagsPacket {}) =
134 Just . toEnum $ 244 Just . toEnum $
135 ( bit 0x1 certify_keys 245 ( bit 0x1 certify_keys
@@ -268,6 +378,37 @@ matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us
268 where 378 where
269 us = filter (isInfixOf pat) $ Map.keys uids 379 us = filter (isInfixOf pat) $ Map.keys uids
270 380
381data UserIDRecord = UserIDRecord {
382 uid_full :: String,
383 uid_realname :: T.Text,
384 uid_user :: T.Text,
385 uid_subdomain :: T.Text,
386 uid_topdomain :: T.Text
387}
388 deriving Show
389
390parseUID str = UserIDRecord {
391 uid_full = str,
392 uid_realname = realname,
393 uid_user = user,
394 uid_subdomain = subdomain,
395 uid_topdomain = topdomain
396 }
397 where
398 text = T.pack str
399 (T.strip-> realname, T.dropAround isBracket-> email)
400 = T.break (=='<') text
401 (user, T.drop 1-> hostname) = T.break (=='@') email
402 ( T.reverse -> topdomain,
403 T.reverse . T.drop 1 -> subdomain)
404 = T.break (=='.') . T.reverse $ hostname
405isBracket :: Char -> Bool
406isBracket '<' = True
407isBracket '>' = True
408isBracket _ = False
409
410
411
271 412
272data KeySpec = 413data KeySpec =
273 KeyGrip String 414 KeyGrip String
@@ -309,11 +450,132 @@ buildKeyDB secring pubring grip0 keyring = do
309 db0 = foldl' (uncurry . merge) Map.empty ms 450 db0 = foldl' (uncurry . merge) Map.empty ms
310 451
311 wms <- mapM (readw wk) (files iswallet) 452 wms <- mapM (readw wk) (files iswallet)
312 453 let wms' = do
454 maybeToList wk
455 (fname,xs) <- wms
456 (_,sub,(_,m)) <- xs
457 (tag,top) <- Map.toList m
458 return (top,fname,sub,tag)
459
460 {-
461 importWalletKey db' (top,fname,sub,tag) = do
462 doImportG doDecrypt
463 db'
464 (fmap keykey $ maybeToList wk)
465 tag
466 fname
467 sub
468 -}
469
470 -- db <- foldM importWalletKey db0 ts
313 (db,report) <- return (db0,[]) -- todo 471 (db,report) <- return (db0,[]) -- todo
314 472
315 return ( (db, grip), report ) 473 return ( (db, grip), report )
316 474
475torhash key = maybe "" id $ derToBase32 <$> derRSA key
476
477derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
478
479derRSA rsa = do
480 k <- rsaKeyFromPacket rsa
481 return $ encodeASN1 DER (toASN1 k [])
482
483try :: KikiCondition a -> (a -> IO (KikiCondition b)) -> IO (KikiCondition b)
484try wkun body =
485 case functorToEither wkun of
486 Left e -> return e
487 Right wkun -> body wkun
488
489doImportG
490 :: Ord k =>
491 (Packet -> IO (KikiCondition Packet))
492 -> Map.Map k KeyData
493 -> [k]
494 -> [Char]
495 -> [Char]
496 -> Packet
497 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
498doImportG doDecrypt db m0 tag fname key = do
499 let kk = head m0
500 Just (KeyData top topsigs uids subs) = Map.lookup kk db
501 subkk = keykey key
502 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
503 [])
504 ( (False,) . addOrigin )
505 (Map.lookup subkk subs)
506 where
507 addOrigin (SubKey mp sigs) =
508 let mp' = mp
509 { locations = Map.insert fname
510 (origin (packet mp) (-1))
511 (locations mp) }
512 in SubKey mp' sigs
513 subs' = Map.insert subkk subkey subs
514
515 istor = do
516 guard (tag == "tor")
517 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
518
519 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
520 let has_torid = do
521 -- TODO: check for omitted real name field
522 (sigtrusts,om) <- Map.lookup idstr uids
523 listToMaybe $ do
524 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
525 signatures_over $ verify (Message [packet top]) s
526 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
527 wkun <- doDecrypt (packet top)
528
529 try wkun $ \wkun -> do
530
531 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
532 uid = UserIDPacket idstr
533 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
534 tor_ov = torSigOver (packet top) wkun uid keyflags
535 sig_ov <- pgpSign (Message [wkun])
536 tor_ov
537 SHA1
538 (fingerprint wkun)
539 flip (maybe $ return $ KikiSuccess (uids,[(fname, FailedToMakeSignature)]))
540 (sig_ov >>= listToMaybe . signatures_over)
541 $ \sig -> do
542 let om = Map.singleton fname (origin sig (-1))
543 trust = Map.empty
544 return $ KikiSuccess
545 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
546 , trust)],om) uids
547 , [] )
548
549 try uids' $ \(uids',report) -> do
550
551 let SubKey subkey_p subsigs = subkey
552 wk = packet top
553 (xs',minsig,ys') = findTag tag wk key subsigs
554 doInsert mbsig db = do
555 sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
556 try sig' $ \(sig',report) -> do
557 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
558 let subs' = Map.insert subkk
559 (SubKey subkey_p $ xs'++[sig']++ys')
560 subs
561 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
562 , report )
563
564 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
565 else id
566 s = show (fmap fst minsig,fingerprint key)
567 in return (f report)
568
569 case minsig of
570 Nothing -> doInsert Nothing db -- we need to create a new sig
571 Just (True,sig) -> -- we can deduce is_new == False
572 -- we may need to add a tor id
573 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
574 , report )
575 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
576
577
578
317runKeyRing :: KeyRingData -> (KeyRingRuntime -> a) -> IO (KikiResult a) 579runKeyRing :: KeyRingData -> (KeyRingRuntime -> a) -> IO (KikiResult a)
318runKeyRing keyring op = do 580runKeyRing keyring op = do
319 (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring) 581 (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
@@ -409,6 +671,32 @@ isUserID _ = False
409isTrust (TrustPacket {}) = True 671isTrust (TrustPacket {}) = True
410isTrust _ = False 672isTrust _ = False
411 673
674sigpackets typ hashed unhashed = return $
675 signaturePacket
676 4 -- version
677 typ -- 0x18 subkey binding sig, or 0x19 back-signature
678 RSA
679 SHA1
680 hashed
681 unhashed
682 0 -- Word16 -- Left 16 bits of the signed hash value
683 [] -- [MPI]
684
685secretToPublic pkt@(SecretKeyPacket {}) =
686 PublicKeyPacket { version = version pkt
687 , timestamp = timestamp pkt
688 , key_algorithm = key_algorithm pkt
689 -- , ecc_curve = ecc_curve pkt
690 , key = let seckey = key pkt
691 pubs = public_key_fields (key_algorithm pkt)
692 in filter (\(k,v) -> k `elem` pubs) seckey
693 , is_subkey = is_subkey pkt
694 , v3_days_of_validity = Nothing
695 }
696secretToPublic pkt = pkt
697
698
699
412slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) 700slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
413slurpWIPKeys stamp "" = ([],[]) 701slurpWIPKeys stamp "" = ([],[])
414slurpWIPKeys stamp cs = 702slurpWIPKeys stamp cs =
@@ -465,6 +753,18 @@ decode_btc_key timestamp str = do
465 , is_subkey = True 753 , is_subkey = True
466 } 754 }
467 755
756rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
757rsaKeyFromPacket p@(PublicKeyPacket {}) = do
758 n <- lookup 'n' $ key p
759 e <- lookup 'e' $ key p
760 return $ RSAKey n e
761rsaKeyFromPacket p@(SecretKeyPacket {}) = do
762 n <- lookup 'n' $ key p
763 e <- lookup 'e' $ key p
764 return $ RSAKey n e
765rsaKeyFromPacket _ = Nothing
766
767
468readPacketsFromWallet :: 768readPacketsFromWallet ::
469 Maybe Packet 769 Maybe Packet
470 -> FilePath 770 -> FilePath
@@ -500,6 +800,149 @@ readPacketsFromFile fname = do
500 return $ decode input 800 return $ decode input
501#endif 801#endif
502 802
803now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
804
805signature_time ov = case if null cs then ds else cs of
806 [] -> minBound
807 xs -> last (sort xs)
808 where
809 ps = signatures_over ov
810 ss = filter isSignaturePacket ps
811 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
812 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
813 creationTime (SignatureCreationTimePacket t) = [t]
814 creationTime _ = []
815
816splitAtMinBy comp xs = minimumBy comp' xxs
817 where
818 xxs = zip (inits xs) (tails xs)
819 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
820 compM (Just a) (Just b) = comp a b
821 compM Nothing mb = GT
822 compM _ _ = LT
823
824
825
826findTag tag wk subkey subsigs = (xs',minsig,ys')
827 where
828 vs = map (\sig ->
829 (sig, do
830 sig <- Just (packet . fst $ sig)
831 guard (isSignaturePacket sig)
832 guard $ flip isSuffixOf
833 (fingerprint wk)
834 . maybe "%bad%" id
835 . signature_issuer
836 $ sig
837 listToMaybe $
838 map (signature_time . verify (Message [wk]))
839 (signatures $ Message [wk,subkey,sig])))
840 subsigs
841 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
842 xs' = map fst xs
843 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
844 minsig = do
845 (sig,ov) <- listToMaybe ys
846 ov
847 let hs = filter (\p->isNotation p && notation_name p=="usage@")
848 (hashed_subpackets . packet . fst $ sig)
849 ks = map notation_value hs
850 isNotation (NotationDataPacket {}) = True
851 isNotation _ = False
852 return (tag `elem` ks, sig)
853
854
855makeSig doDecrypt top fname subkey_p tag mbsig = do
856 let wk = packet top
857 wkun <- doDecrypt wk
858 try wkun $ \wkun -> do
859 let grip = fingerprint wk
860 addOrigin new_sig = do
861 flip (maybe $ error "Failed to make signature.")
862 (new_sig >>= listToMaybe . signatures_over)
863 $ \new_sig -> do
864 let mp' = mappedPacket fname new_sig
865 return (mp', Map.empty)
866 parsedkey = [packet $ subkey_p]
867 hashed0 =
868 [ KeyFlagsPacket
869 { certify_keys = False
870 , sign_data = False
871 , encrypt_communication = False
872 , encrypt_storage = False
873 , split_key = False
874 , authentication = True
875 , group_key = False }
876 , NotationDataPacket
877 { human_readable = True
878 , notation_name = "usage@"
879 , notation_value = tag
880 }
881 -- implicitly added:
882 -- , SignatureCreationTimePacket (fromIntegral timestamp)
883 ]
884 subgrip = fingerprint (head parsedkey)
885
886 back_sig <- pgpSign (Message parsedkey)
887 (SubkeySignature wk
888 (head parsedkey)
889 (sigpackets 0x19
890 hashed0
891 [IssuerPacket subgrip]))
892 (if key_algorithm (head parsedkey)==ECDSA
893 then SHA256
894 else SHA1)
895 subgrip
896 let iss = IssuerPacket (fingerprint wk)
897 cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
898 unhashed0 = maybe [iss] cons_iss back_sig
899
900 new_sig <- pgpSign (Message [wkun])
901 (SubkeySignature wk
902 (head parsedkey)
903 (sigpackets 0x18
904 hashed0
905 unhashed0))
906 SHA1
907 grip
908 let newSig = do
909 (k,o) <- addOrigin new_sig
910 return $ KikiSuccess ((k,o),[])
911 flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
912 let sig = packet mp
913 isCreation (SignatureCreationTimePacket {}) = True
914 isCreation _ = False
915 isExpiration (SignatureExpirationTimePacket {}) = True
916 isExpiration _ = False
917 (cs,ps) = partition isCreation (hashed_subpackets sig)
918 (es,qs) = partition isExpiration ps
919 stamp = listToMaybe . sortBy (comparing Down) $
920 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
921 exp = listToMaybe $ sort $
922 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
923 expires = liftA2 (+) stamp exp
924 timestamp <- now
925 if fmap ( (< timestamp) . fromIntegral) expires == Just True then do
926 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
927 else do
928 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
929 $ maybeToList $ do
930 e <- expires
931 return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
932 notation = NotationDataPacket
933 { notation_name = "usage@"
934 , notation_value = tag
935 , human_readable = True }
936 sig' = sig { hashed_subpackets = times ++ [notation] ++ qs }
937 new_sig <- pgpSign (Message [wkun])
938 (SubkeySignature wk
939 (packet subkey_p)
940 [sig'] )
941 SHA1
942 (fingerprint wk)
943 fmap (KikiSuccess . (,[])) $ addOrigin new_sig
944
945
503 946
504data OriginFlags = OriginFlags { 947data OriginFlags = OriginFlags {
505 originallyPublic :: Bool, 948 originallyPublic :: Bool,
@@ -696,6 +1139,30 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
696 mergeSubSig n sig Nothing = error $ 1139 mergeSubSig n sig Nothing = error $
697 "Unable to merge subkey signature: "++(words (show sig) >>= take 1) 1140 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
698 1141
1142unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
1143unsig fname isPublic (sig,trustmap) =
1144 [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
1145 where
1146 f n _ = n==fname -- && trace ("fname=n="++show n) True
1147 asMapped n p = let m = mappedPacket fname p
1148 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
1149
1150concatSort fname getp f = concat . sortByHint fname getp . map f
1151
1152sortByHint fname f = sortBy (comparing gethint)
1153 where
1154 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
1155 defnum = -1
1156
1157flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
1158flattenAllUids fname ispub uids =
1159 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1160
1161flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
1162flattenUid fname ispub (str,(sigs,om)) =
1163 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
1164
1165
699 1166
700{- 1167{-
701data Kiki a = 1168data Kiki a =