summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/KeyRing.hs1316
-rw-r--r--lib/KeyRing/BuildKeyDB.hs1402
-rw-r--r--lib/KeyRing/Types.hs (renamed from lib/Types.hs)59
-rw-r--r--lib/PacketTranscoder.hs2
-rw-r--r--lib/ScanningParser.hs2
-rw-r--r--lib/Transforms.hs45
6 files changed, 387 insertions, 2439 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 244f880..69410ad 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -24,7 +24,7 @@
24{-# LANGUAGE PatternGuards #-} 24{-# LANGUAGE PatternGuards #-}
25{-# LANGUAGE ForeignFunctionInterface #-} 25{-# LANGUAGE ForeignFunctionInterface #-}
26{-# LANGUAGE LambdaCase #-} 26{-# LANGUAGE LambdaCase #-}
27module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) 27module KeyRing (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) where
28 28
29import System.Environment 29import System.Environment
30import Control.Monad 30import Control.Monad
@@ -123,7 +123,7 @@ import FunctorToMaybe
123import DotLock 123import DotLock
124import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) 124import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
125import GnuPGAgent as Agent 125import GnuPGAgent as Agent
126import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB, 126import KeyRing.BuildKeyDB {- (accBindings, backsig, buildKeyDB,
127 combineTransforms, concatSort, 127 combineTransforms, concatSort,
128 derRSA, derToBase32, filterMatches, 128 derRSA, derToBase32, filterMatches,
129 findTag, fingerdress, 129 findTag, fingerdress,
@@ -148,35 +148,13 @@ import KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB,
148 secretToPublic, seek_key, 148 secretToPublic, seek_key,
149 selectKey0, selectPublicKey, 149 selectKey0, selectPublicKey,
150 showPacket, sortByHint, 150 showPacket, sortByHint,
151 subkeyMappedPacket, torhash, try, 151 subkeyMappedPacket, torhash,
152 usage, usageFromFilter, 152 usageFromFilter) -}
153 usageString)
154 153
155import Types 154import KeyRing.Types
156import PacketTranscoder 155import PacketTranscoder
157import Transforms 156import Transforms
158 157
159-- DER-encoded elliptic curve ids
160-- nistp256_id = 0x2a8648ce3d030107
161secp256k1_id :: Integer
162secp256k1_id = 0x2b8104000a
163-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
164{- OID Curve description Curve name
165 ----------------------------------------------------------------
166 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256"
167 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384"
168 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521"
169
170 Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
171 P-521". The hexadecimal representation used in the public and
172 private key encodings are:
173
174 Curve Name Len Hexadecimal representation of the OID
175 ----------------------------------------------------------------
176 "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07
177 "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22
178 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23
179-}
180 158
181data HomeDir = 159data HomeDir =
182 HomeDir { homevar :: String 160 HomeDir { homevar :: String
@@ -191,37 +169,16 @@ home = HomeDir
191 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] 169 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
192 } 170 }
193 171
194spillable :: StreamInfo -> Bool
195spillable (spill -> KF_None) = False
196spillable _ = True
197
198isMutable :: StreamInfo -> Bool 172isMutable :: StreamInfo -> Bool
199isMutable stream | KF_None <- fill stream = False 173isMutable stream | KF_None <- fill stream = False
200isMutable _ = True 174isMutable _ = True
201 175
202isring :: FileType -> Bool
203isring (KeyRingFile {}) = True
204isring _ = False
205
206isSecretKeyFile :: FileType -> Bool
207isSecretKeyFile PEMFile = True
208isSecretKeyFile DNSPresentation = True
209isSecretKeyFile _ = False
210
211{- 176{-
212pwfile :: FileType -> Maybe InputFile 177pwfile :: FileType -> Maybe InputFile
213pwfile (KeyRingFile f) = f 178pwfile (KeyRingFile f) = f
214pwfile _ = Nothing 179pwfile _ = Nothing
215-} 180-}
216 181
217iswallet :: FileType -> Bool
218iswallet (WalletFile {}) = True
219iswallet _ = False
220
221usageFromFilter :: MonadPlus m => KeyFilter -> m String
222usageFromFilter (KF_Match usage) = return usage
223usageFromFilter _ = mzero
224
225 182
226filesToLock :: 183filesToLock ::
227 KeyRingOperation -> InputFileContext -> [FilePath] 184 KeyRingOperation -> InputFileContext -> [FilePath]
@@ -275,76 +232,6 @@ instance ASN1Object PKCS8_RSAPublicKey where
275 fromASN1 _ = 232 fromASN1 _ =
276 Left "fromASN1: RSAPublicKey: unexpected format" 233 Left "fromASN1: RSAPublicKey: unexpected format"
277 234
278{-
279RSAPrivateKey ::= SEQUENCE {
280 version Version,
281 modulus INTEGER, -- n
282 publicExponent INTEGER, -- e
283 privateExponent INTEGER, -- d
284 prime1 INTEGER, -- p
285 prime2 INTEGER, -- q
286 exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1)
287 exponent2 INTEGER, -- d mod (q-1)
288 coefficient INTEGER, -- (inverse of q) mod p
289 otherPrimeInfos OtherPrimeInfos OPTIONAL
290 }
291-}
292data RSAPrivateKey = RSAPrivateKey
293 { rsaN :: MPI
294 , rsaE :: MPI
295 , rsaD :: MPI
296 , rsaP :: MPI
297 , rsaQ :: MPI
298 , rsaDmodP1 :: MPI
299 , rsaDmodQminus1 :: MPI
300 , rsaCoefficient :: MPI
301 }
302 deriving Show
303
304instance ASN1Object RSAPrivateKey where
305 toASN1 rsa@(RSAPrivateKey {})
306 = \xs -> Start Sequence
307 : IntVal 0
308 : mpiVal rsaN
309 : mpiVal rsaE
310 : mpiVal rsaD
311 : mpiVal rsaP
312 : mpiVal rsaQ
313 : mpiVal rsaDmodP1
314 : mpiVal rsaDmodQminus1
315 : mpiVal rsaCoefficient
316 : End Sequence
317 : xs
318 where mpiVal f = IntVal x where MPI x = f rsa
319
320 fromASN1 ( Start Sequence
321 : IntVal _ -- version
322 : IntVal n
323 : IntVal e
324 : IntVal d
325 : IntVal p
326 : IntVal q
327 : IntVal dmodp1
328 : IntVal dmodqminus1
329 : IntVal coefficient
330 : ys) =
331 Right ( privkey, tail $ dropWhile notend ys)
332 where
333 notend (End Sequence) = False
334 notend _ = True
335 privkey = RSAPrivateKey
336 { rsaN = MPI n
337 , rsaE = MPI e
338 , rsaD = MPI d
339 , rsaP = MPI p
340 , rsaQ = MPI q
341 , rsaDmodP1 = MPI dmodp1
342 , rsaDmodQminus1 = MPI dmodqminus1
343 , rsaCoefficient = MPI coefficient
344 }
345 fromASN1 _ =
346 Left "fromASN1: RSAPrivateKey: unexpected format"
347
348 235
349 236
350reportString :: KikiReportAction -> String 237reportString :: KikiReportAction -> String
@@ -369,45 +256,6 @@ x509cert _ = Nothing
369 256
370 257
371 258
372
373matchSpec :: KeySpec -> KeyData -> Bool
374matchSpec (KeyGrip grip) (KeyData p _ _ _)
375 | matchpr grip (packet p)==grip = True
376 | otherwise = False
377
378matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
379 where
380 ps = map (packet .fst) sigs
381 match p = isSignaturePacket p
382 && has_tag tag p
383 && has_issuer key p
384 has_issuer key p = isJust $ do
385 issuer <- signature_issuer p
386 guard $ matchpr issuer key == issuer
387 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
388 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
389
390matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
391 where
392 us = filter (isInfixOf pat) $ Map.keys uids
393
394
395
396
397data KeySpec =
398 KeyGrip String -- fp:
399 | KeyTag Packet String -- fp:????/t:
400 | KeyUidMatch String -- u:
401 deriving Show
402
403data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
404data SingleKeySpec = FingerprintMatch String
405 | SubstringMatch (Maybe MatchingField) String
406 | EmptyMatch
407 | AnyMatch
408 | WorkingKeyMatch
409 deriving (Show,Eq,Ord)
410
411getStr (FingerprintMatch x) = x 259getStr (FingerprintMatch x) = x
412getStr (SubstringMatch _ x) = x 260getStr (SubstringMatch _ x) = x
413getStr _ = "" 261getStr _ = ""
@@ -431,25 +279,6 @@ getStr _ = ""
431-- (Any of the fields may be left empty.) 279-- (Any of the fields may be left empty.)
432type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec) 280type Spec = (SingleKeySpec,SingleKeySpec,SingleKeySpec)
433 281
434parseSingleSpec :: String -> SingleKeySpec
435parseSingleSpec "*" = AnyMatch
436parseSingleSpec "-" = WorkingKeyMatch
437parseSingleSpec "" = EmptyMatch
438parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag
439parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag
440parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag
441parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
442parseSingleSpec str
443 | is40digitHex str = FingerprintMatch str
444 | otherwise = SubstringMatch Nothing str
445
446is40digitHex xs = ys == xs && length ys==40
447 where
448 ys = filter ishex xs
449 ishex c | '0' <= c && c <= '9' = True
450 | 'A' <= c && c <= 'F' = True
451 | 'a' <= c && c <= 'f' = True
452 ishex c = False
453 282
454data SpecError = SpecENone String 283data SpecError = SpecENone String
455 | SpecEMissMatch String (Maybe MatchingField) MatchingField 284 | SpecEMissMatch String (Maybe MatchingField) MatchingField
@@ -574,43 +403,6 @@ wordsBy c xs = let (b,a) = span (/=c) xs
574 in b:wordsBy c (drop 1 a) 403 in b:wordsBy c (drop 1 a)
575 404
576 405
577
578-- | Parse a key specification.
579-- The first argument is a grip for the default working key.
580parseSpec :: String -> String -> (KeySpec,Maybe String)
581parseSpec wkgrip spec =
582 if not slashed
583 then
584 case prespec of
585 AnyMatch -> (KeyGrip "", Nothing)
586 EmptyMatch -> error "Bad key spec."
587 WorkingKeyMatch -> (KeyGrip wkgrip, Nothing)
588 SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
589 SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str)
590 SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
591 FingerprintMatch fp -> (KeyGrip fp, Nothing)
592 else
593 case (prespec,postspec) of
594 (FingerprintMatch fp, SubstringMatch st t)
595 | st /= Just UserIDField -> (KeyGrip fp, Just t)
596 (SubstringMatch mt u, _)
597 | postspec `elem` [AnyMatch,EmptyMatch]
598 && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing)
599 (SubstringMatch mt u, SubstringMatch st t)
600 | mt /= Just KeyTypeField
601 && st /= Just UserIDField -> (KeyUidMatch u, Just t)
602 (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
603 (_,FingerprintMatch fp) -> error "todo: support /fp: spec"
604 (FingerprintMatch fp,_) -> error "todo: support fp:/ spec"
605 _ -> error "Bad key spec."
606 where
607 (preslash,slashon) = break (=='/') spec
608 slashed = not $ null $ take 1 slashon
609 postslash = drop 1 slashon
610
611 prespec = parseSingleSpec preslash
612 postspec = parseSingleSpec postslash
613
614{- 406{-
615 - BUGGY 407 - BUGGY
616parseSpec grip spec = (topspec,subspec) 408parseSpec grip spec = (topspec,subspec)
@@ -653,9 +445,6 @@ parseSpec grip spec = (topspec,subspec)
653-} 445-}
654 446
655 447
656filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
657filterMatches spec ks = filter (matchSpec spec . snd) ks
658
659filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData 448filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
660filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' 449filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
661 where 450 where
@@ -686,9 +475,6 @@ filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
686selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 475selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
687selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db 476selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
688 477
689selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
690selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
691
692selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])] 478selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
693selectPublicKeyAndSigs (spec,mtag) db = 479selectPublicKeyAndSigs (spec,mtag) db =
694 case mtag of 480 case mtag of
@@ -717,15 +503,6 @@ selectPublicKeyAndSigs (spec,mtag) db =
717 guard hastag 503 guard hastag
718 return $ (kk, packet sub, map (packet . fst) sigs) 504 return $ (kk, packet sub, map (packet . fst) sigs)
719 505
720selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
721selectKey0 wantPublic (spec,mtag) db = do
722 let Message ps = flattenKeys wantPublic db
723 ys = snd $ seek_key spec ps
724 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
725 case ys of
726 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
727 [] -> Nothing
728
729{- 506{-
730selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] 507selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
731selectAll wantPublic (spec,mtag) db = do 508selectAll wantPublic (spec,mtag) db = do
@@ -742,50 +519,6 @@ selectAll wantPublic (spec,mtag) db = do
742 in search (drop 1 ys) 519 in search (drop 1 ys)
743-} 520-}
744 521
745seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
746seek_key (KeyGrip grip) sec = (pre, subs)
747 where
748 (pre,subs) = break pred sec
749 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
750 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
751 pred _ = False
752
753seek_key (KeyTag key tag) ps
754 | null bs = (ps, [])
755 | null qs =
756 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
757 (as ++ (head bs : as'), bs')
758 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
759 where
760 (as,bs) = break (\p -> isSignaturePacket p
761 && has_tag tag p
762 && isJust (signature_issuer p)
763 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
764 ps
765 (rs,qs) = break isKey (reverse as)
766
767 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
768 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
769
770seek_key (KeyUidMatch pat) ps
771 | null bs = (ps, [])
772 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
773 (as ++ (head bs : as'), bs')
774 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
775 where
776 (as,bs) = break (isInfixOf pat . uidStr) ps
777 (rs,qs) = break isKey (reverse as)
778
779 uidStr (UserIDPacket s) = s
780 uidStr _ = ""
781
782
783readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
784readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents
785readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
786readInputFileL ctx inp = do
787 let fname = resolveInputFile ctx inp
788 fmap L.concat $ mapM L.readFile fname
789 522
790 523
791writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) 524writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs)
@@ -829,20 +562,6 @@ writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeF
829writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () 562writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
830writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str 563writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str
831 564
832getInputFileTime :: InputFileContext -> InputFile -> IO CTime
833getInputFileTime ctx (Pipe fdr fdw) = do
834 mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
835 maybe tryw return mt
836 where
837 tryw = do
838 handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?")
839 $ modificationTime <$> getFdStatus fdw
840getInputFileTime ctx (FileDesc fd) = do
841 handleIO_ (error $ "&"++show fd++": modificaiton time?") $
842 modificationTime <$> getFdStatus fd
843getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
844 handleIO_ (error $ fname++": modificaiton time?") $
845 modificationTime <$> getFileStatus fname
846 565
847{- 566{-
848 - This may be useful later. Commented for now as it is not used. 567 - This may be useful later. Commented for now as it is not used.
@@ -855,104 +574,8 @@ doesInputFileExist ctx f = do
855-} 574-}
856 575
857 576
858generateSubkey ::
859 PacketTranscoder
860 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
861 -> (GenerateKeyParams, StreamInfo)
862 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
863generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
864 try kd' $ \(kd,report0) -> do
865 let subs = do
866 SubKey p sigs <- Map.elems $ keySubKeys kd
867 filter (has_tag tag) $ map (packet . fst) sigs
868 if null subs
869 then do
870 newkey <- generateKey genparam
871 kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
872 try kdr $ \(newkd,report) -> do
873 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
874 else do
875 return $ KikiSuccess (kd,report0)
876generateSubkey _ kd _ = return kd
877
878importSecretKey ::
879 (PacketTranscoder)
880 -> KikiCondition
881 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
882 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
883 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
884importSecretKey transcode db' tup = do
885 try db' $ \(db',report0) -> do
886 r <- doImport transcode
887 db'
888 tup
889 try r $ \(db'',report) -> do
890 return $ KikiSuccess (db'', report0 ++ report)
891
892
893mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
894 -> IO
895 (KikiCondition
896 ( ( Map.Map [Char8.ByteString] KeyData
897 , ( [Hosts.Hosts]
898 , [Hosts.Hosts]
899 , Hosts.Hosts
900 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
901 , [SockAddr]))
902 , [(FilePath,KikiReportAction)]))
903mergeHostFiles krd db ctx = do
904 let hns = files ishosts
905 ishosts Hosts = True
906 ishosts _ = False
907 files istyp = do
908 (f,stream) <- Map.toList (opFiles krd)
909 guard (istyp $ typ stream)
910 return f
911 577
912 readInputFileL' ctx f =
913 readInputFileL ctx f
914 `catch` \e -> do when (not $ isDoesNotExistError e) $ do
915 return () -- todo report problem
916 return L.empty
917 578
918 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
919
920 let gpgnames = map getHostnames $ Map.elems db
921 os = do
922 (addr,(ns,_)) <- gpgnames
923 n <- ns
924 return (addr,n)
925 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
926 -- we ensure .onion names are set properly
927 hostdbs = map setOnions hostdbs0
928 outgoing_names = do
929 (addr,(_,gns)) <- gpgnames
930 guard . not $ null gns
931 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
932 return addr
933 -- putStrLn $ "hostdbs = " ++ show hostdbs
934
935 -- 1. let U = union all the host dbs
936 -- preserving whitespace and comments of the first
937 let u0 = foldl' Hosts.plus Hosts.empty hostdbs
938 -- we filter U to be only finger-dresses
939 u1 = Hosts.filterAddrs (hasFingerDress db) u0
940
941 -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
942 {-
943 putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}"
944 putStrLn $ "--> " ++ show (nf (head hostdbs))
945 putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
946 putStrLn $ "--> " ++ show (nf u0)
947 putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
948 putStrLn $ "--> " ++ show (nf u1)
949 -}
950
951 -- 2. replace gpg annotations with those in U
952 -- forM use_db
953 db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
954
955 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
956 579
957writeHostsFiles 580writeHostsFiles
958 :: KeyRingOperation -> InputFileContext 581 :: KeyRingOperation -> InputFileContext
@@ -991,197 +614,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
991 return $ map (first $ resolveForReport $ Just ctx) rs 614 return $ map (first $ resolveForReport $ Just ctx) rs
992 return $ concat rss 615 return $ concat rss
993 616
994-- | buildKeyDB
995--
996-- merge all keyrings, PEM files, and wallets into process memory.
997--
998buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
999 -> IO (KikiCondition (({- db -} KeyDB
1000 ,{- grip -} Maybe String
1001 ,{- wk -} Maybe MappedPacket
1002 ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts],
1003 {- hostdbs -}[Hosts.Hosts],
1004 {- u1 -}Hosts.Hosts,
1005 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
1006 {- outgoing_names -}[SockAddr])
1007 ,{- accs -} Map.Map InputFile Access
1008 ,{- doDecrypt -} PacketTranscoder
1009 ,{- unspilled -} Map.Map InputFile Message
1010 )
1011 ,{- report_imports -} [(FilePath,KikiReportAction)]))
1012buildKeyDB ctx grip0 keyring = do
1013 let files istyp = do
1014 (f,stream) <- Map.toList (opFiles keyring)
1015 guard (istyp $ typ stream)
1016 return f -- resolveInputFile ctx f
1017 617
1018 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
1019 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
1020 where
1021 isgen (Generate _ _) _ = True
1022 isgen _ _ = False
1023
1024 readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message)
1025 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
1026 where
1027 readp0 ps = (stream { access = acc' }, ps)
1028 where acc' = case access stream of
1029 AutoAccess ->
1030 case ps of
1031 Message ((PublicKeyPacket {}):_) -> Pub
1032 Message ((SecretKeyPacket {}):_) -> Sec
1033 _ -> AutoAccess
1034 acc -> acc
1035
1036 readw wk n = fmap (n,) (readPacketsFromWallet wk n)
1037
1038 -- KeyRings (todo: KikiCondition reporting?)
1039 (spilled,mwk,grip,accs,keyqs,unspilled) <- do
1040#if MIN_VERSION_containers(0,5,0)
1041 ringPackets <- Map.traverseWithKey readp ringMap
1042#else
1043 ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
1044#endif
1045 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
1046
1047 let grip = grip0 `mplus` (fingerprint <$> fstkey)
1048 where
1049 fstkey = do
1050 (_,Message ps) <- Map.lookup HomeSec ringPackets
1051 listToMaybe ps
1052
1053 -- | spilled
1054 -- ring packets with info available for export
1055 -- | unspilled
1056 -- the rest
1057 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
1058
1059 -- | keys
1060 -- process ringPackets, and get a map of fingerprint info to
1061 -- to a packet, remembering it's original file, access.
1062 keys :: Map.Map KeyKey (OriginMapped Query)
1063 mwk :: Maybe MappedPacket
1064 (mwk, keys) = keyQueries grip ringPackets
1065
1066 -- | accs
1067 -- file access(Sec | Pub) lookup table
1068 accs :: Map.Map InputFile Access
1069 accs = fmap (access . fst) ringPackets
1070 return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
1071
1072 transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
1073 let doDecrypt = transcode (Unencrypted,S2K 100 "")
1074
1075 let wk = fmap packet mwk
1076 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
1077 , rtSecring = homesecPath ctx
1078 , rtGrip = grip
1079 , rtWorkingKey = wk
1080 , rtRingAccess = accs
1081 , rtKeyDB = Map.empty
1082 , rtPassphrases = transcode
1083 }
1084 -- autosigns and deletes
1085 transformed0 <-
1086 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
1087 trans f (info,ps) = do
1088 let manip = combineTransforms (transforms info)
1089 rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
1090 acc = Just Sec /= Map.lookup f accs
1091 r <- performManipulations doDecrypt rt1 mwk manip
1092 try r $ \(rt2,report) -> do
1093 return $ KikiSuccess (report,rtKeyDB rt2)
1094 -- XXX: Unspilled keys are not obtainable from rtKeyDB.
1095 -- If the working key is marked non spillable, then how
1096 -- would we look up it's UID and such?
1097#if MIN_VERSION_containers(0,5,0)
1098 in fmap sequenceA $ Map.traverseWithKey trans spilled
1099#else
1100 in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
1101#endif
1102 try transformed0 $ \transformed -> do
1103 let -- | db_rings - all keyrings combined into one
1104 db_rings :: Map.Map KeyKey KeyData
1105 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
1106 where
1107 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans
1108 -- | reportTrans
1109 -- events, indexed by file
1110 reportTrans :: [(FilePath, KikiReportAction)]
1111 reportTrans = concat $ Map.elems $ fmap fst transformed
1112
1113 -- Wallets
1114 let importWalletKey wk db' (top,fname,sub,tag) = do
1115 try db' $ \(db',report0) -> do
1116 r <- doImportG transcode
1117 db'
1118 (fmap keykey $ maybeToList wk)
1119 [mkUsage tag]
1120 fname
1121 sub
1122 try r $ \(db'',report) -> do
1123 return $ KikiSuccess (db'', report0 ++ report)
1124
1125 wms <- mapM (readw wk) (files iswallet)
1126 let wallet_keys = do
1127 maybeToList wk
1128 (fname,xs) <- wms
1129 (_,sub,(_,m)) <- xs
1130 (tag,top) <- Map.toList m
1131 return (top,fname,sub,tag)
1132
1133 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
1134 try db $ \(db,reportWallets) -> do
1135
1136 -- PEM files
1137 let pems = do
1138 (n,stream) <- Map.toList $ opFiles keyring
1139 grip <- maybeToList grip
1140 guard $ spillable stream && isSecretKeyFile (typ stream)
1141 let us = mapMaybe usageFromFilter [fill stream,spill stream]
1142 usage <- take 1 us
1143 guard $ all (==usage) $ drop 1 us
1144 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
1145 -- TODO: parseSpec3
1146 let (topspec,subspec) = parseSpec grip usage
1147 ms = map fst $ filterMatches topspec (Map.toList db)
1148 cmd = initializer stream
1149 return (n,subspec,ms,stream, cmd)
1150
1151 imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
1152 _ -> return True)
1153 pems
1154 db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
1155 try db $ \(db,reportPEMs) -> do
1156
1157 -- generate keys
1158 let gens = mapMaybe g $ Map.toList genMap
1159 where g (Generate _ params,v) = Just (params,v)
1160 g _ = Nothing
1161
1162 db <- generateInternals transcode mwk db gens
1163 try db $ \(db,reportGens) -> do
1164
1165 r <- mergeHostFiles keyring db ctx
1166 try r $ \((db,hs),reportHosts) -> do
1167
1168 return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled)
1169 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
1170
1171generateInternals ::
1172 PacketTranscoder
1173 -> Maybe MappedPacket
1174 -> Map.Map KeyKey KeyData
1175 -> [(GenerateKeyParams,StreamInfo)]
1176 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1177generateInternals transcode mwk db gens = do
1178 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
1179 Just kd0 -> do
1180 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
1181 try kd $ \(kd,reportGens) -> do
1182 let kk = keykey $ packet $ fromJust mwk
1183 return $ KikiSuccess (Map.insert kk kd db,reportGens)
1184 Nothing -> return $ KikiSuccess (db,[])
1185 618
1186unconditionally :: IO (KikiCondition a) -> IO a 619unconditionally :: IO (KikiCondition a) -> IO a
1187unconditionally action = do 620unconditionally action = do
@@ -1190,69 +623,9 @@ unconditionally action = do
1190 KikiSuccess x -> return x 623 KikiSuccess x -> return x
1191 e -> error $ errorString e 624 e -> error $ errorString e
1192 625
1193data ParsedCert = ParsedCert
1194 { pcertKey :: Packet
1195 , pcertTimestamp :: UTCTime
1196 , pcertBlob :: L.ByteString
1197 }
1198 deriving (Show,Eq)
1199data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
1200 deriving (Show,Eq)
1201
1202spemPacket (PEMPacket p) = Just p
1203spemPacket _ = Nothing
1204
1205spemCert (PEMCertificate p) = Just p
1206spemCert _ = Nothing
1207
1208toStrict :: L.ByteString -> S.ByteString
1209toStrict = foldr1 (<>) . L.toChunks
1210 626
1211-- No instance for (ASN1Object RSA.PublicKey) 627-- No instance for (ASN1Object RSA.PublicKey)
1212 628
1213parseCertBlob comp bs = do
1214 asn1 <- either (const Nothing) Just
1215 $ decodeASN1 DER bs
1216 let asn1' = drop 2 asn1
1217 cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
1218 let _ = cert :: X509.Certificate
1219 notBefore :: UTCTime
1220#if MIN_VERSION_x509(1,5,0)
1221 notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
1222 where (vincentTime,_) = X509.certValidity cert
1223#else
1224 (notBefore,_) = X509.certValidity cert
1225#endif
1226 case X509.certPubKey cert of
1227 X509.PubKeyRSA key -> do
1228 let withoutkey =
1229 let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
1230 (pre,post) = S.breakSubstring ekey $ toStrict bs
1231 post' = S.drop (S.length ekey) post
1232 len :: Word16
1233 len = if S.null post then maxBound
1234 else fromIntegral $ S.length pre
1235 in if len < 4096
1236 then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
1237 else bs
1238 return
1239 ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
1240 (MPI $ RSA.public_n key)
1241 (MPI $ RSA.public_e key)
1242 , pcertTimestamp = notBefore
1243 , pcertBlob = if comp then withoutkey
1244 else bs
1245 }
1246 _ -> Nothing
1247
1248packetFromPublicRSAKey notBefore n e =
1249 PublicKeyPacket { version = 4
1250 , timestamp = round $ utcTimeToPOSIXSeconds notBefore
1251 , key_algorithm = RSA
1252 , key = [('n',n),('e',e)]
1253 , is_subkey = True
1254 , v3_days_of_validity = Nothing
1255 }
1256 629
1257decodeBlob cert = 630decodeBlob cert =
1258 if 0 /= (bs `L.index` 0) .&. 0x10 631 if 0 /= (bs `L.index` 0) .&. 0x10
@@ -1267,271 +640,9 @@ decodeBlob cert =
1267 bs = pcertBlob cert 640 bs = pcertBlob cert
1268 key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert 641 key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
1269 642
1270extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
1271extractRSAKeyFields kvs = do
1272 let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs
1273 n <- lookup "Modulus" kvs'
1274 e <- lookup "PublicExponent" kvs'
1275 d <- lookup "PrivateExponent" kvs'
1276 p <- lookup "Prime1" kvs' -- p
1277 q <- lookup "Prime2" kvs' -- q
1278 dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
1279 dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
1280 u <- lookup "Coefficient" kvs'
1281 {-
1282 case (d,p,dmodp1) of
1283 (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
1284 _ -> error "dmodp fail!"
1285 case (d,q,dmodqminus1) of
1286 (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
1287 _ -> error "dmodq fail!"
1288 -}
1289 return $ RSAPrivateKey
1290 { rsaN = n
1291 , rsaE = e
1292 , rsaD = d
1293 , rsaP = p
1294 , rsaQ = q
1295 , rsaDmodP1 = dmodp1
1296 , rsaDmodQminus1 = dmodqminus1
1297 , rsaCoefficient = u }
1298 where
1299 parseField blob = MPI <$> m
1300#if defined(VERSION_memory)
1301 where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob)
1302 bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1303 where
1304 nlen = S.length bs
1305#elif defined(VERSION_dataenc)
1306 where m = bigendian <$> Base64.decode (Char8.unpack blob)
1307 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1308 where
1309 nlen = length bs
1310#endif
1311 643
1312 644
1313rsaToPGP stamp rsa = SecretKeyPacket 645
1314 { version = 4
1315 , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
1316 , key_algorithm = RSA
1317 , key = [ -- public fields...
1318 ('n',rsaN rsa)
1319 ,('e',rsaE rsa)
1320 -- secret fields
1321 ,('d',rsaD rsa)
1322 ,('p',rsaQ rsa) -- Note: p & q swapped
1323 ,('q',rsaP rsa) -- Note: p & q swapped
1324 ,('u',rsaCoefficient rsa)
1325 ]
1326 -- , ecc_curve = def
1327 , s2k_useage = 0
1328 , s2k = S2K 100 ""
1329 , symmetric_algorithm = Unencrypted
1330 , encrypted_data = ""
1331 , is_subkey = True
1332 }
1333
1334readSecretDNSFile :: InputFile -> IO Packet
1335readSecretDNSFile fname = do
1336 let ctx = InputFileContext "" ""
1337 stamp <- getInputFileTime ctx fname
1338 input <- readInputFileL ctx fname
1339 let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
1340 . Char8.break (==':'))
1341 $ Char8.lines input
1342 alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
1343 parseAlg spec = case Char8.words spec of
1344 nstr:_ -> case read (Char8.unpack nstr) :: Int of
1345 2 -> DH
1346 3 -> DSA -- SHA1
1347 5 -> RSA -- SHA1
1348 6 -> DSA -- NSEC3-SHA1 (RFC5155)
1349 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
1350 8 -> RSA -- SHA256
1351 10 -> RSA -- SHA512 (RFC5702)
1352 -- 12 -> GOST
1353 13 -> ECDSA -- P-256 SHA256 (RFC6605)
1354 14 -> ECDSA -- P-384 SHA384 (RFC6605)
1355 _ -> RSA
1356 case alg of
1357 RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
1358
1359
1360readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1361readSecretPEMFile fname = do
1362 -- warn $ fname ++ ": reading ..."
1363 let ctx = InputFileContext "" ""
1364 -- Note: The key's timestamp is included in it's fingerprint.
1365 -- Therefore, we should attempt to preserve it.
1366 stamp <- getInputFileTime ctx fname
1367 input <- readInputFileL ctx fname
1368 let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
1369 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1370 $ pemParser $ Just "RSA PRIVATE KEY"
1371 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1372 $ pemParser $ Just "CERTIFICATE"
1373 parseRSAPrivateKey dta = do
1374 let e = decodeASN1 DER dta
1375 asn1 <- either (const $ mzero) return e
1376 rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
1377 let _ = rsa :: RSAPrivateKey
1378 return $ PEMPacket $ rsaToPGP stamp rsa
1379 dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
1380 mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
1381 mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
1382 where key' = if tm < fromTime (timestamp key)
1383 then key { timestamp = fromTime tm }
1384 else key
1385 mergeDate (tm,_) (Right mb) = (tm,mb)
1386 return $ dta
1387
1388doImport
1389 :: PacketTranscoder
1390 -> Map.Map KeyKey KeyData
1391 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
1392 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1393doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
1394 flip (maybe $ return CannotImportMasterKey)
1395 subspec $ \tag -> do
1396 (certs,keys) <- case typ of
1397 PEMFile -> do
1398 ps <- readSecretPEMFile fname
1399 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1400 = partition (isJust . spemCert) ps
1401 return (certs,keys)
1402 DNSPresentation -> do
1403 p <- readSecretDNSFile fname
1404 return ([],[p])
1405 -- TODO Probably we need to move to a new design where signature
1406 -- packets are merged into the database in one phase with null
1407 -- signatures, and then the signatures are made in the next phase.
1408 -- This would let us merge annotations (like certificates) from
1409 -- seperate files.
1410 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1411 where
1412 importKey tag certs prior key = do
1413 try prior $ \(db,report) -> do
1414 let (m0,tailms) = splitAt 1 ms
1415 if (not (null tailms) || null m0)
1416 then return $ AmbiguousKeySpec (resolveForReport Nothing fname)
1417 else do
1418 let kk = keykey key
1419 cs = filter (\c -> kk==keykey (pcertKey c)) certs
1420 blobs = map mkCertNotation $ nub $ map pcertBlob cs
1421 mkCertNotation bs = NotationDataPacket
1422 { human_readable = False
1423 , notation_name = "x509cert@"
1424 , notation_value = Char8.unpack bs }
1425 datedKey = key { timestamp = fromTime $ minimum dates }
1426 dates = fromTime (timestamp key) : map pcertTimestamp certs
1427 r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey
1428 try r $ \(db',report') -> do
1429 return $ KikiSuccess (db',report++report')
1430
1431doImportG
1432 :: PacketTranscoder
1433 -> Map.Map KeyKey KeyData
1434 -> [KeyKey] -- m0, only head is used
1435 -> [SignatureSubpacket] -- tags
1436 -> InputFile
1437 -> Packet
1438 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1439doImportG transcode db m0 tags fname key = do
1440 let kk = head m0
1441 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
1442 kdr <- insertSubkey transcode kk kd tags fname key
1443 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
1444
1445insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
1446 let topcipher = symmetric_algorithm $ packet top
1447 tops2k = s2k $ packet top
1448 doDecrypt = transcode (Unencrypted,S2K 100 "")
1449 fname = resolveForReport Nothing inputfile
1450 subkk = keykey key0
1451 istor = do
1452 guard ("tor" `elem` mapMaybe usage tags)
1453 return $ torUIDFromKey key0
1454 addOrigin (SubKey mp sigs) =
1455 let mp' = mp
1456 { locations = Map.insert fname
1457 (origin (packet mp) (-1))
1458 (locations mp) }
1459 in SubKey mp' sigs
1460
1461 subkey_result <- do
1462 case Map.lookup subkk subs of
1463 Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing)
1464 Nothing -> do
1465 wkun' <- doDecrypt top
1466 try wkun' $ \wkun -> do
1467 key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
1468 try key' $ \key -> do
1469 return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key))
1470
1471
1472 try subkey_result $ \(is_new,subkey,decrypted) -> do
1473
1474 let subs' = Map.insert subkk subkey subs
1475
1476 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
1477 let has_torid = do
1478 -- TODO: check for omitted real name field
1479 (sigtrusts,om) <- Map.lookup idstr uids
1480 listToMaybe $ do
1481 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
1482 signatures_over $ verify (Message [packet top]) s
1483 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
1484
1485 let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids)
1486 uid = UserIDPacket idstr
1487 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1488 tor_ov = makeInducerSig (packet top) (packet top) uid keyflags
1489 wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted
1490 try wkun' $ \wkun -> do
1491 sig_ov <- pgpSign (Message [wkun])
1492 tor_ov
1493 SHA1
1494 (fingerprint wkun)
1495 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
1496 (sig_ov >>= listToMaybe . signatures_over)
1497 $ \sig -> do
1498 let om = Map.singleton fname (origin sig (-1))
1499 trust = Map.empty
1500 return $ KikiSuccess
1501 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1502 , trust)],om) uids
1503 , [] )
1504
1505 try uids' $ \(uids',report) -> do
1506
1507 let SubKey subkey_p subsigs = subkey
1508 wk = packet top
1509 (xs',minsig,ys') = findTag tags wk key0 subsigs
1510 doInsert mbsig = do
1511 -- NEW SUBKEY BINDING SIGNATURE
1512 -- XXX: Here I assume that key0 is the unencrypted version
1513 -- of subkey_p. TODO: Check this assumption.
1514 sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig
1515 try sig' $ \(sig',report) -> do
1516 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
1517 let subs' = Map.insert subkk
1518 (SubKey subkey_p $ xs'++[sig']++ys')
1519 subs
1520 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1521 , report )
1522
1523 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
1524 else id
1525 s = show (fmap fst minsig,fingerprint key0)
1526 in return (f report)
1527
1528 case minsig of
1529 Nothing -> doInsert Nothing -- we need to create a new sig
1530 Just (True,sig) -> -- we can deduce is_new == False
1531 -- we may need to add a tor id
1532 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1533 , report )
1534 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
1535 646
1536isCryptoCoinKey :: Packet -> Bool 647isCryptoCoinKey :: Packet -> Bool
1537isCryptoCoinKey p = 648isCryptoCoinKey p =
@@ -2004,18 +1115,6 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
2004 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs 1115 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
2005 ++ import_rs ++ internals_rs) 1116 ++ import_rs ++ internals_rs)
2006 1117
2007-- | combineTransforms
2008-- remove rundant transforms, and compile the rest to PacketUpdate(s)
2009--
2010-- eqivalent to:
2011-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd
2012combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2013combineTransforms trans rt kd = updates
2014 where
2015 updates = -- kManip operation rt kd ++
2016 concatMap (\t -> resolveTransform t rt kd) sanitized
2017 sanitized = group (sort trans) >>= take 1
2018
2019 1118
2020 1119
2021-- | Load and update key files according to the specified 'KeyRingOperation'. 1120-- | Load and update key files according to the specified 'KeyRingOperation'.
@@ -2160,128 +1259,10 @@ lookupEnv var =
2160 handleIO_ (return Nothing) $ fmap Just (getEnv var) 1259 handleIO_ (return Nothing) $ fmap Just (getEnv var)
2161#endif 1260#endif
2162 1261
2163slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
2164slurpWIPKeys stamp "" = ([],[])
2165slurpWIPKeys stamp cs =
2166 let (b58,xs) = Char8.span (`elem` base58chars) cs
2167 mb = decode_btc_key stamp (Char8.unpack b58)
2168 in if L.null b58
2169 then let (ys,xs') = Char8.break (`elem` base58chars) cs
2170 (ks,js) = slurpWIPKeys stamp xs'
2171 in (ks,ys:js)
2172 else let (ks,js) = slurpWIPKeys stamp xs
2173 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
2174
2175
2176decode_btc_key ::
2177 Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
2178decode_btc_key timestamp str = do
2179 (network_id,us) <- base58_decode str
2180 return . (network_id,) $ Message $ do
2181 let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
2182 {-
2183 xy = secp256k1_G `pmul` d
2184 x = getx xy
2185 y = gety xy
2186 -- y² = x³ + 7 (mod p)
2187 y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
2188 y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
2189 -}
2190 secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
2191 ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
2192 -- pub = cannonical_eckey x y
2193 -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub
2194 -- address = base58_encode hash
2195 -- pubstr = concatMap (printf "%02x") $ pub
2196 -- _ = pubstr :: String
2197 return $ {- trace (unlines ["pub="++show pubstr
2198 ,"add="++show address
2199 ,"y ="++show y
2200 ,"y' ="++show y'
2201 ,"y''="++show y'']) -}
2202 SecretKeyPacket
2203 { version = 4
2204 , timestamp = toEnum (fromEnum timestamp)
2205 , key_algorithm = ECDSA
2206 , key = [ -- public fields...
2207 ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
2208 ,('l',MPI 256)
2209 ,('x',MPI x)
2210 ,('y',MPI y)
2211 -- secret fields
2212 ,('d',MPI d)
2213 ]
2214 , s2k_useage = 0
2215 , s2k = S2K 100 ""
2216 , symmetric_algorithm = Unencrypted
2217 , encrypted_data = ""
2218 , is_subkey = True
2219 }
2220
2221
2222readPacketsFromWallet ::
2223 Maybe Packet
2224 -> InputFile
2225 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
2226readPacketsFromWallet wk fname = do
2227 let ctx = InputFileContext "" ""
2228 timestamp <- getInputFileTime ctx fname
2229 input <- readInputFileL ctx fname
2230 let (ks,_) = slurpWIPKeys timestamp input
2231 {-
2232 unless (null ks) $ do
2233 -- decrypt wk
2234 -- create sigs
2235 -- return key/sig pairs
2236 return () -}
2237 return $ do
2238 wk <- maybeToList wk
2239 guard (not $ null ks)
2240 let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
2241 where tag = CryptoCoins.nameFromSecretByte tagbyte
2242 (wk,MarkerPacket,(MarkerPacket,Map.empty))
2243 :map prep ks
2244
2245readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
2246readPacketsFromFile ctx fname = do
2247 -- warn $ fname ++ ": reading..."
2248 input <- readInputFileL ctx fname
2249#if MIN_VERSION_binary(0,7,0)
2250 return $
2251 case decodeOrFail input of
2252 Right (_,_,msg ) -> msg
2253 Left (_,_,_) ->
2254 -- FIXME
2255 -- trace (fname++": read fail") $
2256 Message []
2257#else
2258 return $ decode input
2259#endif
2260
2261 1262
2262merge :: KeyDB -> InputFile -> Message -> KeyDB
2263merge db inputfile (Message ps) = merge_ db filename qs
2264 where
2265 filename = resolveForReport Nothing inputfile
2266 1263
2267 qs = scanPackets filename ps
2268 1264
2269 scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
2270 scanPackets filename [] = []
2271 scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
2272 where
2273 ret p = (p,Map.empty)
2274 doit (top,sub,prev) p =
2275 case p of
2276 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
2277 _ | isKey p && is_subkey p -> (top,p,ret p)
2278 _ | isUserID p -> (top,p,ret p)
2279 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
2280 _ -> (top,sub,ret p)
2281 1265
2282 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
2283 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
2284 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
2285 1266
2286 1267
2287{- 1268{-
@@ -2292,296 +1273,11 @@ onionName kd = (addr,name)
2292-} 1273-}
2293 1274
2294 1275
2295merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
2296 -> KeyDB
2297merge_ db filename qs = foldl mergeit db (zip [0..] qs)
2298 where
2299 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
2300 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
2301 mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
2302 where
2303 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
2304 update (Just kd) = dbInsertPacket kd filename adding
2305 mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
2306
2307 whatP (a,_) = concat . take 1 . words . show $ a
2308
2309
2310
2311mergeKeyData :: KeyData -> KeyData -> KeyData
2312mergeKeyData (KeyData atop asigs auids asubs)
2313 (KeyData btop bsigs buids bsubs)
2314 = KeyData top sigs uids subs
2315 where
2316 mergeMapped a b =
2317 MappedPacket { packet = packet a
2318 , locations = Map.union (locations a) (locations b)
2319 }
2320
2321 top = mergeMapped atop btop
2322
2323 sigs = foldl' (flip mergeSig) asigs bsigs
2324 1276
2325 uids = Map.unionWith mergeUIDSigs auids buids
2326 subs = Map.unionWith mergeSub asubs bsubs
2327 1277
2328 mergeSub :: SubKey -> SubKey -> SubKey
2329 mergeSub (SubKey a as) (SubKey b bs) =
2330 SubKey (mergeMapped a b)
2331 (foldl' (flip mergeSig) as bs)
2332 1278
2333 mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
2334 -> ([SigAndTrust],OriginMap)
2335 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)
2336 1279
2337 1280
2338dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
2339dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
2340 where
2341 asMapped n p = mappedPacketWithHint filename p n
2342 asSigAndTrust n (p,tm) = (asMapped n p,tm)
2343
2344 -- NOTE:
2345 -- if a keyring file has both a public key packet and a secret key packet
2346 -- for the same key, then only one of them will survive, which ever is
2347 -- later in the file.
2348 --
2349 -- This is due to the use of statements like
2350 -- (Map.insert filename (origin p n) (locations key))
2351 --
2352 update :: Maybe KeyData -> Maybe KeyData
2353 update v | isKey p && not (is_subkey p)
2354 = case v of
2355 Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty
2356 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
2357 -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
2358 sigs
2359 uids
2360 subkeys
2361 _ -> error . concat $ ["Unexpected master key merge error: "
2362 ,show (fingerprint top, fingerprint p)]
2363 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
2364 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
2365 update (Just (KeyData key sigs uids subkeys)) | isUserID p
2366 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
2367 subkeys
2368 update (Just (KeyData key sigs uids subkeys))
2369 = case sub of
2370 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
2371 UserIDPacket {} -> Just $ KeyData key
2372 sigs
2373 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
2374 subkeys
2375 _ | isKey sub -> Just $ KeyData key
2376 sigs
2377 uids
2378 (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
2379 _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
2380 update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
2381
2382 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
2383 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) []
2384 mergeSubkey n p (Just (SubKey key sigs)) = Just $
2385 SubKey (mergeKeyPacket "subs" key $ asMapped n p)
2386 sigs
2387
2388 mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
2389 mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n))
2390 mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
2391 mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
2392
2393 whatP (a,_) = concat . take 1 . words . show $ a
2394
2395
2396 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m)
2397 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
2398
2399 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs)
2400 mergeSubSig n sig Nothing = error $
2401 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
2402
2403mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
2404mergeSig sig sigs =
2405 let (xs,ys) = break (isSameSig (first packet sig)) sigs
2406 in if null ys
2407 then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig]
2408 else let y:ys'=ys
2409 in xs ++ (mergeSameSig sig y : ys')
2410 where
2411 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
2412 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
2413 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
2414
2415 mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
2416 mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
2417 | isSignaturePacket (packet a) && isSignaturePacket b =
2418 ( m { packet = b { unhashed_subpackets =
2419 union (unhashed_subpackets b) (unhashed_subpackets $ packet a)
2420 }
2421 , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs }
2422 -- TODO: when merging items, we should delete invalidated origins
2423 -- from the orgin map.
2424 , tb `Map.union` ta )
2425
2426 mergeSameSig a b = b -- trace ("discarding dup "++show a) b
2427
2428
2429flattenKeys :: Bool -> KeyDB -> Message
2430flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
2431 where
2432 prefilter = if isPublic then id else filter isSecret
2433 where
2434 isSecret (_,(KeyData
2435 (MappedPacket { packet=(SecretKeyPacket {})})
2436 _
2437 _
2438 _)) = True
2439 isSecret _ = False
2440
2441
2442data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
2443 deriving (Eq,Ord,Enum,Show,Read)
2444
2445getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
2446getSubkeys ck topk subs tag = do
2447 SubKey k sigs <- Map.elems subs
2448 let subk = packet k
2449 let sigs' = do
2450 -- require tag
2451 torsig <- filter (has_tag tag) $ map (packet . fst) sigs
2452
2453 -- require parent's signature
2454 when (ck > Unsigned) $ do
2455 sig <- (signatures $ Message [topk,subk,torsig])
2456 let v = verify (Message [topk]) sig
2457 -- Require parent's signature
2458 guard (not . null $ signatures_over v)
2459
2460 -- require child's back signature
2461 when (ck == CrossSigned ) $ do
2462 let unhashed = unhashed_subpackets torsig
2463 subsigs = mapMaybe backsig unhashed
2464 -- This should consist only of 0x19 values
2465 -- subtypes = map signature_type subsigs
2466 -- subtyp <- subtypes
2467 -- guard (subtyp == 0x19)
2468 sig' <- signatures . Message $ [topk,subk]++subsigs
2469 let v' = verify (Message [subk]) sig'
2470 -- Require subkey's signature
2471 guard . not . null $ signatures_over v'
2472 return torsig
2473 guard (not $ null sigs')
2474 return subk
2475
2476-- |
2477-- Returns (ip6 fingerprint address,(onion names,other host names))
2478--
2479-- Requires a validly cross-signed tor key for each onion name returned.
2480-- (Signature checks are performed.)
2481getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
2482getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
2483 where
2484 othernames = do
2485 mp <- flattenAllUids "" True uids
2486 let p = packet mp
2487 guard $ isSignaturePacket p
2488 uh <- unhashed_subpackets p
2489 case uh of
2490 NotationDataPacket True "hostname@" v
2491 -> return $ Char8.pack v
2492 _ -> mzero
2493
2494 addr = fingerdress topk
2495 -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
2496 topk = packet topmp
2497 torkeys = getSubkeys CrossSigned topk subs "tor"
2498
2499 -- subkeyPacket (SubKey k _ ) = k
2500 onames :: [L.ByteString]
2501 onames = map ( (<> ".onion")
2502 . Char8.pack
2503 . take 16
2504 . torhash )
2505 torkeys
2506
2507hasFingerDress :: KeyDB -> SockAddr -> Bool
2508hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
2509hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
2510 where
2511 (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
2512 g' = map toUpper g
2513
2514-- We return into IO in case we want to make a signature here.
2515setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
2516setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
2517 -- TODO: we are removing the origin from the UID OriginMap,
2518 -- when we should be removing origins from the locations
2519 -- field of the sig's MappedPacket records.
2520 -- Call getHostnames and compare to see if no-op.
2521 if not (pred addr) || names0 == names \\ onions
2522 then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
2523 , " file: "++show (map Char8.unpack names)
2524 , " pred: "++show (pred addr)]) -}
2525 (return kd)
2526 else do
2527 -- We should be sure to remove origins so that the data is written
2528 -- (but only if something changed).
2529 -- Filter all hostnames present in uids
2530 -- Write notations into first uid
2531 {-
2532 trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
2533 , " file: "++show (map Char8.unpack names) ]) $ do
2534 -}
2535 return $ KeyData topmp topsigs uids1 subs
2536 where
2537 topk = packet topmp
2538 addr = fingerdress topk
2539 names :: [Char8.ByteString]
2540 names = Hosts.namesForAddress addr hosts
2541 (_,(onions,names0)) = getHostnames kd
2542 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
2543 isName (NotationDataPacket True "hostname@" _) = True
2544 isName _ = False
2545 uids0 = fmap zapIfHasName uids
2546 fstuid = head $ do
2547 p <- map packet $ flattenAllUids "" True uids
2548 guard $ isUserID p
2549 return $ uidkey p
2550 uids1 = Map.adjust addnames fstuid uids0
2551 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
2552 where
2553 (ss,ts) = splitAt 1 sigs
2554 f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
2555 else (sig, tm)
2556 where p' = (packet sig) { unhashed_subpackets=uh }
2557 uh = unhashed_subpackets (packet sig) ++ notations
2558 zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin
2559 else (sigs,om)
2560 where
2561 (bs, sigs') = unzip $ map unhash sigs
2562
2563 unhash (sig,tm) = ( not (null ns)
2564 , ( sig { packet = p', locations = Map.empty }
2565 , tm ) )
2566 where
2567 psig = packet sig
2568 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
2569 else psig
2570 uh = unhashed_subpackets psig
2571 (ns,ps) = partition isName uh
2572
2573fingerdress :: Packet -> SockAddr
2574fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
2575 where
2576 zero = SockAddrInet 0 0
2577 addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk)
2578 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
2579 colons xs = xs
2580
2581socketFamily :: SockAddr -> Family
2582socketFamily (SockAddrInet _ _) = AF_INET
2583socketFamily (SockAddrInet6 {}) = AF_INET6
2584socketFamily (SockAddrUnix _) = AF_UNIX
2585 1281
2586#if ! MIN_VERSION_unix(2,7,0) 1282#if ! MIN_VERSION_unix(2,7,0)
2587setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () 1283setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO ()
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 1c2a5aa..6de217b 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -2,13 +2,21 @@
2{-# LANGUAGE DeriveFunctor #-} 2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DoAndIfThenElse #-} 3{-# LANGUAGE DoAndIfThenElse #-}
4{-# LANGUAGE ForeignFunctionInterface #-} 4{-# LANGUAGE ForeignFunctionInterface #-}
5{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PatternGuards #-} 7{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE TupleSections #-} 8{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE ViewPatterns #-} 9{-# LANGUAGE ViewPatterns #-}
9module KeyRing.BuildKeyDB where 10module KeyRing.BuildKeyDB where
10import qualified Codec.Binary.Base32 as Base32 11
11import qualified Codec.Binary.Base64 as Base64 12#if defined(VERSION_memory)
13import Data.ByteArray.Encoding
14import qualified Data.ByteString.Char8 as S8
15import qualified Data.ByteString as S
16#elif defined(VERSION_dataenc)
17import qualified Codec.Binary.Base32 as Base32
18import qualified Codec.Binary.Base64 as Base64
19#endif
12import Control.Applicative (liftA2) 20import Control.Applicative (liftA2)
13import Control.Arrow (first, second) 21import Control.Arrow (first, second)
14import Control.Exception (catch) 22import Control.Exception (catch)
@@ -17,7 +25,9 @@ import ControlMaybe (handleIO_)
17import Data.ASN1.BinaryEncoding (DER (..)) 25import Data.ASN1.BinaryEncoding (DER (..))
18import Data.ASN1.Encoding (decodeASN1, encodeASN1) 26import Data.ASN1.Encoding (decodeASN1, encodeASN1)
19 27
20import Data.ASN1.Types (fromASN1, toASN1) 28import Data.ASN1.Types (ASN1 (BitString, End, IntVal, Null, OID, Start),
29 ASN1ConstructionType (Sequence), ASN1Object,
30 fromASN1, toASN1)
21import Data.Binary 31import Data.Binary
22import Data.Bits ((.&.), (.|.)) 32import Data.Bits ((.&.), (.|.))
23import Data.Bits (Bits) 33import Data.Bits (Bits)
@@ -101,6 +111,9 @@ import ScanningParser
101import TimeUtil 111import TimeUtil
102 112
103import KeyRing.Types 113import KeyRing.Types
114import Transforms
115import PacketTranscoder
116import GnuPGAgent
104 117
105-- | buildKeyDB 118-- | buildKeyDB
106-- 119--
@@ -116,16 +129,15 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
116 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], 129 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
117 {- outgoing_names -}[SockAddr]) 130 {- outgoing_names -}[SockAddr])
118 ,{- accs -} Map.Map InputFile Access 131 ,{- accs -} Map.Map InputFile Access
119 ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) 132 ,{- doDecrypt -} PacketTranscoder
120 ,{- unspilled -} Map.Map InputFile Message 133 ,{- unspilled -} Map.Map InputFile Message
121 ) 134 )
122 ,{- report_imports -} [(FilePath,KikiReportAction)])) 135 ,{- report_imports -} [(FilePath,KikiReportAction)]))
123buildKeyDB ctx grip0 keyring = do 136buildKeyDB ctx grip0 keyring = do
124 let 137 let files istyp = do
125 files istyp = do
126 (f,stream) <- Map.toList (opFiles keyring) 138 (f,stream) <- Map.toList (opFiles keyring)
127 guard (istyp $ typ stream) 139 guard (istyp $ typ stream)
128 resolveInputFile ctx f 140 return f -- resolveInputFile ctx f
129 141
130 ringMap0 = Map.filter (isring . typ) $ opFiles keyring 142 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
131 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 143 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
@@ -145,10 +157,10 @@ buildKeyDB ctx grip0 keyring = do
145 _ -> AutoAccess 157 _ -> AutoAccess
146 acc -> acc 158 acc -> acc
147 159
148 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) 160 readw wk n = fmap (n,) (readPacketsFromWallet wk n)
149 161
150 -- KeyRings (todo: KikiCondition reporting?) 162 -- KeyRings (todo: KikiCondition reporting?)
151 (spilled,mwk,grip,accs,keys,unspilled) <- do 163 (spilled,mwk,grip,accs,keyqs,unspilled) <- do
152#if MIN_VERSION_containers(0,5,0) 164#if MIN_VERSION_containers(0,5,0)
153 ringPackets <- Map.traverseWithKey readp ringMap 165 ringPackets <- Map.traverseWithKey readp ringMap
154#else 166#else
@@ -164,39 +176,25 @@ buildKeyDB ctx grip0 keyring = do
164 176
165 -- | spilled 177 -- | spilled
166 -- ring packets with info available for export 178 -- ring packets with info available for export
167 -- | unspilled 179 -- | unspilled
168 -- the rest 180 -- the rest
169 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets 181 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
170 182
171 -- | keys 183 -- | keys
172 -- process ringPackets, and get a map of fingerprint info to 184 -- process ringPackets, and get a map of fingerprint info to
173 -- to a packet, remembering it's original file, access. 185 -- to a packet, remembering it's original file, access.
174 keys :: Map.Map KeyKey MappedPacket 186 keys :: Map.Map KeyKey (OriginMapped Query)
175 keys = Map.foldl slurpkeys Map.empty
176 $ Map.mapWithKey filterSecrets ringPackets
177 where
178 filterSecrets f (_,Message ps) =
179 filter (isSecretKey . packet)
180 $ zipWith (mappedPacketWithHint fname) ps [1..]
181 where fname = resolveForReport (Just ctx) f
182 slurpkeys m ps = m `Map.union` Map.fromList ps'
183 where ps' = zip (map (keykey . packet) ps) ps
184 -- | mwk
185 -- first master key matching the provided grip
186 -- (the m is for "MappedPacket", wk for working key)
187 mwk :: Maybe MappedPacket 187 mwk :: Maybe MappedPacket
188 mwk = listToMaybe $ do 188 (mwk, keys) = keyQueries grip ringPackets
189 fp <- maybeToList grip 189
190 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
191 where p = packet mp
192 Map.elems $ Map.filter matchfp keys
193 -- | accs 190 -- | accs
194 -- file access(Sec | Pub) lookup table 191 -- file access(Sec | Pub) lookup table
195 accs :: Map.Map InputFile Access 192 accs :: Map.Map InputFile Access
196 accs = fmap (access . fst) ringPackets 193 accs = fmap (access . fst) ringPackets
197 return (spilled,mwk,grip,accs,keys,fmap snd unspilled) 194 return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
198 195
199 doDecrypt <- makeMemoizingDecrypter keyring ctx keys 196 transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
197 let doDecrypt = transcode (Unencrypted,S2K 100 "")
200 198
201 let wk = fmap packet mwk 199 let wk = fmap packet mwk
202 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx 200 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
@@ -205,10 +203,10 @@ buildKeyDB ctx grip0 keyring = do
205 , rtWorkingKey = wk 203 , rtWorkingKey = wk
206 , rtRingAccess = accs 204 , rtRingAccess = accs
207 , rtKeyDB = Map.empty 205 , rtKeyDB = Map.empty
208 , rtPassphrases = doDecrypt 206 , rtPassphrases = transcode
209 } 207 }
210 -- autosigns and deletes 208 -- autosigns and deletes
211 transformed0 <- do 209 transformed0 <-
212 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) 210 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
213 trans f (info,ps) = do 211 trans f (info,ps) = do
214 let manip = combineTransforms (transforms info) 212 let manip = combineTransforms (transforms info)
@@ -216,87 +214,84 @@ buildKeyDB ctx grip0 keyring = do
216 acc = Just Sec /= Map.lookup f accs 214 acc = Just Sec /= Map.lookup f accs
217 r <- performManipulations doDecrypt rt1 mwk manip 215 r <- performManipulations doDecrypt rt1 mwk manip
218 try r $ \(rt2,report) -> do 216 try r $ \(rt2,report) -> do
219 return $ KikiSuccess (report,rtKeyDB rt2) 217 return $ KikiSuccess (report,rtKeyDB rt2)
218 -- XXX: Unspilled keys are not obtainable from rtKeyDB.
219 -- If the working key is marked non spillable, then how
220 -- would we look up it's UID and such?
220#if MIN_VERSION_containers(0,5,0) 221#if MIN_VERSION_containers(0,5,0)
221 fmap sequenceA $ Map.traverseWithKey trans spilled 222 in fmap sequenceA $ Map.traverseWithKey trans spilled
222#else 223#else
223 fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled 224 in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
224#endif 225#endif
225 try transformed0 $ \transformed -> do 226 try transformed0 $ \transformed -> do
226 let -- | db_rings - all keyrings combined into one 227 let -- | db_rings - all keyrings combined into one
227 db_rings :: Map.Map KeyKey KeyData 228 db_rings :: Map.Map KeyKey KeyData
228 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed 229 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
229 where 230 where
230 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans 231 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans
231 -- | reportTrans 232 -- | reportTrans
232 -- events, indexed by file 233 -- events, indexed by file
233 reportTrans :: [(FilePath, KikiReportAction)] 234 reportTrans :: [(FilePath, KikiReportAction)]
234 reportTrans = concat $ Map.elems $ fmap fst transformed 235 reportTrans = concat $ Map.elems $ fmap fst transformed
235 236
236 -- Wallets 237 -- Wallets
237 let importWalletKey wk db' (top,fname,sub,tag) = do 238 let importWalletKey wk db' (top,fname,sub,tag) = do
238 try db' $ \(db',report0) -> do 239 try db' $ \(db',report0) -> do
239 r <- doImportG doDecrypt 240 r <- doImportG transcode
240 db' 241 db'
241 (fmap keykey $ maybeToList wk) 242 (fmap keykey $ maybeToList wk)
242 [mkUsage tag] 243 [mkUsage tag]
243 fname 244 fname
244 sub 245 sub
245 try r $ \(db'',report) -> do 246 try r $ \(db'',report) -> do
246 return $ KikiSuccess (db'', report0 ++ report) 247 return $ KikiSuccess (db'', report0 ++ report)
247 248
248 wms <- mapM (readw wk) (files iswallet) 249 wms <- mapM (readw wk) (files iswallet)
249 let wallet_keys = do 250 let wallet_keys = do
250 maybeToList wk 251 maybeToList wk
251 (fname,xs) <- wms 252 (fname,xs) <- wms
252 (_,sub,(_,m)) <- xs 253 (_,sub,(_,m)) <- xs
253 (tag,top) <- Map.toList m 254 (tag,top) <- Map.toList m
254 return (top,fname,sub,tag) 255 return (top,fname,sub,tag)
255 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys 256
256 try db $ \(db,reportWallets) -> do 257 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
257 258 try db $ \(db,reportWallets) -> do
258 -- PEM files 259
259 let pems = do 260 -- PEM files
260 (n,stream) <- Map.toList $ opFiles keyring 261 let pems = do
261 grip <- maybeToList grip 262 (n,stream) <- Map.toList $ opFiles keyring
262 n <- resolveInputFile ctx n 263 grip <- maybeToList grip
263 guard $ spillable stream && isSecretKeyFile (typ stream) 264 guard $ spillable stream && isSecretKeyFile (typ stream)
264 let us = mapMaybe usageFromFilter [fill stream,spill stream] 265 let us = mapMaybe usageFromFilter [fill stream,spill stream]
265 usage <- take 1 us 266 usage <- take 1 us
266 guard $ all (==usage) $ drop 1 us 267 guard $ all (==usage) $ drop 1 us
267 -- TODO: KikiCondition reporting for spill/fill usage mismatch? 268 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
268 -- TODO: parseSpec3 269 -- TODO: parseSpec3
269 let (topspec,subspec) = parseSpec grip usage 270 let (topspec,subspec) = parseSpec grip usage
270 ms = map fst $ filterMatches topspec (Map.toList db) 271 ms = map fst $ filterMatches topspec (Map.toList db)
271 cmd = initializer stream 272 cmd = initializer stream
272 return (n,subspec,ms,stream, cmd) 273 return (n,subspec,ms,stream, cmd)
273 274
274 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems 275 imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
275 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports 276 _ -> return True)
276 try db $ \(db,reportPEMs) -> do 277 pems
277 278 db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
278 -- generate keys 279 try db $ \(db,reportPEMs) -> do
279 let gens = mapMaybe g $ Map.toList genMap 280
280 where g (Generate _ params,v) = Just (params,v) 281 -- generate keys
281 g _ = Nothing 282 let gens = mapMaybe g $ Map.toList genMap
282 283 where g (Generate _ params,v) = Just (params,v)
283 db <- generateInternals doDecrypt mwk db gens 284 g _ = Nothing
284 try db $ \(db,reportGens) -> do 285
285 286 db <- generateInternals transcode mwk db gens
286 r <- mergeHostFiles keyring db ctx 287 try db $ \(db,reportGens) -> do
287 try r $ \((db,hs),reportHosts) -> do 288
288 289 r <- mergeHostFiles keyring db ctx
289 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) 290 try r $ \((db,hs),reportHosts) -> do
290 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) 291
291 292 return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled)
292 293 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
293resolveInputFile :: InputFileContext -> InputFile -> [FilePath] 294
294resolveInputFile ctx = resolve
295 where
296 resolve HomeSec = return (homesecPath ctx)
297 resolve HomePub = return (homepubPath ctx)
298 resolve (ArgFile f) = return f
299 resolve _ = []
300 295
301isring :: FileType -> Bool 296isring :: FileType -> Bool
302isring (KeyRingFile {}) = True 297isring (KeyRingFile {}) = True
@@ -327,11 +322,12 @@ readPacketsFromWallet wk fname = do
327 timestamp <- getInputFileTime ctx fname 322 timestamp <- getInputFileTime ctx fname
328 input <- readInputFileL ctx fname 323 input <- readInputFileL ctx fname
329 let (ks,_) = slurpWIPKeys timestamp input 324 let (ks,_) = slurpWIPKeys timestamp input
325 {-
330 unless (null ks) $ do 326 unless (null ks) $ do
331 -- decrypt wk 327 -- decrypt wk
332 -- create sigs 328 -- create sigs
333 -- return key/sig pairs 329 -- return key/sig pairs
334 return () 330 return () -}
335 return $ do 331 return $ do
336 wk <- maybeToList wk 332 wk <- maybeToList wk
337 guard (not $ null ks) 333 guard (not $ null ks)
@@ -344,120 +340,11 @@ spillable :: StreamInfo -> Bool
344spillable (spill -> KF_None) = False 340spillable (spill -> KF_None) = False
345spillable _ = True 341spillable _ = True
346 342
347isSecretKey :: Packet -> Bool
348isSecretKey (SecretKeyPacket {}) = True
349isSecretKey _ = False
350
351mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
352mappedPacketWithHint filename p hint = MappedPacket
353 { packet = p
354 , locations = Map.singleton filename (origin p hint)
355 }
356
357resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
358resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
359 where str = case (fdr,fdw) of
360 (0,1) -> "-"
361 _ -> "&pipe" ++ show (fdr,fdw)
362resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
363 where str = "&" ++ show fd
364resolveForReport mctx f = concat $ resolveInputFile ctx f
365 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
366
367keykey :: Packet -> KeyKey
368keykey key =
369 -- Note: The key's timestamp is normally included in it's fingerprint.
370 -- This is undesirable for kiki because it causes the same
371 -- key to be imported multiple times and show as apparently
372 -- distinct keys with different fingerprints.
373 -- Thus, we will remove the timestamp.
374 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
375
376-- matchpr computes the fingerprint of the given key truncated to
377-- be the same lenght as the given fingerprint for comparison.
378--
379-- matchpr fp = Data.List.Extra.takeEnd (length fp)
380--
381matchpr :: String -> Packet -> String
382matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
383
384makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
385 -> Map.Map KeyKey MappedPacket
386 -> IO (MappedPacket -> IO (KikiCondition Packet))
387makeMemoizingDecrypter operation ctx keys =
388 if null chains then do
389 -- (*) Notice we do not pass ctx to resolveForReport.
390 -- This is because the merge function does not currently use a context
391 -- and the pws map keys must match the MappedPacket locations.
392 -- TODO: Perhaps these should both be of type InputFile rather than
393 -- FilePath?
394 -- pws :: Map.Map FilePath (IO S.ByteString)
395 {-
396 pws <-
397 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
398 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
399 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
400 -}
401 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
402 pws2 <-
403 Traversable.mapM (cachedContents prompt ctx)
404 $ Map.fromList $ mapMaybe
405 (\spec -> (,passSpecPassFile spec) `fmap` do
406 guard $ isNothing $ passSpecKeySpec spec
407 passSpecRingFile spec)
408 passspecs
409 defpw <- do
410 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
411 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
412 && isNothing (passSpecKeySpec sp))
413 $ opPassphrases operation
414 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
415 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
416 else let PassphraseMemoizer f = head chains
417 in return f
418 where
419 (chains,passspecs) = partition isChain $ opPassphrases operation
420 where isChain (PassphraseMemoizer {}) = True
421 isChain _ = False
422 doDecrypt :: IORef (Map.Map KeyKey Packet)
423 -> Map.Map FilePath (IO S.ByteString)
424 -> Maybe (IO S.ByteString)
425 -> MappedPacket
426 -> IO (KikiCondition Packet)
427 doDecrypt unkeysRef pws defpw mp0 = do
428 unkeys <- readIORef unkeysRef
429 let mp = fromMaybe mp0 $ do
430 k <- Map.lookup kk keys
431 return $ mergeKeyPacket "decrypt" mp0 k
432 wk = packet mp0
433 kk = keykey wk
434 fs = Map.keys $ locations mp
435
436 decryptIt [] = return BadPassphrase
437 decryptIt (getpw:getpws) = do
438 -- TODO: This function should use mergeKeyPacket to
439 -- combine the packet with it's unspilled version before
440 -- attempting to decrypt it.
441 pw <- getpw
442 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
443 case symmetric_algorithm wkun of
444 Unencrypted -> do
445 writeIORef unkeysRef (Map.insert kk wkun unkeys)
446 return $ KikiSuccess wkun
447 _ -> decryptIt getpws
448
449 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
450
451 case symmetric_algorithm wk of
452 Unencrypted -> return (KikiSuccess wk)
453 _ -> maybe (decryptIt getpws)
454 (return . KikiSuccess)
455 $ Map.lookup kk unkeys
456 343
457-- | combineTransforms 344-- | combineTransforms
458-- remove rundant transforms, and compile the rest to PacketUpdate(s) 345-- remove redundant transforms, and compile the rest to PacketUpdate(s)
459-- 346--
460-- eqivalent to: 347-- equivalent to:
461-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd 348-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd
462combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] 349combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
463combineTransforms trans rt kd = updates 350combineTransforms trans rt kd = updates
@@ -490,108 +377,6 @@ merge db inputfile (Message ps) = merge_ db filename qs
490 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public 377 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
491 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret 378 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
492 379
493performManipulations ::
494 (MappedPacket -> IO (KikiCondition Packet))
495 -> KeyRingRuntime
496 -> Maybe MappedPacket
497 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
498 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
499performManipulations doDecrypt rt wk manip = do
500 let db = rtKeyDB rt
501 performAll kd = foldM perform (KikiSuccess (kd, [])) $ manip rt kd
502 r <- Traversable.mapM performAll db
503 try (sequenceA r) $ \db -> do
504 return $
505 KikiSuccess (rt {rtKeyDB = fmap fst db}, concatMap snd $ Map.elems db)
506 where
507 perform
508 :: KikiCondition (KeyData, KikiReport)
509 -> PacketUpdate
510 -> IO (KikiCondition (KeyData, KikiReport))
511 perform kd (InducerSignature uid subpaks) = do
512 try kd $ \(kd, report) -> do
513 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
514 wkun' <- doDecrypt wk'
515 try wkun' $ \wkun -> do
516 let flgs =
517 if keykey (keyPacket kd) == keykey wkun
518 then keyFlags0
519 (keyPacket kd)
520 (map (\(x, _, _) -> x) selfsigs)
521 else []
522 sigOver =
523 makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $
524 flgs ++ subpaks
525 om = Map.singleton "--autosign" (origin p (-1))
526 where
527 p = UserIDPacket uid
528 toMappedPacket om p = (mappedPacket "" p) {locations = om}
529 selfsigs =
530 filter
531 (\(sig, v, whosign) ->
532 isJust
533 (v >> Just wkun >>=
534 guard . (== keykey whosign) . keykey))
535 vs
536 keys = map keyPacket $ Map.elems (rtKeyDB rt)
537 overs sig =
538 signatures $
539 Message (keys ++ [keyPacket kd, UserIDPacket uid, sig])
540 vs
541 :: [(Packet -- signature
542 , Maybe SignatureOver -- Nothing means non-verified
543 , Packet -- key who signed
544 )]
545 vs = do
546 x <- maybeToList $ Map.lookup uid (keyUids kd)
547 sig <- map (packet . fst) (fst x)
548 o <- overs sig
549 k <- keys
550 let ov = verify (Message [k]) $ o
551 signatures_over ov
552 return (sig, Just ov, k)
553 additional new_sig = do
554 new_sig <- maybeToList new_sig
555 guard (null $ selfsigs)
556 signatures_over new_sig
557 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
558 let f :: ([SigAndTrust], OriginMap) -> ([SigAndTrust], OriginMap)
559 f x =
560 ( map ((, Map.empty) . toMappedPacket om) (additional sigr) ++
561 fst x
562 , om `Map.union` snd x)
563 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
564 return $
565 KikiSuccess $
566 (kd {keyUids = Map.adjust f uid (keyUids kd)}, report)
567 perform kd (SubKeyDeletion topk subk) = do
568 try kd $ \(kd, report) -> do
569 let kk = keykey $ packet $ keyMappedPacket kd
570 kd'
571 | kk /= topk = kd
572 | otherwise =
573 kd {keySubKeys = Map.filterWithKey pred $ keySubKeys kd}
574 pred k _ = k /= subk
575 ps =
576 concat $
577 maybeToList $ do
578 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
579 return $
580 packet mp :
581 concatMap (\(p, ts) -> packet p : Map.elems ts) sigs
582 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
583 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
584 return $
585 KikiSuccess
586 ( kd'
587 , report ++
588 [(f, DeletedPacket $ showPacket p) | f <- rings, p <- ps])
589
590try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
591try x body =
592 case functorToEither x of
593 Left e -> return e
594 Right x -> body x
595 380
596mergeKeyData :: KeyData -> KeyData -> KeyData 381mergeKeyData :: KeyData -> KeyData -> KeyData
597mergeKeyData (KeyData atop asigs auids asubs) 382mergeKeyData (KeyData atop asigs auids asubs)
@@ -620,40 +405,19 @@ mergeKeyData (KeyData atop asigs auids asubs)
620 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) 405 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)
621 406
622doImportG 407doImportG
623 :: (MappedPacket -> IO (KikiCondition Packet)) 408 :: PacketTranscoder
624 -> Map.Map KeyKey KeyData 409 -> Map.Map KeyKey KeyData
625 -> [KeyKey] -- m0, only head is used 410 -> [KeyKey] -- m0, only head is used
626 -> [SignatureSubpacket] -- tags 411 -> [SignatureSubpacket] -- tags
627 -> FilePath 412 -> InputFile
628 -> Packet 413 -> Packet
629 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 414 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
630doImportG doDecrypt db m0 tags fname key = do 415doImportG transcode db m0 tags fname key = do
631 let kk = head m0 416 let kk = head m0
632 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db 417 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
633 kdr <- insertSubkey doDecrypt kk kd tags fname key 418 kdr <- insertSubkey transcode kk kd tags fname key
634 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 419 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
635 420
636mkUsage :: String -> SignatureSubpacket
637mkUsage tag
638 | Just flags <- lookup tag specials =
639 KeyFlagsPacket
640 { certify_keys = fromEnum flags .&. 0x1 /= 0
641 , sign_data = fromEnum flags .&. 0x2 /= 0
642 , encrypt_communication = fromEnum flags .&. 0x4 /= 0
643 , encrypt_storage = fromEnum flags .&. 0x8 /= 0
644 , split_key = False
645 , authentication = False
646 , group_key = False
647 }
648 where
649 flagsets = [Special .. VouchSignEncrypt]
650 specials = map (\f -> (usageString f, f)) flagsets
651
652mkUsage tag = NotationDataPacket
653 { human_readable = True
654 , notation_name = "usage@"
655 , notation_value = tag
656 }
657 421
658iswallet :: FileType -> Bool 422iswallet :: FileType -> Bool
659iswallet (WalletFile {}) = True 423iswallet (WalletFile {}) = True
@@ -749,32 +513,32 @@ filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
749filterMatches spec ks = filter (matchSpec spec . snd) ks 513filterMatches spec ks = filter (matchSpec spec . snd) ks
750 514
751importSecretKey :: 515importSecretKey ::
752 (MappedPacket -> IO (KikiCondition Packet)) 516 (PacketTranscoder)
753 -> KikiCondition 517 -> KikiCondition
754 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 518 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
755 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 519 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
756 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 520 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
757importSecretKey doDecrypt db' tup = do 521importSecretKey transcode db' tup = do
758 try db' $ \(db',report0) -> do 522 try db' $ \(db',report0) -> do
759 r <- doImport doDecrypt 523 r <- doImport transcode
760 db' 524 db'
761 tup 525 tup
762 try r $ \(db'',report) -> do 526 try r $ \(db'',report) -> do
763 return $ KikiSuccess (db'', report0 ++ report) 527 return $ KikiSuccess (db'', report0 ++ report)
764 528
765generateInternals :: 529generateInternals ::
766 (MappedPacket -> IO (KikiCondition Packet)) 530 PacketTranscoder
767 -> Maybe MappedPacket 531 -> Maybe MappedPacket
768 -> Map.Map KeyKey KeyData 532 -> Map.Map KeyKey KeyData
769 -> [(GenerateKeyParams,StreamInfo)] 533 -> [(GenerateKeyParams,StreamInfo)]
770 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 534 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
771generateInternals doDecrypt mwk db gens = do 535generateInternals transcode mwk db gens = do
772 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of 536 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
773 Just kd0 -> do 537 Just kd0 -> do
774 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens 538 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
775 try kd $ \(kd,reportGens) -> do 539 try kd $ \(kd,reportGens) -> do
776 let kk = keykey $ packet $ fromJust mwk 540 let kk = keykey $ packet $ fromJust mwk
777 return $ KikiSuccess (Map.insert kk kd db,reportGens) 541 return $ KikiSuccess (Map.insert kk kd db,reportGens)
778 Nothing -> return $ KikiSuccess (db,[]) 542 Nothing -> return $ KikiSuccess (db,[])
779 543
780mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext 544mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
@@ -875,89 +639,6 @@ slurpWIPKeys stamp cs =
875 else let (ks,js) = slurpWIPKeys stamp xs 639 else let (ks,js) = slurpWIPKeys stamp xs
876 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb 640 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
877 641
878origin :: Packet -> Int -> OriginFlags
879origin p n = OriginFlags ispub n
880 where
881 ispub = case p of
882 SecretKeyPacket {} -> False
883 _ -> True
884
885cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
886cachedContents maybePrompt ctx fd = do
887 ref <- newIORef Nothing
888 return $ get maybePrompt ref fd
889 where
890 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
891
892 get maybePrompt ref fd = do
893 pw <- readIORef ref
894 flip (flip maybe return) pw $ do
895 if fd == FileDesc 0 then case maybePrompt of
896 Just prompt -> S.hPutStr stderr prompt
897 Nothing -> return ()
898 else return ()
899 pw <- fmap trimCR $ readInputFileS ctx fd
900 writeIORef ref (Just pw)
901 return pw
902
903mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
904mergeKeyPacket what key p =
905 key { packet = minimumBy (keyCompare what) [packet key,packet p]
906 , locations = Map.union (locations key) (locations p)
907 }
908
909-- | resolveTransform
910resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
911resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
912 where
913 ops = map (\u -> InducerSignature u []) us
914 us = filter torStyle $ Map.keys umap
915 torStyle str = and [ uid_topdomain parsed == "onion"
916 , uid_realname parsed `elem` ["","Anonymous"]
917 , uid_user parsed == "root"
918 , fmap (match . fst) (lookup (packet k) torbindings)
919 == Just True ]
920 where parsed = parseUID str
921 match = (==subdom) . take (fromIntegral len)
922 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
923 subdom = Char8.unpack subdom0
924 len = T.length (uid_subdomain parsed)
925 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
926 getTorKeys pub = do
927 xs <- groupBindings pub
928 (_,(top,sub),us,_,_) <- xs
929 guard ("tor" `elem` us)
930 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
931 return (top,(torhash,sub))
932
933 groupBindings pub = gs
934 where (_,bindings) = getBindings pub
935 bindings' = accBindings bindings
936 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
937 ownerkey (_,(a,_),_,_,_) = a
938 sameMaster (ownerkey->a) (ownerkey->b)
939 = fingerprint_material a==fingerprint_material b
940 gs = groupBy sameMaster (sortBy (comparing code) bindings')
941
942
943-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
944resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
945 where
946 topk = keykey $ packet k -- key to master of key to be deleted
947 subk = do
948 (k,sub) <- Map.toList submap
949 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
950 return k
951
952-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
953resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
954 where
955 topk = keykey $ packet k -- key to master of key to be deleted
956 subk = do
957 (k,SubKey p sigs) <- Map.toList submap
958 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
959 return k
960
961merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] 642merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
962 -> KeyDB 643 -> KeyDB
963merge_ db filename qs = foldl mergeit db (zip [0..] qs) 644merge_ db filename qs = foldl mergeit db (zip [0..] qs)
@@ -972,140 +653,38 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
972 653
973 whatP (a,_) = concat . take 1 . words . show $ a 654 whatP (a,_) = concat . take 1 . words . show $ a
974 655
975isKey :: Packet -> Bool
976isKey (PublicKeyPacket {}) = True
977isKey (SecretKeyPacket {}) = True
978isKey _ = False
979
980isUserID :: Packet -> Bool
981isUserID (UserIDPacket {}) = True
982isUserID _ = False
983
984isTrust :: Packet -> Bool
985isTrust (TrustPacket {}) = True
986isTrust _ = False
987 656
988keyPacket :: KeyData -> Packet 657-- insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)]))
989keyPacket (KeyData k _ _ _) = packet k 658insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
990 659 let topcipher = symmetric_algorithm $ packet top
991keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] 660 tops2k = s2k $ packet top
992keyFlags0 wkun uidsigs = concat 661 doDecrypt = transcode (Unencrypted,S2K 100 "")
993 [ keyflags 662 fname = resolveForReport Nothing inputfile
994 , preferredsym 663 subkk = keykey key0
995 , preferredhash 664 istor = do
996 , preferredcomp 665 guard ("tor" `elem` mapMaybe usage tags)
997 , features ] 666 return $ torUIDFromKey key0
998 667 addOrigin (SubKey mp sigs) =
999 where
1000 subs = concatMap hashed_subpackets uidsigs
1001 keyflags = filterOr isflags subs $
1002 KeyFlagsPacket { certify_keys = True
1003 , sign_data = True
1004 , encrypt_communication = False
1005 , encrypt_storage = False
1006 , split_key = False
1007 , authentication = False
1008 , group_key = False
1009 }
1010 preferredsym = filterOr ispreferedsym subs $
1011 PreferredSymmetricAlgorithmsPacket
1012 [ AES256
1013 , AES192
1014 , AES128
1015 , CAST5
1016 , TripleDES
1017 ]
1018 preferredhash = filterOr ispreferedhash subs $
1019 PreferredHashAlgorithmsPacket
1020 [ SHA256
1021 , SHA1
1022 , SHA384
1023 , SHA512
1024 , SHA224
1025 ]
1026 preferredcomp = filterOr ispreferedcomp subs $
1027 PreferredCompressionAlgorithmsPacket
1028 [ ZLIB
1029 , BZip2
1030 , ZIP
1031 ]
1032 features = filterOr isfeatures subs $
1033 FeaturesPacket { supports_mdc = True
1034 }
1035
1036 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
1037
1038 isflags (KeyFlagsPacket {}) = True
1039 isflags _ = False
1040 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
1041 ispreferedsym _ = False
1042 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
1043 ispreferedhash _ = False
1044 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
1045 ispreferedcomp _ = False
1046 isfeatures (FeaturesPacket {}) = True
1047 isfeatures _ = False
1048
1049makeInducerSig
1050 :: Packet
1051 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
1052-- torsig g topk wkun uid timestamp extras = todo
1053makeInducerSig topk wkun uid extras
1054 = CertificationSignature (secretToPublic topk)
1055 uid
1056 (sigpackets 0x13
1057 subpackets
1058 subpackets_unh)
1059 where
1060 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
1061 tsign
1062 ++ extras
1063 subpackets_unh = [IssuerPacket (fingerprint wkun)]
1064 tsign = if keykey wkun == keykey topk
1065 then [] -- tsign doesnt make sense for self-signatures
1066 else [ TrustSignaturePacket 1 120
1067 , RegularExpressionPacket regex]
1068 -- <[^>]+[@.]asdf\.nowhere>$
1069 regex = "<[^>]+[@.]"++hostname++">$"
1070 -- regex = username ++ "@" ++ hostname
1071 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
1072 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
1073 pu = parseUID uidstr where UserIDPacket uidstr = uid
1074 subdomain' = escape . T.unpack . uid_subdomain
1075 topdomain' = escape . T.unpack . uid_topdomain
1076 escape s = concatMap echar s
1077 where
1078 echar '|' = "\\|"
1079 echar '*' = "\\*"
1080 echar '+' = "\\+"
1081 echar '?' = "\\?"
1082 echar '.' = "\\."
1083 echar '^' = "\\^"
1084 echar '$' = "\\$"
1085 echar '\\' = "\\\\"
1086 echar '[' = "\\["
1087 echar ']' = "\\]"
1088 echar c = [c]
1089
1090insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)]))
1091insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1092 let subkk = keykey key
1093 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1094 [])
1095 ( (False,) . addOrigin )
1096 (Map.lookup subkk subs)
1097 where
1098 addOrigin (SubKey mp sigs) =
1099 let mp' = mp 668 let mp' = mp
1100 { locations = Map.insert fname 669 { locations = Map.insert fname
1101 (origin (packet mp) (-1)) 670 (origin (packet mp) (-1))
1102 (locations mp) } 671 (locations mp) }
1103 in SubKey mp' sigs 672 in SubKey mp' sigs
1104 subs' = Map.insert subkk subkey subs
1105 673
1106 istor = do 674 subkey_result <- do
1107 guard ("tor" `elem` mapMaybe usage tags) 675 case Map.lookup subkk subs of
1108 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>" 676 Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing)
677 Nothing -> do
678 wkun' <- doDecrypt top
679 try wkun' $ \wkun -> do
680 key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
681 try key' $ \key -> do
682 return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key))
683
684
685 try subkey_result $ \(is_new,subkey,decrypted) -> do
686
687 let subs' = Map.insert subkk subkey subs
1109 688
1110 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do 689 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
1111 let has_torid = do 690 let has_torid = do
@@ -1115,72 +694,58 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1115 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) 694 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
1116 signatures_over $ verify (Message [packet top]) s 695 signatures_over $ verify (Message [packet top]) s
1117 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do 696 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
1118 wkun <- doDecrypt top 697
1119 698 let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids)
1120 try wkun $ \wkun -> do 699 uid = UserIDPacket idstr
1121 700 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1122 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) 701 tor_ov = makeInducerSig (packet top) (packet top) uid keyflags
1123 uid = UserIDPacket idstr 702 wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted
1124 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags 703 try wkun' $ \wkun -> do
1125 tor_ov = makeInducerSig (packet top) wkun uid keyflags 704 sig_ov <- pgpSign (Message [wkun])
1126 sig_ov <- pgpSign (Message [wkun]) 705 tor_ov
1127 tor_ov 706 SHA1
1128 SHA1 707 (fingerprint wkun)
1129 (fingerprint wkun) 708 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
1130 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) 709 (sig_ov >>= listToMaybe . signatures_over)
1131 (sig_ov >>= listToMaybe . signatures_over) 710 $ \sig -> do
1132 $ \sig -> do 711 let om = Map.singleton fname (origin sig (-1))
1133 let om = Map.singleton fname (origin sig (-1)) 712 trust = Map.empty
1134 trust = Map.empty 713 return $ KikiSuccess
1135 return $ KikiSuccess 714 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1136 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} 715 , trust)],om) uids
1137 , trust)],om) uids 716 , [] )
1138 , [] )
1139 717
1140 try uids' $ \(uids',report) -> do 718 try uids' $ \(uids',report) -> do
1141 719
1142 let SubKey subkey_p subsigs = subkey 720 let SubKey subkey_p subsigs = subkey
1143 wk = packet top 721 wk = packet top
1144 (xs',minsig,ys') = findTag tags wk key subsigs 722 (xs',minsig,ys') = findTag tags wk key0 subsigs
1145 doInsert mbsig = do 723 doInsert mbsig = do
1146 -- NEW SUBKEY BINDING SIGNATURE 724 -- NEW SUBKEY BINDING SIGNATURE
1147 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig 725 -- XXX: Here I assume that key0 is the unencrypted version
1148 try sig' $ \(sig',report) -> do 726 -- of subkey_p. TODO: Check this assumption.
1149 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] 727 sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig
1150 let subs' = Map.insert subkk 728 try sig' $ \(sig',report) -> do
1151 (SubKey subkey_p $ xs'++[sig']++ys') 729 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
1152 subs 730 let subs' = Map.insert subkk
1153 return $ KikiSuccess ( KeyData top topsigs uids' subs' 731 (SubKey subkey_p $ xs'++[sig']++ys')
1154 , report ) 732 subs
1155 733 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1156 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) 734 , report )
1157 else id 735
1158 s = show (fmap fst minsig,fingerprint key) 736 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
1159 in return (f report) 737 else id
1160 738 s = show (fmap fst minsig,fingerprint key0)
1161 case minsig of 739 in return (f report)
1162 Nothing -> doInsert Nothing -- we need to create a new sig 740
1163 Just (True,sig) -> -- we can deduce is_new == False 741 case minsig of
1164 -- we may need to add a tor id 742 Nothing -> doInsert Nothing -- we need to create a new sig
1165 return $ KikiSuccess ( KeyData top topsigs uids' subs' 743 Just (True,sig) -> -- we can deduce is_new == False
1166 , report ) 744 -- we may need to add a tor id
1167 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag 745 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1168 746 , report )
1169mappedPacket :: FilePath -> Packet -> MappedPacket 747 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
1170mappedPacket filename p = MappedPacket 748
1171 { packet = p
1172 , locations = Map.singleton filename (origin p (-1))
1173 }
1174
1175showPacket :: Packet -> String
1176showPacket p | isKey p = (if is_subkey p
1177 then showPacket0 p
1178 else ifSecret p "----Secret-----" "----Public-----")
1179 ++ " "++show (key_algorithm p)++" "++fingerprint p
1180 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1181 | otherwise = showPacket0 p
1182showPacket0 :: Show a => a -> [Char]
1183showPacket0 p = concat . take 1 $ words (show p)
1184 749
1185mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] 750mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
1186mergeSig sig sigs = 751mergeSig sig sigs =
@@ -1207,26 +772,6 @@ mergeSig sig sigs =
1207 772
1208 mergeSameSig a b = b -- trace ("discarding dup "++show a) b 773 mergeSameSig a b = b -- trace ("discarding dup "++show a) b
1209 774
1210usageString :: PGPKeyFlags -> String
1211usageString flgs =
1212 case flgs of
1213 Special -> "special"
1214 Vouch -> "vouch" -- signkey
1215 Sign -> "sign"
1216 VouchSign -> "vouch-sign"
1217 Communication -> "communication"
1218 VouchCommunication -> "vouch-communication"
1219 SignCommunication -> "sign-communication"
1220 VouchSignCommunication -> "vouch-sign-communication"
1221 Storage -> "storage"
1222 VouchStorage -> "vouch-storage"
1223 SignStorage -> "sign-storage"
1224 VouchSignStorage -> "vouch-sign-storage"
1225 Encrypt -> "encrypt"
1226 VouchEncrypt -> "vouch-encrypt"
1227 SignEncrypt -> "sign-encrypt"
1228 VouchSignEncrypt -> "vouch-sign-encrypt"
1229
1230parseSingleSpec :: String -> SingleKeySpec 775parseSingleSpec :: String -> SingleKeySpec
1231parseSingleSpec "*" = AnyMatch 776parseSingleSpec "*" = AnyMatch
1232parseSingleSpec "-" = WorkingKeyMatch 777parseSingleSpec "-" = WorkingKeyMatch
@@ -1270,66 +815,66 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
1270 us = filter (isInfixOf pat) $ Map.keys uids 815 us = filter (isInfixOf pat) $ Map.keys uids
1271 816
1272doImport 817doImport
1273 :: (MappedPacket -> IO (KikiCondition Packet)) 818 :: PacketTranscoder
1274 -> Map.Map KeyKey KeyData 819 -> Map.Map KeyKey KeyData
1275 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 820 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
1276 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 821 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1277doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do 822doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
1278 flip (maybe $ return CannotImportMasterKey) 823 flip (maybe $ return CannotImportMasterKey)
1279 subspec $ \tag -> do 824 subspec $ \tag -> do
1280 (certs,keys) <- case typ of 825 (certs,keys) <- case typ of
1281 PEMFile -> do 826 PEMFile -> do
1282 ps <- readSecretPEMFile (ArgFile fname) 827 ps <- readSecretPEMFile fname
1283 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) 828 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1284 = partition (isJust . spemCert) ps 829 = partition (isJust . spemCert) ps
1285 return (certs,keys) 830 return (certs,keys)
1286 DNSPresentation -> do 831 DNSPresentation -> do
1287 p <- readSecretDNSFile (ArgFile fname) 832 p <- readSecretDNSFile fname
1288 return ([],[p]) 833 return ([],[p])
1289 -- TODO Probably we need to move to a new design where signature 834 -- TODO Probably we need to move to a new design where signature
1290 -- packets are merged into the database in one phase with null 835 -- packets are merged into the database in one phase with null
1291 -- signatures, and then the signatures are made in the next phase. 836 -- signatures, and then the signatures are made in the next phase.
1292 -- This would let us merge annotations (like certificates) from 837 -- This would let us merge annotations (like certificates) from
1293 -- seperate files. 838 -- seperate files.
1294 foldM (importKey tag certs) (KikiSuccess (db,[])) keys 839 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1295 where 840 where
1296 importKey tag certs prior key = do 841 importKey tag certs prior key = do
1297 try prior $ \(db,report) -> do 842 try prior $ \(db,report) -> do
1298 let (m0,tailms) = splitAt 1 ms 843 let (m0,tailms) = splitAt 1 ms
1299 if (not (null tailms) || null m0) 844 if (not (null tailms) || null m0)
1300 then return $ AmbiguousKeySpec fname 845 then return $ AmbiguousKeySpec (resolveForReport Nothing fname)
1301 else do 846 else do
1302 let kk = keykey key 847 let kk = keykey key
1303 cs = filter (\c -> kk==keykey (pcertKey c)) certs 848 cs = filter (\c -> kk==keykey (pcertKey c)) certs
1304 blobs = map mkCertNotation $ nub $ map pcertBlob cs 849 blobs = map mkCertNotation $ nub $ map pcertBlob cs
1305 mkCertNotation bs = NotationDataPacket 850 mkCertNotation bs = NotationDataPacket
1306 { human_readable = False 851 { human_readable = False
1307 , notation_name = "x509cert@" 852 , notation_name = "x509cert@"
1308 , notation_value = Char8.unpack bs } 853 , notation_value = Char8.unpack bs }
1309 datedKey = key { timestamp = fromTime $ minimum dates } 854 datedKey = key { timestamp = fromTime $ minimum dates }
1310 dates = fromTime (timestamp key) : map pcertTimestamp certs 855 dates = fromTime (timestamp key) : map pcertTimestamp certs
1311 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey 856 r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey
1312 try r $ \(db',report') -> do 857 try r $ \(db',report') -> do
1313 return $ KikiSuccess (db',report++report') 858 return $ KikiSuccess (db',report++report')
1314 859
1315generateSubkey :: 860generateSubkey ::
1316 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ 861 PacketTranscoder
1317 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db 862 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1318 -> (GenerateKeyParams, StreamInfo) 863 -> (GenerateKeyParams, StreamInfo)
1319 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) 864 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1320generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do 865generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1321 try kd' $ \(kd,report0) -> do 866 try kd' $ \(kd,report0) -> do
1322 let subs = do 867 let subs = do
1323 SubKey p sigs <- Map.elems $ keySubKeys kd 868 SubKey p sigs <- Map.elems $ keySubKeys kd
1324 filter (has_tag tag) $ map (packet . fst) sigs 869 filter (has_tag tag) $ map (packet . fst) sigs
1325 if null subs 870 if null subs
1326 then do 871 then do
1327 newkey <- generateKey genparam 872 newkey <- generateKey genparam
1328 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey 873 kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
1329 try kdr $ \(newkd,report) -> do 874 try kdr $ \(newkd,report) -> do
1330 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) 875 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1331 else do 876 else do
1332 return $ KikiSuccess (kd,report0) 877 return $ KikiSuccess (kd,report0)
1333generateSubkey _ kd _ = return kd 878generateSubkey _ kd _ = return kd
1334 879
1335-- | 880-- |
@@ -1496,12 +1041,6 @@ secp256k1_id = 0x2b8104000a
1496 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 1041 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23
1497-} 1042-}
1498 1043
1499readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
1500readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
1501readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
1502readInputFileS ctx inp = do
1503 let fname = resolveInputFile ctx inp
1504 fmap S.concat $ mapM S.readFile fname
1505 1044
1506keyCompare :: String -> Packet -> Packet -> Ordering 1045keyCompare :: String -> Packet -> Packet -> Ordering
1507keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT 1046keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
@@ -1514,101 +1053,6 @@ keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
1514 , PP.ppShow b 1053 , PP.ppShow b
1515 ] 1054 ]
1516 1055
1517parseUID :: String -> UserIDRecord
1518parseUID str = UserIDRecord {
1519 uid_full = str,
1520 uid_realname = realname,
1521 uid_user = user,
1522 uid_subdomain = subdomain,
1523 uid_topdomain = topdomain
1524 }
1525 where
1526 text = T.pack str
1527 (T.strip-> realname, T.dropAround isBracket-> email)
1528 = T.break (=='<') text
1529 (user, T.drop 1-> hostname) = T.break (=='@') email
1530 ( T.reverse -> topdomain,
1531 T.reverse . T.drop 1 -> subdomain)
1532 = T.break (=='.') . T.reverse $ hostname
1533
1534flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1535flattenTop fname ispub (KeyData key sigs uids subkeys) =
1536 unk ispub key :
1537 ( flattenAllUids fname ispub uids
1538 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1539
1540derToBase32 :: ByteString -> String
1541#if !defined(VERSION_cryptonite)
1542derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
1543#else
1544derToBase32 = map toLower . Base32.encode . S.unpack . sha1
1545 where
1546 sha1 :: L.ByteString -> S.ByteString
1547 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1548#endif
1549
1550derRSA :: Packet -> Maybe ByteString
1551derRSA rsa = do
1552 k <- rsaKeyFromPacket rsa
1553 return $ encodeASN1 DER (toASN1 k [])
1554
1555getBindings ::
1556 [Packet]
1557 ->
1558 ( [([Packet],[SignatureOver])] -- other signatures with key sets
1559 -- that were used for the verifications
1560 , [(Word8,
1561 (Packet, Packet), -- (topkey,subkey)
1562 [String], -- usage flags
1563 [SignatureSubpacket], -- hashed data
1564 [Packet])] -- binding signatures
1565 )
1566getBindings pkts = (sigs,bindings)
1567 where
1568 (sigs,concat->bindings) = unzip $ do
1569 let (keys,_) = partition isKey pkts
1570 keys <- disjoint_fp keys
1571 let (bs,sigs) = verifyBindings keys pkts
1572 return . ((keys,sigs),) $ do
1573 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
1574 i <- map signature_issuer (signatures_over b)
1575 i <- maybeToList i
1576 who <- maybeToList $ find_key fingerprint (Message keys) i
1577 let (code,claimants) =
1578 case () of
1579 _ | who == topkey b -> (1,[])
1580 _ | who == subkey b -> (2,[])
1581 _ -> (0,[who])
1582 let hashed = signatures_over b >>= hashed_subpackets
1583 kind = guard (code==1) >> hashed >>= maybeToList . usage
1584 return (code,(topkey b,subkey b), kind, hashed,claimants)
1585
1586-- Returned data is simmilar to getBindings but the Word8 codes
1587-- are ORed together.
1588accBindings ::
1589 Bits t =>
1590 [(t, (Packet, Packet), [a], [a1], [a2])]
1591 -> [(t, (Packet, Packet), [a], [a1], [a2])]
1592accBindings bs = as
1593 where
1594 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
1595 as = map (foldl1 combine) gs
1596 bindingPair (_,p,_,_,_) = pub2 p
1597 where
1598 pub2 (a,b) = (pub a, pub b)
1599 pub a = fingerprint_material a
1600 samePair a b = bindingPair a == bindingPair b
1601 combine (ac,p,akind,ahashed,aclaimaints)
1602 (bc,_,bkind,bhashed,bclaimaints)
1603 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
1604
1605subkeyMappedPacket :: SubKey -> MappedPacket
1606subkeyMappedPacket (SubKey k _ ) = k
1607
1608has_tag :: String -> Packet -> Bool
1609has_tag tag p = isSignaturePacket p
1610 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
1611 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
1612 1056
1613dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData 1057dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
1614dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) 1058dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
@@ -1689,200 +1133,55 @@ secretToPublic pkt@(SecretKeyPacket {}) =
1689 } 1133 }
1690secretToPublic pkt = pkt 1134secretToPublic pkt = pkt
1691 1135
1692sigpackets ::
1693 Monad m =>
1694 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
1695sigpackets typ hashed unhashed = return $
1696 signaturePacket
1697 4 -- version
1698 typ -- 0x18 subkey binding sig, or 0x19 back-signature
1699 RSA
1700 SHA1
1701 hashed
1702 unhashed
1703 0 -- Word16 -- Left 16 bits of the signed hash value
1704 [] -- [MPI]
1705
1706usage :: SignatureSubpacket -> Maybe String
1707usage (NotationDataPacket
1708 { human_readable = True
1709 , notation_name = "usage@"
1710 , notation_value = u
1711 }) = Just u
1712usage _ = Nothing
1713
1714torhash :: Packet -> String
1715torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1716
1717keyFlags :: t -> [Packet] -> [SignatureSubpacket]
1718keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
1719
1720flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
1721flattenAllUids fname ispub uids =
1722 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1723
1724-- | Given list of subpackets, a master key, one of its subkeys and a
1725-- list of signatures on that subkey, yields:
1726--
1727-- * preceding list of signatures
1728--
1729-- * The most recent valid signature made by the master key along with a
1730-- flag that indicates whether or not all of the supplied subpackets occur in
1731-- it or, if no valid signature from the working key is present, Nothing.
1732--
1733-- * following list of signatures
1734--
1735findTag ::
1736 [SignatureSubpacket]
1737 -> Packet
1738 -> Packet
1739 -> [(MappedPacket, b)]
1740 -> ([(MappedPacket, b)],
1741 Maybe (Bool, (MappedPacket, b)),
1742 [(MappedPacket, b)])
1743findTag tag topk subkey subsigs = (xs',minsig,ys')
1744 where
1745 vs = map (\sig ->
1746 (sig, do
1747 sig <- Just (packet . fst $ sig)
1748 guard (isSignaturePacket sig)
1749 guard $ flip isSuffixOf
1750 (fingerprint topk)
1751 . fromMaybe "%bad%"
1752 . signature_issuer
1753 $ sig
1754 listToMaybe $
1755 map (signature_time . verify (Message [topk]))
1756 (signatures $ Message [topk,subkey,sig])))
1757 subsigs
1758 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
1759 xs' = map fst xs
1760 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
1761 minsig = do
1762 (sig,ov) <- listToMaybe ys
1763 ov
1764 let hshed = hashed_subpackets $ packet $ fst sig
1765 return ( null $ tag \\ hshed, sig)
1766
1767makeSig ::
1768 (MappedPacket -> IO (KikiCondition Packet))
1769 -> MappedPacket
1770 -> [Char]
1771 -> MappedPacket
1772 -> [SignatureSubpacket]
1773 -> Maybe (MappedPacket, Map.Map k a)
1774 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
1775makeSig doDecrypt top fname subkey_p tags mbsig = do
1776 let wk = packet top
1777 wkun <- doDecrypt top
1778 try wkun $ \wkun -> do
1779 let grip = fingerprint wk
1780 addOrigin new_sig =
1781 flip
1782 (maybe $ return FailedToMakeSignature)
1783 (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do
1784 let mp' = mappedPacket fname new_sig
1785 return $ KikiSuccess (mp', Map.empty)
1786 parsedkey = [packet subkey_p]
1787 hashed0
1788 | any isFlagsPacket tags = tags
1789 | otherwise =
1790 KeyFlagsPacket
1791 { certify_keys = False
1792 , sign_data = False
1793 , encrypt_communication = False
1794 , encrypt_storage = False
1795 , split_key = False
1796 , authentication = True
1797 , group_key = False
1798 } :
1799 tags
1800 -- implicitly added:
1801 -- , SignatureCreationTimePacket (fromIntegral timestamp)
1802 isFlagsPacket (KeyFlagsPacket {}) = True
1803 isFlagsPacket _ = False
1804 subgrip = fingerprint (head parsedkey)
1805 back_sig <-
1806 pgpSign
1807 (Message parsedkey)
1808 (SubkeySignature
1809 wk
1810 (head parsedkey)
1811 (sigpackets 0x19 hashed0 [IssuerPacket subgrip]))
1812 (if key_algorithm (head parsedkey) == ECDSA
1813 then SHA256
1814 else SHA1)
1815 subgrip
1816 let iss = IssuerPacket (fingerprint wk)
1817 cons_iss back_sig =
1818 iss : map EmbeddedSignaturePacket (signatures_over back_sig)
1819 unhashed0 = maybe [iss] cons_iss back_sig
1820 new_sig <-
1821 pgpSign
1822 (Message [wkun])
1823 (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0))
1824 SHA1
1825 grip
1826 let newSig = do
1827 r <- addOrigin new_sig
1828 return $ fmap (, []) r
1829 flip (maybe newSig) mbsig $ \(mp, trustmap) -> do
1830 let sig = packet mp
1831 isCreation (SignatureCreationTimePacket {}) = True
1832 isCreation _ = False
1833 isExpiration (SignatureExpirationTimePacket {}) = True
1834 isExpiration _ = False
1835 (cs, ps) = partition isCreation (hashed_subpackets sig)
1836 (es, qs) = partition isExpiration ps
1837 stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs
1838 where
1839 unwrap (SignatureCreationTimePacket x) = x
1840 exp = listToMaybe $ sort $ map unwrap es
1841 where
1842 unwrap (SignatureExpirationTimePacket x) = x
1843 expires = liftA2 (+) stamp exp
1844 timestamp <- now
1845 if fmap ((< timestamp) . fromIntegral) expires == Just True
1846 then return $
1847 KikiSuccess ((mp, trustmap), [UnableToUpdateExpiredSignature])
1848 else do
1849 let times =
1850 (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $
1851 maybeToList $ do
1852 e <- expires
1853 return $
1854 SignatureExpirationTimePacket (e - fromIntegral timestamp)
1855 sig' = sig {hashed_subpackets = times ++ (qs `union` tags)}
1856 new_sig <-
1857 pgpSign
1858 (Message [wkun])
1859 (SubkeySignature wk (packet subkey_p) [sig'])
1860 SHA1
1861 (fingerprint wk)
1862 newsig <- addOrigin new_sig
1863 return $ fmap (, []) newsig
1864 1136
1865ifSecret :: Packet -> t -> t -> t 1137ifSecret :: Packet -> t -> t -> t
1866ifSecret (SecretKeyPacket {}) t f = t 1138ifSecret (SecretKeyPacket {}) t f = t
1867ifSecret _ t f = f 1139ifSecret _ t f = f
1868 1140
1869uidkey :: Packet -> String 1141instance ASN1Object RSAPrivateKey where
1870uidkey (UserIDPacket str) = str 1142 toASN1 rsa@(RSAPrivateKey {})
1871 1143 = \xs -> Start Sequence
1872keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags 1144 : IntVal 0
1873keyflags flgs@(KeyFlagsPacket {}) = 1145 : mpiVal rsaN
1874 Just . toEnum $ 1146 : mpiVal rsaE
1875 ( bit 0x1 certify_keys 1147 : mpiVal rsaD
1876 .|. bit 0x2 sign_data 1148 : mpiVal rsaP
1877 .|. bit 0x4 encrypt_communication 1149 : mpiVal rsaQ
1878 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags 1150 : mpiVal rsaDmodP1
1879 -- other flags: 1151 : mpiVal rsaDmodQminus1
1880 -- split_key 1152 : mpiVal rsaCoefficient
1881 -- authentication (ssh-client) 1153 : End Sequence
1882 -- group_key 1154 : xs
1883 where 1155 where mpiVal f = IntVal x where MPI x = f rsa
1884 bit v f = if f flgs then v else 0 1156
1885keyflags _ = Nothing 1157 fromASN1 ( Start Sequence
1158 : IntVal _ -- version
1159 : IntVal n
1160 : IntVal e
1161 : IntVal d
1162 : IntVal p
1163 : IntVal q
1164 : IntVal dmodp1
1165 : IntVal dmodqminus1
1166 : IntVal coefficient
1167 : ys) =
1168 Right ( privkey, tail $ dropWhile notend ys)
1169 where
1170 notend (End Sequence) = False
1171 notend _ = True
1172 privkey = RSAPrivateKey
1173 { rsaN = MPI n
1174 , rsaE = MPI e
1175 , rsaD = MPI d
1176 , rsaP = MPI p
1177 , rsaQ = MPI q
1178 , rsaDmodP1 = MPI dmodp1
1179 , rsaDmodQminus1 = MPI dmodqminus1
1180 , rsaCoefficient = MPI coefficient
1181 }
1182 fromASN1 _ =
1183 Left "fromASN1: RSAPrivateKey: unexpected format"
1184
1886 1185
1887readSecretPEMFile :: InputFile -> IO [SecretPEMData] 1186readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1888readSecretPEMFile fname = do 1187readSecretPEMFile fname = do
@@ -1912,6 +1211,7 @@ readSecretPEMFile fname = do
1912 mergeDate (tm,_) (Right mb) = (tm,mb) 1211 mergeDate (tm,_) (Right mb) = (tm,mb)
1913 return $ dta 1212 return $ dta
1914 1213
1214
1915readSecretDNSFile :: InputFile -> IO Packet 1215readSecretDNSFile :: InputFile -> IO Packet
1916readSecretDNSFile fname = do 1216readSecretDNSFile fname = do
1917 let ctx = InputFileContext "" "" 1217 let ctx = InputFileContext "" ""
@@ -1992,97 +1292,6 @@ socketFamily (SockAddrUnix _) = AF_UNIX
1992selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 1292selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1993selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db 1293selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
1994 1294
1995isBracket :: Char -> Bool
1996isBracket '<' = True
1997isBracket '>' = True
1998isBracket _ = False
1999
2000unk :: Bool -> MappedPacket -> MappedPacket
2001unk isPublic = if isPublic then toPacket secretToPublic else id
2002 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
2003
2004concatSort ::
2005 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
2006concatSort fname getp f = concat . sortByHint fname getp . map f
2007
2008flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
2009flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
2010
2011rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
2012rsaKeyFromPacket p | isKey p = do
2013 n <- lookup 'n' $ key p
2014 e <- lookup 'e' $ key p
2015 return $ RSAKey n e
2016
2017rsaKeyFromPacket _ = Nothing
2018
2019disjoint_fp :: [Packet] -> [[Packet]]
2020disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
2021 where
2022 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
2023 samepr a b = smallpr a == smallpr b
2024
2025 {-
2026 -- useful for testing
2027 group2 :: [a] -> [[a]]
2028 group2 (x:y:ys) = [x,y]:group2 ys
2029 group2 [x] = [[x]]
2030 group2 [] = []
2031 -}
2032
2033verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver])
2034verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
2035 where
2036 verified = do
2037 sig <- signatures (Message nonkeys)
2038 let v = verify (Message keys) sig
2039 guard (not . null $ signatures_over v)
2040 return v
2041 (top,othersigs) = partition isSubkeySignature verified
2042 embedded = do
2043 sub <- top
2044 let sigover = signatures_over sub
2045 unhashed = sigover >>= unhashed_subpackets
2046 subsigs = mapMaybe backsig unhashed
2047 -- This should consist only of 0x19 values
2048 -- subtypes = map signature_type subsigs
2049 -- trace ("subtypes = "++show subtypes) (return ())
2050 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
2051 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
2052 let v = verify (Message [subkey sub]) sig
2053 guard (not . null $ signatures_over v)
2054 return v
2055
2056flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
2057flattenUid fname ispub (str,(sigs,om)) =
2058 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
2059
2060-- | Get the time stamp of a signature.
2061--
2062-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
2063-- the hashed section. TODO: change this?
2064--
2065signature_time :: SignatureOver -> Word32
2066signature_time ov = case (if null cs then ds else cs) of
2067 [] -> minBound
2068 xs -> maximum xs
2069 where
2070 ps = signatures_over ov
2071 ss = filter isSignaturePacket ps
2072 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
2073 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
2074 creationTime (SignatureCreationTimePacket t) = [t]
2075 creationTime _ = []
2076
2077splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
2078splitAtMinBy comp xs = minimumBy comp' xxs
2079 where
2080 xxs = zip (inits xs) (tails xs)
2081 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
2082 compM (Just a) (Just b) = comp a b
2083 compM Nothing mb = GT
2084 compM _ _ = LT
2085
2086parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert 1295parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert
2087parseCertBlob comp bs = do 1296parseCertBlob comp bs = do
2088 asn1 <- either (const Nothing) Just 1297 asn1 <- either (const Nothing) Just
@@ -2171,15 +1380,18 @@ extractRSAKeyFields kvs = do
2171 , rsaCoefficient = u } 1380 , rsaCoefficient = u }
2172 where 1381 where
2173 parseField blob = MPI <$> m 1382 parseField blob = MPI <$> m
1383#if defined(VERSION_memory)
1384 where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob)
1385 bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1386 where
1387 nlen = S.length bs
1388#elif defined(VERSION_dataenc)
2174 where m = bigendian <$> Base64.decode (Char8.unpack blob) 1389 where m = bigendian <$> Base64.decode (Char8.unpack blob)
2175
2176 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs 1390 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
2177 where 1391 where
2178 nlen = length bs 1392 nlen = length bs
1393#endif
2179 1394
2180backsig :: SignatureSubpacket -> Maybe Packet
2181backsig (EmbeddedSignaturePacket s) = Just s
2182backsig _ = Nothing
2183 1395
2184selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 1396selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
2185selectKey0 wantPublic (spec,mtag) db = do 1397selectKey0 wantPublic (spec,mtag) db = do
@@ -2190,27 +1402,7 @@ selectKey0 wantPublic (spec,mtag) db = do
2190 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 1402 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
2191 [] -> Nothing 1403 [] -> Nothing
2192 1404
2193sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] 1405-- TODO: Data.ByteString.Lazy now exports this.
2194sortByHint fname f = sortBy (comparing gethint)
2195 where
2196 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
2197 defnum = -1
2198
2199unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
2200unsig fname isPublic (sig,trustmap) =
2201 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
2202 where
2203 f n _ = n==fname -- && trace ("fname=n="++show n) True
2204 asMapped n p = let m = mappedPacket fname p
2205 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
2206
2207smallpr :: Packet -> [Char]
2208smallpr k = drop 24 $ fingerprint k
2209
2210isSubkeySignature :: SignatureOver -> Bool
2211isSubkeySignature (SubkeySignature {}) = True
2212isSubkeySignature _ = False
2213
2214toStrict :: L.ByteString -> S.ByteString 1406toStrict :: L.ByteString -> S.ByteString
2215toStrict = foldr1 (<>) . L.toChunks 1407toStrict = foldr1 (<>) . L.toChunks
2216 1408
diff --git a/lib/Types.hs b/lib/KeyRing/Types.hs
index dd519de..2383140 100644
--- a/lib/Types.hs
+++ b/lib/KeyRing/Types.hs
@@ -1,5 +1,5 @@
1{-# LANGUAGE DeriveFunctor #-} 1{-# LANGUAGE DeriveFunctor #-}
2module Types where 2module KeyRing.Types where
3 3
4import Data.Char (isLower,toLower) 4import Data.Char (isLower,toLower)
5import Data.List (groupBy) 5import Data.List (groupBy)
@@ -7,6 +7,7 @@ import Data.Map as Map (Map)
7import qualified Data.Map as Map 7import qualified Data.Map as Map
8import Data.OpenPGP 8import Data.OpenPGP
9import Data.OpenPGP.Util 9import Data.OpenPGP.Util
10import Data.Time.Clock
10import FunctorToMaybe 11import FunctorToMaybe
11import qualified Data.ByteString.Lazy as L 12import qualified Data.ByteString.Lazy as L
12import qualified System.Posix.Types as Posix 13import qualified System.Posix.Types as Posix
@@ -335,3 +336,59 @@ matchpr :: String -> Packet -> String
335matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp 336matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
336 337
337 338
339
340
341data KeySpec =
342 KeyGrip String -- fp:
343 | KeyTag Packet String -- fp:????/t:
344 | KeyUidMatch String -- u:
345 deriving Show
346
347{-
348RSAPrivateKey ::= SEQUENCE {
349 version Version,
350 modulus INTEGER, -- n
351 publicExponent INTEGER, -- e
352 privateExponent INTEGER, -- d
353 prime1 INTEGER, -- p
354 prime2 INTEGER, -- q
355 exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1)
356 exponent2 INTEGER, -- d mod (q-1)
357 coefficient INTEGER, -- (inverse of q) mod p
358 otherPrimeInfos OtherPrimeInfos OPTIONAL
359 }
360-}
361data RSAPrivateKey = RSAPrivateKey
362 { rsaN :: MPI
363 , rsaE :: MPI
364 , rsaD :: MPI
365 , rsaP :: MPI
366 , rsaQ :: MPI
367 , rsaDmodP1 :: MPI
368 , rsaDmodQminus1 :: MPI
369 , rsaCoefficient :: MPI
370 }
371 deriving Show
372
373data ParsedCert = ParsedCert
374 { pcertKey :: Packet
375 , pcertTimestamp :: UTCTime
376 , pcertBlob :: L.ByteString
377 }
378 deriving (Show,Eq)
379
380data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
381 deriving (Eq,Ord,Enum,Show,Read)
382
383data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
384 deriving (Show,Eq)
385
386data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)
387
388data SingleKeySpec = FingerprintMatch String
389 | SubstringMatch (Maybe MatchingField) String
390 | EmptyMatch
391 | AnyMatch
392 | WorkingKeyMatch
393 deriving (Show,Eq,Ord)
394
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
index e276528..6eadfe4 100644
--- a/lib/PacketTranscoder.hs
+++ b/lib/PacketTranscoder.hs
@@ -20,7 +20,7 @@ import qualified Data.Traversable as Traversable
20import System.IO ( stderr) 20import System.IO ( stderr)
21import System.Posix.IO ( fdToHandle ) 21import System.Posix.IO ( fdToHandle )
22import Text.Show.Pretty as PP ( ppShow ) 22import Text.Show.Pretty as PP ( ppShow )
23import Types 23import KeyRing.Types
24import ControlMaybe (handleIO_) 24import ControlMaybe (handleIO_)
25 25
26-- | Merge two representations of the same key, prefering secret version 26-- | Merge two representations of the same key, prefering secret version
diff --git a/lib/ScanningParser.hs b/lib/ScanningParser.hs
index f99e120..305402e 100644
--- a/lib/ScanningParser.hs
+++ b/lib/ScanningParser.hs
@@ -34,6 +34,8 @@ instance Functor (ScanningParser a) where
34 first f (x,y) = (f x, y) 34 first f (x,y) = (f x, y)
35 35
36 36
37instance Semigroup (ScanningParser a b) where
38 (<>) = mappend
37instance Monoid (ScanningParser a b) where 39instance Monoid (ScanningParser a b) where
38 mempty = ScanningParser (const Nothing) (const $ const (Nothing,[])) 40 mempty = ScanningParser (const Nothing) (const $ const (Nothing,[]))
39 mappend (ScanningParser ffstA pbdyA) 41 mappend (ScanningParser ffstA pbdyA)
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 990a5b4..c83f427 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -16,7 +16,7 @@ import Data.Ord
16import Data.OpenPGP 16import Data.OpenPGP
17import Data.OpenPGP.Util 17import Data.OpenPGP.Util
18import Data.Word 18import Data.Word
19import Types 19import KeyRing.Types
20import FunctorToMaybe 20import FunctorToMaybe
21import GnuPGAgent ( key_nbits ) 21import GnuPGAgent ( key_nbits )
22import PacketTranscoder 22import PacketTranscoder
@@ -257,10 +257,9 @@ mkUsage tag | Just flags <- lookup tag specials
257 where 257 where
258 flagsets = [Special .. VouchSignEncrypt] 258 flagsets = [Special .. VouchSignEncrypt]
259 specials = map (\f -> (usageString f, f)) flagsets 259 specials = map (\f -> (usageString f, f)) flagsets
260
261mkUsage tag = NotationDataPacket 260mkUsage tag = NotationDataPacket
262 { human_readable = True 261 { human_readable = True
263 , notation_name = "usage@" 262 , notation_name = "usage@"
264 , notation_value = tag 263 , notation_value = tag
265 } 264 }
266 265
@@ -278,6 +277,7 @@ unsig fname isPublic (sig,trustmap) =
278 asMapped n p = let m = mappedPacket fname p 277 asMapped n p = let m = mappedPacket fname p
279 in m { locations = fmap (\x->x {originalNum=n}) (locations m) } 278 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
280 279
280smallpr :: Packet -> [Char]
281smallpr k = drop 24 $ fingerprint k 281smallpr k = drop 24 $ fingerprint k
282 282
283backsig :: SignatureSubpacket -> Maybe Packet 283backsig :: SignatureSubpacket -> Maybe Packet
@@ -285,16 +285,19 @@ backsig (EmbeddedSignaturePacket s) = Just s
285backsig _ = Nothing 285backsig _ = Nothing
286 286
287 287
288isSubkeySignature :: SignatureOver -> Bool
288isSubkeySignature (SubkeySignature {}) = True 289isSubkeySignature (SubkeySignature {}) = True
289isSubkeySignature _ = False 290isSubkeySignature _ = False
290 291
291 292
293has_tag :: String -> Packet -> Bool
292has_tag tag p = isSignaturePacket p 294has_tag tag p = isSignaturePacket p
293 && or [ tag `elem` mapMaybe usage (hashed_subpackets p) 295 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
294 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] 296 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
295 297
296 298
297 299
300verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver])
298verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) 301verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
299 where 302 where
300 verified = do 303 verified = do
@@ -317,7 +320,7 @@ verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersig
317 guard (not . null $ signatures_over v) 320 guard (not . null $ signatures_over v)
318 return v 321 return v
319 322
320 323disjoint_fp :: [Packet] -> [[Packet]]
321disjoint_fp ks = {- concatMap group2 $ -} transpose grouped 324disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
322 where 325 where
323 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks 326 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
@@ -474,22 +477,22 @@ uidkey (UserIDPacket str) = str
474usageString :: PGPKeyFlags -> String 477usageString :: PGPKeyFlags -> String
475usageString flgs = 478usageString flgs =
476 case flgs of 479 case flgs of
477 Special -> "special" 480 Special -> "special"
478 Vouch -> "vouch" -- signkey 481 Vouch -> "vouch" -- signkey
479 Sign -> "sign" 482 Sign -> "sign"
480 VouchSign -> "vouch-sign" 483 VouchSign -> "vouch-sign"
481 Communication -> "communication" 484 Communication -> "communication"
482 VouchCommunication -> "vouch-communication" 485 VouchCommunication -> "vouch-communication"
483 SignCommunication -> "sign-communication" 486 SignCommunication -> "sign-communication"
484 VouchSignCommunication -> "vouch-sign-communication" 487 VouchSignCommunication -> "vouch-sign-communication"
485 Storage -> "storage" 488 Storage -> "storage"
486 VouchStorage -> "vouch-storage" 489 VouchStorage -> "vouch-storage"
487 SignStorage -> "sign-storage" 490 SignStorage -> "sign-storage"
488 VouchSignStorage -> "vouch-sign-storage" 491 VouchSignStorage -> "vouch-sign-storage"
489 Encrypt -> "encrypt" 492 Encrypt -> "encrypt"
490 VouchEncrypt -> "vouch-encrypt" 493 VouchEncrypt -> "vouch-encrypt"
491 SignEncrypt -> "sign-encrypt" 494 SignEncrypt -> "sign-encrypt"
492 VouchSignEncrypt -> "vouch-sign-encrypt" 495 VouchSignEncrypt -> "vouch-sign-encrypt"
493 496
494 497
495 498
@@ -529,7 +532,7 @@ showPacket p | isKey p = (if is_subkey p
529 flags = mapMaybe (fmap usageString . keyflags) xs 532 flags = mapMaybe (fmap usageString . keyflags) xs
530 xs = hashed_subpackets p 533 xs = hashed_subpackets p
531 534
532 535showPacket0 :: Show a => a -> [Char]
533showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) 536showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
534 where 537 where
535 dropSuffix :: String -> String -> String 538 dropSuffix :: String -> String -> String
@@ -588,7 +591,6 @@ keyFlags0 wkun uidsigs = concat
588 , preferredhash 591 , preferredhash
589 , preferredcomp 592 , preferredcomp
590 , features ] 593 , features ]
591
592 where 594 where
593 subs = concatMap hashed_subpackets uidsigs 595 subs = concatMap hashed_subpackets uidsigs
594 keyflags = filterOr isflags subs $ 596 keyflags = filterOr isflags subs $
@@ -650,7 +652,6 @@ rsaKeyFromPacket p | isKey p = do
650 n <- lookup 'n' $ key p 652 n <- lookup 'n' $ key p
651 e <- lookup 'e' $ key p 653 e <- lookup 'e' $ key p
652 return $ RSAKey n e 654 return $ RSAKey n e
653
654rsaKeyFromPacket _ = Nothing 655rsaKeyFromPacket _ = Nothing
655 656
656 657
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 01:50:29 +0000