summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--kiki.cabal4
-rw-r--r--kiki.hs2
-rw-r--r--lib/KeyRing.hs663
-rw-r--r--lib/Transforms.hs738
4 files changed, 743 insertions, 664 deletions
diff --git a/kiki.cabal b/kiki.cabal
index 012bdf9..028a1ff 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -96,8 +96,8 @@ library
96 ControlMaybe, 96 ControlMaybe,
97 Compat, 97 Compat,
98 Types, 98 Types,
99 PacketTranscoder 99 PacketTranscoder,
100 100 Transforms
101 Build-Depends: base >=4.6.0.0, 101 Build-Depends: base >=4.6.0.0,
102 asn1-encoding, 102 asn1-encoding,
103 asn1-types, 103 asn1-types,
diff --git a/kiki.hs b/kiki.hs
index d3e505a..5c27c36 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1752,6 +1752,8 @@ commands =
1752 -- , ( "init-key", "initialize the samizdat key ring") 1752 -- , ( "init-key", "initialize the samizdat key ring")
1753 , ( "init", "Initialize kiki") 1753 , ( "init", "Initialize kiki")
1754 , ( "delete", "Delete a subkey and its associated signatures" ) 1754 , ( "delete", "Delete a subkey and its associated signatures" )
1755 -- TODO: , ( "rename", "Change the usage tag on a specified subkey" )
1756 -- also repairs signature and adds missing cross-certification.
1755 , ( "tar", "import or export system key files in tar format" ) 1757 , ( "tar", "import or export system key files in tar format" )
1756 ] 1758 ]
1757 1759
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 5953f12..bb32a2e 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -216,6 +216,7 @@ import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
216import GnuPGAgent as Agent 216import GnuPGAgent as Agent
217import Types 217import Types
218import PacketTranscoder 218import PacketTranscoder
219import Transforms
219 220
220-- DER-encoded elliptic curve ids 221-- DER-encoded elliptic curve ids
221-- nistp256_id = 0x2a8648ce3d030107 222-- nistp256_id = 0x2a8648ce3d030107
@@ -284,33 +285,6 @@ usageFromFilter (KF_Match usage) = return usage
284usageFromFilter _ = mzero 285usageFromFilter _ = mzero
285 286
286 287
287data KeyRingRuntime = KeyRingRuntime
288 { rtPubring :: FilePath
289 -- ^ Path to the file represented by 'HomePub'
290 , rtSecring :: FilePath
291 -- ^ Path to the file represented by 'HomeSec'
292 , rtGrip :: Maybe String
293 -- ^ Fingerprint or portion of a fingerprint used
294 -- to identify the working GnuPG identity used to
295 -- make signatures.
296 , rtWorkingKey :: Maybe Packet
297 -- ^ The master key of the working GnuPG identity.
298 , rtKeyDB :: KeyDB
299 -- ^ The common information pool where files spilled
300 -- their content and from which they received new
301 -- content.
302 , rtRingAccess :: Map.Map InputFile Access
303 -- ^ The 'Access' values used for files of type
304 -- 'KeyRingFile'. If 'AutoAccess' was specified
305 -- for a file, this 'Map.Map' will indicate the
306 -- detected value that was used by the algorithm.
307 , rtPassphrases :: PacketTranscoder
308 }
309
310-- | Roster-entry level actions
311data PacketUpdate = InducerSignature String [SignatureSubpacket]
312 | SubKeyDeletion KeyKey KeyKey
313
314filesToLock :: 288filesToLock ::
315 KeyRingOperation -> InputFileContext -> [FilePath] 289 KeyRingOperation -> InputFileContext -> [FilePath]
316filesToLock k ctx = do 290filesToLock k ctx = do
@@ -323,26 +297,11 @@ filesToLock k ctx = do
323-- kret :: a -> KeyRingOperation a 297-- kret :: a -> KeyRingOperation a
324-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) 298-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)
325 299
326data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
327data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show 300data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
328 301
329pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey 302pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
330pkcs8 (RSAKey n e) = RSAKey8 n e 303pkcs8 (RSAKey n e) = RSAKey8 n e
331 304
332instance ASN1Object RSAPublicKey where
333 -- PKCS #1 RSA Public Key
334 toASN1 (RSAKey (MPI n) (MPI e))
335 = \xs -> Start Sequence
336 : IntVal n
337 : IntVal e
338 : End Sequence
339 : xs
340 fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
341 Right (RSAKey (MPI n) (MPI e), xs)
342
343 fromASN1 _ =
344 Left "fromASN1: RSAPublicKey: unexpected format"
345
346instance ASN1Object PKCS8_RSAPublicKey where 305instance ASN1Object PKCS8_RSAPublicKey where
347 306
348 -- PKCS #8 Public key data 307 -- PKCS #8 Public key data
@@ -450,32 +409,6 @@ instance ASN1Object RSAPrivateKey where
450 409
451 410
452 411
453-- | This type is used to describe events triggered by 'runKeyRing'. In
454-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
455-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a
456-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
457-- many inputs and outputs, an operation may be partially (or even mostly)
458-- successful even when I/O failures occured. In this situation, the files may
459-- not have all the information they were intended to store, but they will be
460-- in a valid format for GnuPG or kiki to operate on in the future.
461data KikiReportAction =
462 NewPacket String
463 | MissingPacket String
464 | ExportedSubkey
465 | GeneratedSubkeyFile
466 | NewWalletKey String
467 | YieldSignature
468 | YieldSecretKeyPacket String
469 | UnableToUpdateExpiredSignature
470 | WarnFailedToMakeSignature
471 | FailedExternal Int
472 | ExternallyGeneratedFile
473 | UnableToExport KeyAlgorithm String
474 | FailedFileWrite
475 | HostsDiff ByteString
476 | DeletedPacket String
477 deriving (Eq,Show)
478
479uncamel :: String -> String 412uncamel :: String -> String
480uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args 413uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
481 where 414 where
@@ -501,23 +434,6 @@ data KikiResult a = KikiResult
501 -- along with the files that triggered them. 434 -- along with the files that triggered them.
502 } 435 }
503 436
504type KikiReport = [ (FilePath, KikiReportAction) ]
505
506keyPacket :: KeyData -> Packet
507keyPacket (KeyData k _ _ _) = packet k
508
509subkeyMappedPacket :: SubKey -> MappedPacket
510subkeyMappedPacket (SubKey k _ ) = k
511
512
513usage :: SignatureSubpacket -> Maybe String
514usage (NotationDataPacket
515 { human_readable = True
516 , notation_name = "usage@"
517 , notation_value = u
518 }) = Just u
519usage _ = Nothing
520
521x509cert :: SignatureSubpacket -> Maybe Char8.ByteString 437x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
522x509cert (NotationDataPacket 438x509cert (NotationDataPacket
523 { human_readable = False 439 { human_readable = False
@@ -526,167 +442,7 @@ x509cert (NotationDataPacket
526 }) = Just (Char8.pack u) 442 }) = Just (Char8.pack u)
527x509cert _ = Nothing 443x509cert _ = Nothing
528 444
529makeInducerSig
530 :: Packet
531 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
532-- torsig g topk wkun uid timestamp extras = todo
533makeInducerSig topk wkun uid extras
534 = CertificationSignature (secretToPublic topk)
535 uid
536 (sigpackets 0x13
537 subpackets
538 subpackets_unh)
539 where
540 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
541 tsign
542 ++ extras
543 subpackets_unh = [IssuerPacket (fingerprint wkun)]
544 tsign = if keykey wkun == keykey topk
545 then [] -- tsign doesnt make sense for self-signatures
546 else [ TrustSignaturePacket 1 120
547 , RegularExpressionPacket regex]
548 -- <[^>]+[@.]asdf\.nowhere>$
549 regex = "<[^>]+[@.]"++hostname++">$"
550 -- regex = username ++ "@" ++ hostname
551 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
552 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
553 pu = parseUID uidstr where UserIDPacket uidstr = uid
554 subdomain' = escape . T.unpack . uid_subdomain
555 topdomain' = escape . T.unpack . uid_topdomain
556 escape s = concatMap echar s
557 where
558 echar '|' = "\\|"
559 echar '*' = "\\*"
560 echar '+' = "\\+"
561 echar '?' = "\\?"
562 echar '.' = "\\."
563 echar '^' = "\\^"
564 echar '$' = "\\$"
565 echar '\\' = "\\\\"
566 echar '[' = "\\["
567 echar ']' = "\\]"
568 echar c = [c]
569
570
571keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
572keyflags flgs@(KeyFlagsPacket {}) =
573 Just . toEnum $
574 ( bit 0x1 certify_keys
575 .|. bit 0x2 sign_data
576 .|. bit 0x4 encrypt_communication
577 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
578 -- other flags:
579 -- split_key
580 -- authentication (ssh-client)
581 -- group_key
582 where
583 bit v f = if f flgs then v else 0
584keyflags _ = Nothing
585
586
587data PGPKeyFlags =
588 Special
589 | Vouch -- 0001 C -- Signkey
590 | Sign -- 0010 S
591 | VouchSign -- 0011
592 | Communication -- 0100 E
593 | VouchCommunication -- 0101
594 | SignCommunication -- 0110
595 | VouchSignCommunication -- 0111
596 | Storage -- 1000 E
597 | VouchStorage -- 1001
598 | SignStorage -- 1010
599 | VouchSignStorage -- 1011
600 | Encrypt -- 1100 E
601 | VouchEncrypt -- 1101
602 | SignEncrypt -- 1110
603 | VouchSignEncrypt -- 1111
604 deriving (Eq,Show,Read,Enum)
605
606
607usageString :: PGPKeyFlags -> String
608usageString flgs =
609 case flgs of
610 Special -> "special"
611 Vouch -> "vouch" -- signkey
612 Sign -> "sign"
613 VouchSign -> "vouch-sign"
614 Communication -> "communication"
615 VouchCommunication -> "vouch-communication"
616 SignCommunication -> "sign-communication"
617 VouchSignCommunication -> "vouch-sign-communication"
618 Storage -> "storage"
619 VouchStorage -> "vouch-storage"
620 SignStorage -> "sign-storage"
621 VouchSignStorage -> "vouch-sign-storage"
622 Encrypt -> "encrypt"
623 VouchEncrypt -> "vouch-encrypt"
624 SignEncrypt -> "sign-encrypt"
625 VouchSignEncrypt -> "vouch-sign-encrypt"
626
627
628
629
630keyFlags :: t -> [Packet] -> [SignatureSubpacket]
631keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
632
633keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
634keyFlags0 wkun uidsigs = concat
635 [ keyflags
636 , preferredsym
637 , preferredhash
638 , preferredcomp
639 , features ]
640 445
641 where
642 subs = concatMap hashed_subpackets uidsigs
643 keyflags = filterOr isflags subs $
644 KeyFlagsPacket { certify_keys = True
645 , sign_data = True
646 , encrypt_communication = False
647 , encrypt_storage = False
648 , split_key = False
649 , authentication = False
650 , group_key = False
651 }
652 preferredsym = filterOr ispreferedsym subs $
653 PreferredSymmetricAlgorithmsPacket
654 [ AES256
655 , AES192
656 , AES128
657 , CAST5
658 , TripleDES
659 ]
660 preferredhash = filterOr ispreferedhash subs $
661 PreferredHashAlgorithmsPacket
662 [ SHA256
663 , SHA1
664 , SHA384
665 , SHA512
666 , SHA224
667 ]
668 preferredcomp = filterOr ispreferedcomp subs $
669 PreferredCompressionAlgorithmsPacket
670 [ ZLIB
671 , BZip2
672 , ZIP
673 ]
674 features = filterOr isfeatures subs $
675 FeaturesPacket { supports_mdc = True
676 }
677
678 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
679
680 isflags (KeyFlagsPacket {}) = True
681 isflags _ = False
682 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
683 ispreferedsym _ = False
684 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
685 ispreferedhash _ = False
686 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
687 ispreferedcomp _ = False
688 isfeatures (FeaturesPacket {}) = True
689 isfeatures _ = False
690 446
691 447
692matchSpec :: KeySpec -> KeyData -> Bool 448matchSpec :: KeySpec -> KeyData -> Bool
@@ -710,36 +466,6 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
710 where 466 where
711 us = filter (isInfixOf pat) $ Map.keys uids 467 us = filter (isInfixOf pat) $ Map.keys uids
712 468
713data UserIDRecord = UserIDRecord {
714 uid_full :: String,
715 uid_realname :: T.Text,
716 uid_user :: T.Text,
717 uid_subdomain :: T.Text,
718 uid_topdomain :: T.Text
719}
720 deriving Show
721
722parseUID :: String -> UserIDRecord
723parseUID str = UserIDRecord {
724 uid_full = str,
725 uid_realname = realname,
726 uid_user = user,
727 uid_subdomain = subdomain,
728 uid_topdomain = topdomain
729 }
730 where
731 text = T.pack str
732 (T.strip-> realname, T.dropAround isBracket-> email)
733 = T.break (=='<') text
734 (user, T.drop 1-> hostname) = T.break (=='@') email
735 ( T.reverse -> topdomain,
736 T.reverse . T.drop 1 -> subdomain)
737 = T.break (=='.') . T.reverse $ hostname
738isBracket :: Char -> Bool
739isBracket '<' = True
740isBracket '>' = True
741isBracket _ = False
742
743 469
744 470
745 471
@@ -1532,32 +1258,6 @@ generateInternals transcode mwk db gens = do
1532 return $ KikiSuccess (Map.insert kk kd db,reportGens) 1258 return $ KikiSuccess (Map.insert kk kd db,reportGens)
1533 Nothing -> return $ KikiSuccess (db,[]) 1259 Nothing -> return $ KikiSuccess (db,[])
1534 1260
1535torhash :: Packet -> String
1536torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1537
1538torUIDFromKey :: Packet -> String
1539torUIDFromKey key = "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
1540
1541derToBase32 :: ByteString -> String
1542derToBase32 = map toLower . base32 . sha1
1543 where
1544 sha1 :: L.ByteString -> S.ByteString
1545#if !defined(VERSION_cryptonite)
1546 sha1 = SHA1.hashlazy
1547#else
1548 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1549#endif
1550#if defined(VERSION_memory)
1551 base32 = S8.unpack . convertToBase Base32
1552#elif defined(VERSION_dataenc)
1553 base32 = Base32.encode . S.unpack
1554#endif
1555
1556derRSA :: Packet -> Maybe ByteString
1557derRSA rsa = do
1558 k <- rsaKeyFromPacket rsa
1559 return $ encodeASN1 DER (toASN1 k [])
1560
1561unconditionally :: IO (KikiCondition a) -> IO a 1261unconditionally :: IO (KikiCondition a) -> IO a
1562unconditionally action = do 1262unconditionally action = do
1563 r <- action 1263 r <- action
@@ -1565,13 +1265,6 @@ unconditionally action = do
1565 KikiSuccess x -> return x 1265 KikiSuccess x -> return x
1566 e -> error $ errorString e 1266 e -> error $ errorString e
1567 1267
1568try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
1569try x body =
1570 case functorToEither x of
1571 Left e -> return e
1572 Right x -> body x
1573
1574
1575data ParsedCert = ParsedCert 1268data ParsedCert = ParsedCert
1576 { pcertKey :: Packet 1269 { pcertKey :: Packet
1577 , pcertTimestamp :: UTCTime 1270 , pcertTimestamp :: UTCTime
@@ -1982,42 +1675,6 @@ writeWalletKeys krd db wk = do
1982 report <- foldM writeWallet [] (files isMutableWallet) 1675 report <- foldM writeWallet [] (files isMutableWallet)
1983 return $ KikiSuccess report 1676 return $ KikiSuccess report
1984 1677
1985ifSecret :: Packet -> t -> t -> t
1986ifSecret (SecretKeyPacket {}) t f = t
1987ifSecret _ t f = f
1988
1989showPacket :: Packet -> String
1990showPacket p | isKey p = (if is_subkey p
1991 then showPacket0 p
1992 else ifSecret p "---Secret" "---Public")
1993 ++ " "++fingerprint p
1994 ++ " "++show (key_algorithm p)
1995 ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" }
1996 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1997 -- | isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p)
1998 | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p
1999 | otherwise = showPacket0 p
2000 where
2001 sigusage p =
2002 case take 1 (tagStrings p) of
2003 [] -> ""
2004 tag:_ -> " "++show tag -- "("++tag++")"
2005 where
2006 tagStrings p = usage_tags ++ flags
2007 where
2008 usage_tags = mapMaybe usage xs
2009 flags = mapMaybe (fmap usageString . keyflags) xs
2010 xs = hashed_subpackets p
2011
2012
2013showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
2014 where
2015 dropSuffix :: String -> String -> String
2016 dropSuffix _ [] = ""
2017 dropSuffix suff (x:xs) | (x:xs)==suff = ""
2018 | otherwise = x:dropSuffix suff xs
2019
2020
2021-- | returns Just True so as to indicate that 1678-- | returns Just True so as to indicate that
2022-- the public portions of keys will be imported 1679-- the public portions of keys will be imported
2023importPublic :: Maybe Bool 1680importPublic :: Maybe Bool
@@ -2312,75 +1969,6 @@ writePEMKeys doDecrypt db exports = do
2312 try pun $ \pun -> do 1969 try pun $ \pun -> do
2313 return $ KikiSuccess (fname,stream,pun) 1970 return $ KikiSuccess (fname,stream,pun)
2314 1971
2315performManipulations ::
2316 (PacketDecrypter)
2317 -> KeyRingRuntime
2318 -> Maybe MappedPacket
2319 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
2320 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
2321performManipulations doDecrypt rt wk manip = do
2322 let db = rtKeyDB rt
2323 performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
2324 r <- Traversable.mapM performAll db
2325 try (sequenceA r) $ \db -> do
2326 return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db)
2327 where
2328 perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
2329 perform kd (InducerSignature uid subpaks) = do
2330 try kd $ \(kd,report) -> do
2331 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
2332 wkun' <- doDecrypt wk'
2333 try wkun' $ \wkun -> do
2334 let flgs = if keykey (keyPacket kd) == keykey wkun
2335 then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
2336 else []
2337 sigOver = makeInducerSig (keyPacket kd)
2338 wkun
2339 (UserIDPacket uid)
2340 $ flgs ++ subpaks
2341 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
2342 toMappedPacket om p = (mappedPacket "" p) {locations=om}
2343 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
2344 . (== keykey whosign)
2345 . keykey)) vs
2346 keys = map keyPacket $ Map.elems (rtKeyDB rt)
2347 overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
2348 vs :: [ ( Packet -- signature
2349 , Maybe SignatureOver -- Nothing means non-verified
2350 , Packet ) -- key who signed
2351 ]
2352 vs = do
2353 x <- maybeToList $ Map.lookup uid (keyUids kd)
2354 sig <- map (packet . fst) (fst x)
2355 o <- overs sig
2356 k <- keys
2357 let ov = verify (Message [k]) $ o
2358 signatures_over ov
2359 return (sig,Just ov,k)
2360 additional new_sig = do
2361 new_sig <- maybeToList new_sig
2362 guard (null $ selfsigs)
2363 signatures_over new_sig
2364 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
2365 let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
2366 f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
2367 , om `Map.union` snd x )
2368 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
2369 return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
2370
2371 perform kd (SubKeyDeletion topk subk) = do
2372 try kd $ \(kd,report) -> do
2373 let kk = keykey $ packet $ keyMappedPacket kd
2374 kd' | kk /= topk = kd
2375 | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
2376 pred k _ = k /= subk
2377 ps = concat $ maybeToList $ do
2378 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
2379 return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs
2380 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
2381 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
2382 return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
2383
2384initializeMissingPEMFiles :: 1972initializeMissingPEMFiles ::
2385 KeyRingOperation 1973 KeyRingOperation
2386 -> InputFileContext 1974 -> InputFileContext
@@ -2503,150 +2091,7 @@ combineTransforms trans rt kd = updates
2503 concatMap (\t -> resolveTransform t rt kd) sanitized 2091 concatMap (\t -> resolveTransform t rt kd) sanitized
2504 sanitized = group (sort trans) >>= take 1 2092 sanitized = group (sort trans) >>= take 1
2505 2093
2506isSubkeySignature (SubkeySignature {}) = True
2507isSubkeySignature _ = False
2508
2509-- Returned data is simmilar to getBindings but the Word8 codes
2510-- are ORed together.
2511accBindings ::
2512 Bits t =>
2513 [(t, (Packet, Packet), [a], [a1], [a2])]
2514 -> [(t, (Packet, Packet), [a], [a1], [a2])]
2515accBindings bs = as
2516 where
2517 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
2518 as = map (foldl1 combine) gs
2519 bindingPair (_,p,_,_,_) = pub2 p
2520 where
2521 pub2 (a,b) = (pub a, pub b)
2522 pub a = fingerprint_material a
2523 samePair a b = bindingPair a == bindingPair b
2524 combine (ac,p,akind,ahashed,aclaimaints)
2525 (bc,_,bkind,bhashed,bclaimaints)
2526 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
2527
2528
2529
2530verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
2531 where
2532 verified = do
2533 sig <- signatures (Message nonkeys)
2534 let v = verify (Message keys) sig
2535 guard (not . null $ signatures_over v)
2536 return v
2537 (top,othersigs) = partition isSubkeySignature verified
2538 embedded = do
2539 sub <- top
2540 let sigover = signatures_over sub
2541 unhashed = sigover >>= unhashed_subpackets
2542 subsigs = mapMaybe backsig unhashed
2543 -- This should consist only of 0x19 values
2544 -- subtypes = map signature_type subsigs
2545 -- trace ("subtypes = "++show subtypes) (return ())
2546 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
2547 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
2548 let v = verify (Message [subkey sub]) sig
2549 guard (not . null $ signatures_over v)
2550 return v
2551
2552smallpr k = drop 24 $ fingerprint k
2553
2554disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
2555 where
2556 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
2557 samepr a b = smallpr a == smallpr b
2558
2559 {-
2560 -- useful for testing
2561 group2 :: [a] -> [[a]]
2562 group2 (x:y:ys) = [x,y]:group2 ys
2563 group2 [x] = [[x]]
2564 group2 [] = []
2565 -}
2566
2567 2094
2568getBindings ::
2569 [Packet]
2570 ->
2571 ( [([Packet],[SignatureOver])] -- other signatures with key sets
2572 -- that were used for the verifications
2573 , [(Word8,
2574 (Packet, Packet), -- (topkey,subkey)
2575 [String], -- usage flags
2576 [SignatureSubpacket], -- hashed data
2577 [Packet])] -- binding signatures
2578 )
2579getBindings pkts = (sigs,bindings)
2580 where
2581 (sigs,concat->bindings) = unzip $ do
2582 let (keys,_) = partition isKey pkts
2583 keys <- disjoint_fp keys
2584 let (bs,sigs) = verifyBindings keys pkts
2585 return . ((keys,sigs),) $ do
2586 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
2587 i <- map signature_issuer (signatures_over b)
2588 i <- maybeToList i
2589 who <- maybeToList $ find_key fingerprint (Message keys) i
2590 let (code,claimants) =
2591 case () of
2592 _ | who == topkey b -> (1,[])
2593 _ | who == subkey b -> (2,[])
2594 _ -> (0,[who])
2595 let hashed = signatures_over b >>= hashed_subpackets
2596 kind = guard (code==1) >> hashed >>= maybeToList . usage
2597 return (code,(topkey b,subkey b), kind, hashed,claimants)
2598
2599-- | resolveTransform
2600resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2601resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
2602 where
2603 ops = map (\u -> InducerSignature u []) us
2604 us = filter torStyle $ Map.keys umap
2605 torStyle str = and [ uid_topdomain parsed == "onion"
2606 , uid_realname parsed `elem` ["","Anonymous"]
2607 , uid_user parsed == "root"
2608 , fmap (match . fst) (lookup (packet k) torbindings)
2609 == Just True ]
2610 where parsed = parseUID str
2611 match = (==subdom) . take (fromIntegral len)
2612 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
2613 subdom = Char8.unpack subdom0
2614 len = T.length (uid_subdomain parsed)
2615 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
2616 getTorKeys pub = do
2617 xs <- groupBindings pub
2618 (_,(top,sub),us,_,_) <- xs
2619 guard ("tor" `elem` us)
2620 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
2621 return (top,(torhash,sub))
2622
2623 groupBindings pub = gs
2624 where (_,bindings) = getBindings pub
2625 bindings' = accBindings bindings
2626 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
2627 ownerkey (_,(a,_),_,_,_) = a
2628 sameMaster (ownerkey->a) (ownerkey->b)
2629 = fingerprint_material a==fingerprint_material b
2630 gs = groupBy sameMaster (sortBy (comparing code) bindings')
2631
2632
2633-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2634resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
2635 where
2636 topk = keykey $ packet k -- key to master of key to be deleted
2637 subk = do
2638 (k,sub) <- Map.toList submap
2639 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
2640 return k
2641
2642-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2643resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
2644 where
2645 topk = keykey $ packet k -- key to master of key to be deleted
2646 subk = do
2647 (k,SubKey p sigs) <- Map.toList submap
2648 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
2649 return k
2650 2095
2651-- | Load and update key files according to the specified 'KeyRingOperation'. 2096-- | Load and update key files according to the specified 'KeyRingOperation'.
2652runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) 2097runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
@@ -2790,36 +2235,6 @@ lookupEnv var =
2790 handleIO_ (return Nothing) $ fmap Just (getEnv var) 2235 handleIO_ (return Nothing) $ fmap Just (getEnv var)
2791#endif 2236#endif
2792 2237
2793sigpackets ::
2794 Monad m =>
2795 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
2796sigpackets typ hashed unhashed = return $
2797 signaturePacket
2798 4 -- version
2799 typ -- 0x18 subkey binding sig, or 0x19 back-signature
2800 RSA
2801 SHA1
2802 hashed
2803 unhashed
2804 0 -- Word16 -- Left 16 bits of the signed hash value
2805 [] -- [MPI]
2806
2807secretToPublic :: Packet -> Packet
2808secretToPublic pkt@(SecretKeyPacket {}) =
2809 PublicKeyPacket { version = version pkt
2810 , timestamp = timestamp pkt
2811 , key_algorithm = key_algorithm pkt
2812 -- , ecc_curve = ecc_curve pkt
2813 , key = let seckey = key pkt
2814 pubs = public_key_fields (key_algorithm pkt)
2815 in filter (\(k,v) -> k `elem` pubs) seckey
2816 , is_subkey = is_subkey pkt
2817 , v3_days_of_validity = Nothing
2818 }
2819secretToPublic pkt = pkt
2820
2821
2822
2823slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) 2238slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
2824slurpWIPKeys stamp "" = ([],[]) 2239slurpWIPKeys stamp "" = ([],[])
2825slurpWIPKeys stamp cs = 2240slurpWIPKeys stamp cs =
@@ -2878,14 +2293,6 @@ decode_btc_key timestamp str = do
2878 , is_subkey = True 2293 , is_subkey = True
2879 } 2294 }
2880 2295
2881rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
2882rsaKeyFromPacket p | isKey p = do
2883 n <- lookup 'n' $ key p
2884 e <- lookup 'e' $ key p
2885 return $ RSAKey n e
2886
2887rsaKeyFromPacket _ = Nothing
2888
2889 2296
2890readPacketsFromWallet :: 2297readPacketsFromWallet ::
2891 Maybe Packet 2298 Maybe Packet
@@ -3111,26 +2518,6 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
3111 newsig <- addOrigin new_sig 2518 newsig <- addOrigin new_sig
3112 return $ fmap (,[]) newsig 2519 return $ fmap (,[]) newsig
3113 2520
3114
3115type TrustMap = Map.Map FilePath Packet
3116type SigAndTrust = ( MappedPacket
3117 , TrustMap ) -- trust packets
3118
3119data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
3120
3121-- | This is a GPG Identity which includes a master key and all its UIDs and
3122-- subkeys and associated signatures.
3123data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key
3124 , keySigAndTrusts :: [SigAndTrust] -- sigs on main key
3125 , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
3126 , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
3127 } deriving Show
3128
3129type KeyDB = Map.Map KeyKey KeyData
3130
3131uidkey :: Packet -> String
3132uidkey (UserIDPacket str) = str
3133
3134merge :: KeyDB -> InputFile -> Message -> KeyDB 2521merge :: KeyDB -> InputFile -> Message -> KeyDB
3135merge db inputfile (Message ps) = merge_ db filename qs 2522merge db inputfile (Message ps) = merge_ db filename qs
3136 where 2523 where
@@ -3298,24 +2685,6 @@ mergeSig sig sigs =
3298 mergeSameSig a b = b -- trace ("discarding dup "++show a) b 2685 mergeSameSig a b = b -- trace ("discarding dup "++show a) b
3299 2686
3300 2687
3301unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
3302unsig fname isPublic (sig,trustmap) =
3303 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
3304 where
3305 f n _ = n==fname -- && trace ("fname=n="++show n) True
3306 asMapped n p = let m = mappedPacket fname p
3307 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
3308
3309concatSort ::
3310 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
3311concatSort fname getp f = concat . sortByHint fname getp . map f
3312
3313sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
3314sortByHint fname f = sortBy (comparing gethint)
3315 where
3316 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
3317 defnum = -1
3318
3319flattenKeys :: Bool -> KeyDB -> Message 2688flattenKeys :: Bool -> KeyDB -> Message
3320flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) 2689flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
3321 where 2690 where
@@ -3329,27 +2698,6 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl
3329 isSecret _ = False 2698 isSecret _ = False
3330 2699
3331 2700
3332flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
3333flattenTop fname ispub (KeyData key sigs uids subkeys) =
3334 unk ispub key :
3335 ( flattenAllUids fname ispub uids
3336 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
3337
3338flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
3339flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
3340
3341unk :: Bool -> MappedPacket -> MappedPacket
3342unk isPublic = if isPublic then toPacket secretToPublic else id
3343 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
3344
3345flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
3346flattenAllUids fname ispub uids =
3347 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
3348
3349flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
3350flattenUid fname ispub (str,(sigs,om)) =
3351 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
3352
3353data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned 2701data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
3354 deriving (Eq,Ord,Enum,Show,Read) 2702 deriving (Eq,Ord,Enum,Show,Read)
3355 2703
@@ -3384,11 +2732,6 @@ getSubkeys ck topk subs tag = do
3384 guard (not $ null sigs') 2732 guard (not $ null sigs')
3385 return subk 2733 return subk
3386 2734
3387has_tag tag p = isSignaturePacket p
3388 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
3389 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
3390
3391
3392-- | 2735-- |
3393-- Returns (ip6 fingerprint address,(onion names,other host names)) 2736-- Returns (ip6 fingerprint address,(onion names,other host names))
3394-- 2737--
@@ -3494,10 +2837,6 @@ fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
3494 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs 2837 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
3495 colons xs = xs 2838 colons xs = xs
3496 2839
3497backsig :: SignatureSubpacket -> Maybe Packet
3498backsig (EmbeddedSignaturePacket s) = Just s
3499backsig _ = Nothing
3500
3501socketFamily :: SockAddr -> Family 2840socketFamily :: SockAddr -> Family
3502socketFamily (SockAddrInet _ _) = AF_INET 2841socketFamily (SockAddrInet _ _) = AF_INET
3503socketFamily (SockAddrInet6 {}) = AF_INET6 2842socketFamily (SockAddrInet6 {}) = AF_INET6
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
new file mode 100644
index 0000000..093d594
--- /dev/null
+++ b/lib/Transforms.hs
@@ -0,0 +1,738 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE OverloadedStrings #-}
5module Transforms where
6
7import Control.Monad
8import Data.Char
9import Data.List
10import Data.Maybe
11import Data.Ord
12import Data.OpenPGP
13import Data.OpenPGP.Util
14import Data.Word (Word8)
15import Types
16import FunctorToMaybe
17import GnuPGAgent ( key_nbits )
18import PacketTranscoder
19import qualified Data.Traversable as Traversable
20import qualified Data.ByteString as S
21import qualified Data.ByteString.Lazy as L
22import qualified Data.ByteString.Lazy.Char8 as Char8
23import qualified Data.Map.Strict as Map
24#if defined(VERSION_memory)
25import qualified Data.ByteString.Char8 as S8
26import Data.ByteArray.Encoding
27#elif defined(VERSION_dataenc)
28import qualified Codec.Binary.Base32 as Base32
29import qualified Codec.Binary.Base64 as Base64
30#endif
31#if !defined(VERSION_cryptonite)
32import qualified Crypto.Hash.SHA1 as SHA1
33import qualified Crypto.Types.PubKey.ECC as ECC
34#else
35import qualified Crypto.Hash as Vincent
36import Data.ByteArray (convert)
37import qualified Crypto.PubKey.ECC.Types as ECC
38#endif
39import Data.ASN1.BinaryEncoding ( DER(..) )
40import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
41 , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
42import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
43import qualified Data.Text as T ( Text, unpack, pack,
44 strip, reverse, drop, break, dropAround, length )
45import Data.Text.Encoding ( encodeUtf8 )
46import Data.Bits ( (.|.), (.&.), Bits, shiftR )
47
48type TrustMap = Map.Map FilePath Packet
49type SigAndTrust = ( MappedPacket
50 , TrustMap ) -- trust packets
51data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
52
53-- | This is a GPG Identity which includes a master key and all its UIDs and
54-- subkeys and associated signatures.
55data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key
56 , keySigAndTrusts :: [SigAndTrust] -- sigs on main key
57 , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
58 , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
59 } deriving Show
60type KeyDB = Map.Map KeyKey KeyData
61
62
63
64data KeyRingRuntime = KeyRingRuntime
65 { rtPubring :: FilePath
66 -- ^ Path to the file represented by 'HomePub'
67 , rtSecring :: FilePath
68 -- ^ Path to the file represented by 'HomeSec'
69 , rtGrip :: Maybe String
70 -- ^ Fingerprint or portion of a fingerprint used
71 -- to identify the working GnuPG identity used to
72 -- make signatures.
73 , rtWorkingKey :: Maybe Packet
74 -- ^ The master key of the working GnuPG identity.
75 , rtKeyDB :: KeyDB
76 -- ^ The common information pool where files spilled
77 -- their content and from which they received new
78 -- content.
79 , rtRingAccess :: Map.Map InputFile Access
80 -- ^ The 'Access' values used for files of type
81 -- 'KeyRingFile'. If 'AutoAccess' was specified
82 -- for a file, this 'Map.Map' will indicate the
83 -- detected value that was used by the algorithm.
84 , rtPassphrases :: PacketTranscoder
85 }
86
87
88-- | Roster-entry level actions
89data PacketUpdate = InducerSignature String [SignatureSubpacket]
90 | SubKeyDeletion KeyKey KeyKey
91
92data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
93
94instance ASN1Object RSAPublicKey where
95 -- PKCS #1 RSA Public Key
96 toASN1 (RSAKey (MPI n) (MPI e))
97 = \xs -> Start Sequence
98 : IntVal n
99 : IntVal e
100 : End Sequence
101 : xs
102 fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
103 Right (RSAKey (MPI n) (MPI e), xs)
104
105 fromASN1 _ =
106 Left "fromASN1: RSAPublicKey: unexpected format"
107
108
109-- | This type is used to describe events triggered by 'runKeyRing'. In
110-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
111-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a
112-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
113-- many inputs and outputs, an operation may be partially (or even mostly)
114-- successful even when I/O failures occured. In this situation, the files may
115-- not have all the information they were intended to store, but they will be
116-- in a valid format for GnuPG or kiki to operate on in the future.
117data KikiReportAction =
118 NewPacket String
119 | MissingPacket String
120 | ExportedSubkey
121 | GeneratedSubkeyFile
122 | NewWalletKey String
123 | YieldSignature
124 | YieldSecretKeyPacket String
125 | UnableToUpdateExpiredSignature
126 | WarnFailedToMakeSignature
127 | FailedExternal Int
128 | ExternallyGeneratedFile
129 | UnableToExport KeyAlgorithm String
130 | FailedFileWrite
131 | HostsDiff L.ByteString
132 | DeletedPacket String
133 deriving (Eq,Show)
134
135type KikiReport = [ (FilePath, KikiReportAction) ]
136
137data UserIDRecord = UserIDRecord {
138 uid_full :: String,
139 uid_realname :: T.Text,
140 uid_user :: T.Text,
141 uid_subdomain :: T.Text,
142 uid_topdomain :: T.Text
143}
144 deriving Show
145
146data PGPKeyFlags =
147 Special
148 | Vouch -- 0001 C -- Signkey
149 | Sign -- 0010 S
150 | VouchSign -- 0011
151 | Communication -- 0100 E
152 | VouchCommunication -- 0101
153 | SignCommunication -- 0110
154 | VouchSignCommunication -- 0111
155 | Storage -- 1000 E
156 | VouchStorage -- 1001
157 | SignStorage -- 1010
158 | VouchSignStorage -- 1011
159 | Encrypt -- 1100 E
160 | VouchEncrypt -- 1101
161 | SignEncrypt -- 1110
162 | VouchSignEncrypt -- 1111
163 deriving (Eq,Show,Read,Enum)
164
165
166
167-- Functions
168
169unk :: Bool -> MappedPacket -> MappedPacket
170unk isPublic = if isPublic then toPacket secretToPublic else id
171 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
172
173
174unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
175unsig fname isPublic (sig,trustmap) =
176 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
177 where
178 f n _ = n==fname -- && trace ("fname=n="++show n) True
179 asMapped n p = let m = mappedPacket fname p
180 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
181
182smallpr k = drop 24 $ fingerprint k
183
184backsig :: SignatureSubpacket -> Maybe Packet
185backsig (EmbeddedSignaturePacket s) = Just s
186backsig _ = Nothing
187
188
189isSubkeySignature (SubkeySignature {}) = True
190isSubkeySignature _ = False
191
192
193has_tag tag p = isSignaturePacket p
194 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
195 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
196
197
198
199verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
200 where
201 verified = do
202 sig <- signatures (Message nonkeys)
203 let v = verify (Message keys) sig
204 guard (not . null $ signatures_over v)
205 return v
206 (top,othersigs) = partition isSubkeySignature verified
207 embedded = do
208 sub <- top
209 let sigover = signatures_over sub
210 unhashed = sigover >>= unhashed_subpackets
211 subsigs = mapMaybe backsig unhashed
212 -- This should consist only of 0x19 values
213 -- subtypes = map signature_type subsigs
214 -- trace ("subtypes = "++show subtypes) (return ())
215 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
216 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
217 let v = verify (Message [subkey sub]) sig
218 guard (not . null $ signatures_over v)
219 return v
220
221
222disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
223 where
224 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
225 samepr a b = smallpr a == smallpr b
226
227 {-
228 -- useful for testing
229 group2 :: [a] -> [[a]]
230 group2 (x:y:ys) = [x,y]:group2 ys
231 group2 [x] = [[x]]
232 group2 [] = []
233 -}
234
235
236
237subkeyMappedPacket :: SubKey -> MappedPacket
238subkeyMappedPacket (SubKey k _ ) = k
239
240getBindings ::
241 [Packet]
242 ->
243 ( [([Packet],[SignatureOver])] -- other signatures with key sets
244 -- that were used for the verifications
245 , [(Word8,
246 (Packet, Packet), -- (topkey,subkey)
247 [String], -- usage flags
248 [SignatureSubpacket], -- hashed data
249 [Packet])] -- binding signatures
250 )
251getBindings pkts = (sigs,bindings)
252 where
253 (sigs,concat->bindings) = unzip $ do
254 let (keys,_) = partition isKey pkts
255 keys <- disjoint_fp keys
256 let (bs,sigs) = verifyBindings keys pkts
257 return . ((keys,sigs),) $ do
258 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
259 i <- map signature_issuer (signatures_over b)
260 i <- maybeToList i
261 who <- maybeToList $ find_key fingerprint (Message keys) i
262 let (code,claimants) =
263 case () of
264 _ | who == topkey b -> (1,[])
265 _ | who == subkey b -> (2,[])
266 _ -> (0,[who])
267 let hashed = signatures_over b >>= hashed_subpackets
268 kind = guard (code==1) >> hashed >>= maybeToList . usage
269 return (code,(topkey b,subkey b), kind, hashed,claimants)
270
271
272-- Returned data is simmilar to getBindings but the Word8 codes
273-- are ORed together.
274accBindings ::
275 Bits t =>
276 [(t, (Packet, Packet), [a], [a1], [a2])]
277 -> [(t, (Packet, Packet), [a], [a1], [a2])]
278accBindings bs = as
279 where
280 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
281 as = map (foldl1 combine) gs
282 bindingPair (_,p,_,_,_) = pub2 p
283 where
284 pub2 (a,b) = (pub a, pub b)
285 pub a = fingerprint_material a
286 samePair a b = bindingPair a == bindingPair b
287 combine (ac,p,akind,ahashed,aclaimaints)
288 (bc,_,bkind,bhashed,bclaimaints)
289 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
290
291sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
292sortByHint fname f = sortBy (comparing gethint)
293 where
294 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
295 defnum = -1
296
297concatSort ::
298 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
299concatSort fname getp f = concat . sortByHint fname getp . map f
300
301flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
302flattenUid fname ispub (str,(sigs,om)) =
303 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
304
305flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
306flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
307
308flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
309flattenAllUids fname ispub uids =
310 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
311
312flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
313flattenTop fname ispub (KeyData key sigs uids subkeys) =
314 unk ispub key :
315 ( flattenAllUids fname ispub uids
316 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
317
318
319sigpackets ::
320 Monad m =>
321 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
322sigpackets typ hashed unhashed = return $
323 signaturePacket
324 4 -- version
325 typ -- 0x18 subkey binding sig, or 0x19 back-signature
326 RSA
327 SHA1
328 hashed
329 unhashed
330 0 -- Word16 -- Left 16 bits of the signed hash value
331 [] -- [MPI]
332
333
334
335keyFlags :: t -> [Packet] -> [SignatureSubpacket]
336keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
337
338-- XXX keyFlags and keyflags are different functions.
339keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
340keyflags flgs@(KeyFlagsPacket {}) =
341 Just . toEnum $
342 ( bit 0x1 certify_keys
343 .|. bit 0x2 sign_data
344 .|. bit 0x4 encrypt_communication
345 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
346 -- other flags:
347 -- split_key
348 -- authentication (ssh-client)
349 -- group_key
350 where
351 bit v f = if f flgs then v else 0
352keyflags _ = Nothing
353
354
355
356secretToPublic :: Packet -> Packet
357secretToPublic pkt@(SecretKeyPacket {}) =
358 PublicKeyPacket { version = version pkt
359 , timestamp = timestamp pkt
360 , key_algorithm = key_algorithm pkt
361 -- , ecc_curve = ecc_curve pkt
362 , key = let seckey = key pkt
363 pubs = public_key_fields (key_algorithm pkt)
364 in filter (\(k,v) -> k `elem` pubs) seckey
365 , is_subkey = is_subkey pkt
366 , v3_days_of_validity = Nothing
367 }
368secretToPublic pkt = pkt
369
370
371
372uidkey :: Packet -> String
373uidkey (UserIDPacket str) = str
374
375usageString :: PGPKeyFlags -> String
376usageString flgs =
377 case flgs of
378 Special -> "special"
379 Vouch -> "vouch" -- signkey
380 Sign -> "sign"
381 VouchSign -> "vouch-sign"
382 Communication -> "communication"
383 VouchCommunication -> "vouch-communication"
384 SignCommunication -> "sign-communication"
385 VouchSignCommunication -> "vouch-sign-communication"
386 Storage -> "storage"
387 VouchStorage -> "vouch-storage"
388 SignStorage -> "sign-storage"
389 VouchSignStorage -> "vouch-sign-storage"
390 Encrypt -> "encrypt"
391 VouchEncrypt -> "vouch-encrypt"
392 SignEncrypt -> "sign-encrypt"
393 VouchSignEncrypt -> "vouch-sign-encrypt"
394
395
396
397usage :: SignatureSubpacket -> Maybe String
398usage (NotationDataPacket
399 { human_readable = True
400 , notation_name = "usage@"
401 , notation_value = u
402 }) = Just u
403usage _ = Nothing
404
405
406ifSecret :: Packet -> t -> t -> t
407ifSecret (SecretKeyPacket {}) t f = t
408ifSecret _ t f = f
409
410
411showPacket :: Packet -> String
412showPacket p | isKey p = (if is_subkey p
413 then showPacket0 p
414 else ifSecret p "---Secret" "---Public")
415 ++ " "++fingerprint p
416 ++ " "++show (key_algorithm p)
417 ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" }
418 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
419 -- | isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p)
420 | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p
421 | otherwise = showPacket0 p
422 where
423 sigusage p =
424 case take 1 (tagStrings p) of
425 [] -> ""
426 tag:_ -> " "++show tag -- "("++tag++")"
427 where
428 tagStrings p = usage_tags ++ flags
429 where
430 usage_tags = mapMaybe usage xs
431 flags = mapMaybe (fmap usageString . keyflags) xs
432 xs = hashed_subpackets p
433
434
435showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
436 where
437 dropSuffix :: String -> String -> String
438 dropSuffix _ [] = ""
439 dropSuffix suff (x:xs) | (x:xs)==suff = ""
440 | otherwise = x:dropSuffix suff xs
441
442
443
444makeInducerSig
445 :: Packet
446 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
447-- torsig g topk wkun uid timestamp extras = todo
448makeInducerSig topk wkun uid extras
449 = CertificationSignature (secretToPublic topk)
450 uid
451 (sigpackets 0x13
452 subpackets
453 subpackets_unh)
454 where
455 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
456 tsign
457 ++ extras
458 subpackets_unh = [IssuerPacket (fingerprint wkun)]
459 tsign = if keykey wkun == keykey topk
460 then [] -- tsign doesnt make sense for self-signatures
461 else [ TrustSignaturePacket 1 120
462 , RegularExpressionPacket regex]
463 -- <[^>]+[@.]asdf\.nowhere>$
464 regex = "<[^>]+[@.]"++hostname++">$"
465 -- regex = username ++ "@" ++ hostname
466 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
467 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
468 pu = parseUID uidstr where UserIDPacket uidstr = uid
469 subdomain' = escape . T.unpack . uid_subdomain
470 topdomain' = escape . T.unpack . uid_topdomain
471 escape s = concatMap echar s
472 where
473 echar '|' = "\\|"
474 echar '*' = "\\*"
475 echar '+' = "\\+"
476 echar '?' = "\\?"
477 echar '.' = "\\."
478 echar '^' = "\\^"
479 echar '$' = "\\$"
480 echar '\\' = "\\\\"
481 echar '[' = "\\["
482 echar ']' = "\\]"
483 echar c = [c]
484
485
486keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
487keyFlags0 wkun uidsigs = concat
488 [ keyflags
489 , preferredsym
490 , preferredhash
491 , preferredcomp
492 , features ]
493
494 where
495 subs = concatMap hashed_subpackets uidsigs
496 keyflags = filterOr isflags subs $
497 KeyFlagsPacket { certify_keys = True
498 , sign_data = True
499 , encrypt_communication = False
500 , encrypt_storage = False
501 , split_key = False
502 , authentication = False
503 , group_key = False
504 }
505 preferredsym = filterOr ispreferedsym subs $
506 PreferredSymmetricAlgorithmsPacket
507 [ AES256
508 , AES192
509 , AES128
510 , CAST5
511 , TripleDES
512 ]
513 preferredhash = filterOr ispreferedhash subs $
514 PreferredHashAlgorithmsPacket
515 [ SHA256
516 , SHA1
517 , SHA384
518 , SHA512
519 , SHA224
520 ]
521 preferredcomp = filterOr ispreferedcomp subs $
522 PreferredCompressionAlgorithmsPacket
523 [ ZLIB
524 , BZip2
525 , ZIP
526 ]
527 features = filterOr isfeatures subs $
528 FeaturesPacket { supports_mdc = True
529 }
530
531 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
532
533 isflags (KeyFlagsPacket {}) = True
534 isflags _ = False
535 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
536 ispreferedsym _ = False
537 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
538 ispreferedhash _ = False
539 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
540 ispreferedcomp _ = False
541 isfeatures (FeaturesPacket {}) = True
542 isfeatures _ = False
543
544
545
546keyPacket :: KeyData -> Packet
547keyPacket (KeyData k _ _ _) = packet k
548
549
550rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
551rsaKeyFromPacket p | isKey p = do
552 n <- lookup 'n' $ key p
553 e <- lookup 'e' $ key p
554 return $ RSAKey n e
555
556rsaKeyFromPacket _ = Nothing
557
558
559torhash :: Packet -> String
560torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
561
562torUIDFromKey :: Packet -> String
563torUIDFromKey key = "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
564
565derToBase32 :: L.ByteString -> String
566derToBase32 = map toLower . base32 . sha1
567 where
568 sha1 :: L.ByteString -> S.ByteString
569#if !defined(VERSION_cryptonite)
570 sha1 = SHA1.hashlazy
571#else
572 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
573#endif
574#if defined(VERSION_memory)
575 base32 = S8.unpack . convertToBase Base32
576#elif defined(VERSION_dataenc)
577 base32 = Base32.encode . S.unpack
578#endif
579
580derRSA :: Packet -> Maybe L.ByteString
581derRSA rsa = do
582 k <- rsaKeyFromPacket rsa
583 return $ encodeASN1 DER (toASN1 k [])
584
585try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
586try x body =
587 case functorToEither x of
588 Left e -> return e
589 Right x -> body x
590
591
592
593
594performManipulations ::
595 (PacketDecrypter)
596 -> KeyRingRuntime
597 -> Maybe MappedPacket
598 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
599 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
600performManipulations doDecrypt rt wk manip = do
601 let db = rtKeyDB rt
602 performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
603 r <- Traversable.mapM performAll db
604 try (sequenceA r) $ \db -> do
605 return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db)
606 where
607 perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
608 perform kd (InducerSignature uid subpaks) = do
609 try kd $ \(kd,report) -> do
610 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
611 wkun' <- doDecrypt wk'
612 try wkun' $ \wkun -> do
613 let flgs = if keykey (keyPacket kd) == keykey wkun
614 then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
615 else []
616 sigOver = makeInducerSig (keyPacket kd)
617 wkun
618 (UserIDPacket uid)
619 $ flgs ++ subpaks
620 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
621 toMappedPacket om p = (mappedPacket "" p) {locations=om}
622 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
623 . (== keykey whosign)
624 . keykey)) vs
625 keys = map keyPacket $ Map.elems (rtKeyDB rt)
626 overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
627 vs :: [ ( Packet -- signature
628 , Maybe SignatureOver -- Nothing means non-verified
629 , Packet ) -- key who signed
630 ]
631 vs = do
632 x <- maybeToList $ Map.lookup uid (keyUids kd)
633 sig <- map (packet . fst) (fst x)
634 o <- overs sig
635 k <- keys
636 let ov = verify (Message [k]) $ o
637 signatures_over ov
638 return (sig,Just ov,k)
639 additional new_sig = do
640 new_sig <- maybeToList new_sig
641 guard (null $ selfsigs)
642 signatures_over new_sig
643 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
644 let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
645 f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
646 , om `Map.union` snd x )
647 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
648 return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
649
650 perform kd (SubKeyDeletion topk subk) = do
651 try kd $ \(kd,report) -> do
652 let kk = keykey $ packet $ keyMappedPacket kd
653 kd' | kk /= topk = kd
654 | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
655 pred k _ = k /= subk
656 ps = concat $ maybeToList $ do
657 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
658 return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs
659 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
660 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
661 return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
662
663isBracket :: Char -> Bool
664isBracket '<' = True
665isBracket '>' = True
666isBracket _ = False
667
668
669parseUID :: String -> UserIDRecord
670parseUID str = UserIDRecord {
671 uid_full = str,
672 uid_realname = realname,
673 uid_user = user,
674 uid_subdomain = subdomain,
675 uid_topdomain = topdomain
676 }
677 where
678 text = T.pack str
679 (T.strip-> realname, T.dropAround isBracket-> email)
680 = T.break (=='<') text
681 (user, T.drop 1-> hostname) = T.break (=='@') email
682 ( T.reverse -> topdomain,
683 T.reverse . T.drop 1 -> subdomain)
684 = T.break (=='.') . T.reverse $ hostname
685
686-- | resolveTransform
687resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
688resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
689 where
690 ops = map (\u -> InducerSignature u []) us
691 us = filter torStyle $ Map.keys umap
692 torStyle str = and [ uid_topdomain parsed == "onion"
693 , uid_realname parsed `elem` ["","Anonymous"]
694 , uid_user parsed == "root"
695 , fmap (match . fst) (lookup (packet k) torbindings)
696 == Just True ]
697 where parsed = parseUID str
698 match = (==subdom) . take (fromIntegral len)
699 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
700 subdom = Char8.unpack subdom0
701 len = T.length (uid_subdomain parsed)
702 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
703 getTorKeys pub = do
704 xs <- groupBindings pub
705 (_,(top,sub),us,_,_) <- xs
706 guard ("tor" `elem` us)
707 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
708 return (top,(torhash,sub))
709
710 groupBindings pub = gs
711 where (_,bindings) = getBindings pub
712 bindings' = accBindings bindings
713 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
714 ownerkey (_,(a,_),_,_,_) = a
715 sameMaster (ownerkey->a) (ownerkey->b)
716 = fingerprint_material a==fingerprint_material b
717 gs = groupBy sameMaster (sortBy (comparing code) bindings')
718
719
720-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
721resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
722 where
723 topk = keykey $ packet k -- key to master of key to be deleted
724 subk = do
725 (k,sub) <- Map.toList submap
726 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
727 return k
728
729-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
730resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
731 where
732 topk = keykey $ packet k -- key to master of key to be deleted
733 subk = do
734 (k,SubKey p sigs) <- Map.toList submap
735 -- TODO: This should warn/fail when there are multiple matches.
736 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
737 return k
738
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:31:39 +0000