summaryrefslogtreecommitdiff
path: root/lib/KeyRing.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-01 02:37:20 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-01 02:37:20 -0400
commitbc0458ee540da677a04eeddf9b4e0fe8a8991e93 (patch)
tree9b3f7ddce51a9ddbf2be725c78e79523fedee68e /lib/KeyRing.hs
parent7c2ee942309df7a484f3ab50b1b090ca5e606c03 (diff)
Attempted to merge 0bc53f99cfd70f3a18802604d7ef3174d004db4c.
I left lib/Kiki.hs out for later.
Diffstat (limited to 'lib/KeyRing.hs')
-rw-r--r--lib/KeyRing.hs1316
1 files changed, 6 insertions, 1310 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 ()
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-14 00:57:40 +0000