diff options
Diffstat (limited to 'keys.hs')
-rw-r--r-- | keys.hs | 173 |
1 files changed, 164 insertions, 9 deletions
@@ -27,6 +27,7 @@ import qualified Codec.Binary.Base32 as Base32 | |||
27 | import qualified Crypto.Hash.SHA1 as SHA1 | 27 | import qualified Crypto.Hash.SHA1 as SHA1 |
28 | import Data.Char (toLower) | 28 | import Data.Char (toLower) |
29 | import qualified Crypto.PubKey.RSA as RSA | 29 | import qualified Crypto.PubKey.RSA as RSA |
30 | import Crypto.Random (newGenIO,SystemRandom) | ||
30 | import Data.ASN1.Types | 31 | import Data.ASN1.Types |
31 | import Data.ASN1.Encoding | 32 | import Data.ASN1.Encoding |
32 | import Data.ASN1.BinaryEncoding | 33 | import Data.ASN1.BinaryEncoding |
@@ -138,15 +139,23 @@ disjoint_fp ks = {- concatMap group2 $ -} transpose grouped | |||
138 | group2 [] = [] | 139 | group2 [] = [] |
139 | -} | 140 | -} |
140 | 141 | ||
142 | verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures) | ||
143 | verifyBindingsEx pkts = bicat . unzip $ do | ||
144 | let (keys,_) = partition isKey pkts | ||
145 | keys <- disjoint_fp keys | ||
146 | return $ verifyBindings keys pkts | ||
147 | where | ||
148 | bicat (xs,ys) = (concat xs,concat ys) | ||
149 | |||
141 | getBindings :: | 150 | getBindings :: |
142 | [Packet] | 151 | [Packet] |
143 | -> | 152 | -> |
144 | ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets | 153 | ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets |
145 | -- that were used for the verifications | 154 | -- that were used for the verifications |
146 | , [(Word8, | 155 | , [(Word8, |
147 | (Packet, Packet), | 156 | (Packet, Packet), -- (topkey,subkey) |
148 | [String], | 157 | [String], -- usage flags |
149 | [SignatureSubpacket], | 158 | [SignatureSubpacket], -- hashed data |
150 | [Packet])] -- ^ binding signatures | 159 | [Packet])] -- ^ binding signatures |
151 | ) | 160 | ) |
152 | getBindings pkts = (sigs,bindings) | 161 | getBindings pkts = (sigs,bindings) |
@@ -169,6 +178,8 @@ getBindings pkts = (sigs,bindings) | |||
169 | kind = guard (code==1) >> hashed >>= maybeToList . usage | 178 | kind = guard (code==1) >> hashed >>= maybeToList . usage |
170 | return (code,(topkey b,subkey b), kind, hashed,claimants) | 179 | return (code,(topkey b,subkey b), kind, hashed,claimants) |
171 | 180 | ||
181 | -- Returned data is simmilar to getBindings but the Word8 codes | ||
182 | -- are ORed together. | ||
172 | accBindings :: | 183 | accBindings :: |
173 | Bits t => | 184 | Bits t => |
174 | [(t, (Packet, Packet), [a], [a1], [a2])] | 185 | [(t, (Packet, Packet), [a], [a1], [a2])] |
@@ -194,6 +205,7 @@ data UserIDRecord = UserIDRecord { | |||
194 | uid_subdomain :: T.Text, | 205 | uid_subdomain :: T.Text, |
195 | uid_topdomain :: T.Text | 206 | uid_topdomain :: T.Text |
196 | } | 207 | } |
208 | deriving Show | ||
197 | 209 | ||
198 | isBracket '<' = True | 210 | isBracket '<' = True |
199 | isBracket '>' = True | 211 | isBracket '>' = True |
@@ -295,7 +307,7 @@ listKeysFiltered grip pkts = do | |||
295 | 307 | ||
296 | data PGPKeyFlags = | 308 | data PGPKeyFlags = |
297 | Special | 309 | Special |
298 | | Vouch | 310 | | Vouch -- Signkey |
299 | | Sign | 311 | | Sign |
300 | | VouchSign | 312 | | VouchSign |
301 | | Communication | 313 | | Communication |
@@ -315,7 +327,7 @@ data PGPKeyFlags = | |||
315 | usageString flgs = | 327 | usageString flgs = |
316 | case flgs of | 328 | case flgs of |
317 | Special -> "special" | 329 | Special -> "special" |
318 | Vouch -> "vouch" | 330 | Vouch -> "vouch" -- signkey |
319 | Sign -> "sign" | 331 | Sign -> "sign" |
320 | VouchSign -> "vouch-sign" | 332 | VouchSign -> "vouch-sign" |
321 | Communication -> "communication" | 333 | Communication -> "communication" |
@@ -506,7 +518,6 @@ cmd = required . pos 0 Nothing $ posInfo | |||
506 | a <:> b = flip const <$> a <*> b | 518 | a <:> b = flip const <$> a <*> b |
507 | infixr 2 <:> | 519 | infixr 2 <:> |
508 | 520 | ||
509 | |||
510 | selectAction cmd actions = actions !! fromEnum cmd | 521 | selectAction cmd actions = actions !! fromEnum cmd |
511 | 522 | ||
512 | cmdInfo :: ArgVal cmd => | 523 | cmdInfo :: ArgVal cmd => |
@@ -607,6 +618,81 @@ main = do | |||
607 | where topair (x:xs) = (x,xs) | 618 | where topair (x:xs) = (x,xs) |
608 | return $ lookup "default-key" config >>= listToMaybe | 619 | return $ lookup "default-key" config >>= listToMaybe |
609 | 620 | ||
621 | getPGPEnviron cmd = do | ||
622 | (homedir,secring,grip) <- getHomeDir cmd | ||
623 | (Message sec) <- readPacketsFromFile secring | ||
624 | let (keys,_) = partition (\k -> case k of | ||
625 | { SecretKeyPacket {} -> True | ||
626 | ; _ -> False }) | ||
627 | sec | ||
628 | return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys)) | ||
629 | |||
630 | getTorKeys pub = do | ||
631 | xs <- groupBindings pub | ||
632 | (_,(top,sub),us,_,_) <- xs | ||
633 | guard ("tor" `elem` us) | ||
634 | let torhash = maybe "" id $ derToBase32 <$> derRSA sub | ||
635 | return (top,(torhash,sub)) | ||
636 | |||
637 | uidScan pub = scanl (\(mkey,u) w -> | ||
638 | case () of | ||
639 | _ | isMaster w -> (w,u) | ||
640 | _ | isUserID w -> (mkey,w) | ||
641 | _ | otherwise -> (mkey,u) | ||
642 | ) | ||
643 | (w0,w0) | ||
644 | ws | ||
645 | where | ||
646 | w0:ws = pub | ||
647 | isMaster k@(PublicKeyPacket {}) = not $ is_subkey k | ||
648 | isMaster _ = False | ||
649 | |||
650 | signSelfAuthTorKeys g sec grip xs = ys | ||
651 | where | ||
652 | keys = filter isKey sec | ||
653 | selfkey = find_key fingerprint (Message keys) (fromJust grip) | ||
654 | mainpubkey = fst (head xs) | ||
655 | uid:xs' = map snd xs | ||
656 | (sigs, xs'') = span isSignaturePacket xs' | ||
657 | overs sig = signatures $ Message (keys++[uid,sig]) | ||
658 | vs :: [ ( Packet -- signature | ||
659 | , Maybe SignatureOver) -- Nothing means non-verified | ||
660 | ] | ||
661 | vs = do | ||
662 | sig <- sigs | ||
663 | let vs = overs sig >>= return . verify (Message keys) | ||
664 | ws = filter (not . null . signatures_over) vs | ||
665 | ws' = if null ws then [Nothing] else map Just ws | ||
666 | v <- ws' | ||
667 | return (sig,v) | ||
668 | has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs | ||
669 | sigs' = if has_self | ||
670 | then sigs | ||
671 | -- else sigs ++ (filter isSignaturePacket $ signatures_over new_sig) | ||
672 | -- else trace ("new_sig = "++ show (filter isSignaturePacket $ signatures_over new_sig)) sigs | ||
673 | -- else trace ("selfkey "++ show (fmap fingerprint selfkey)) sigs | ||
674 | else trace (traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ signatures_over new_sig | ||
675 | -- else trace (traceSig (mainpubkey) (uid) ([last sigs])) sigs ++ signatures_over new_sig | ||
676 | traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) | ||
677 | ,"new_sig topkey:"++ (show . fingerprint $ newtop) | ||
678 | ,"new_sig user_id:"++ (show newuid) | ||
679 | ,"new_sig |over| = " ++ (show . length $ new_sig) | ||
680 | ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) | ||
681 | ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) | ||
682 | ,"new_sig type: " ++ (show . map signature_type $ new_sig) | ||
683 | -- ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) | ||
684 | ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) | ||
685 | ]) | ||
686 | new_sig = fst $ sign (Message (maybeToList selfkey)) | ||
687 | (CertificationSignature mainpubkey | ||
688 | uid | ||
689 | []) --fromJust selfkey, uid]) | ||
690 | SHA1 | ||
691 | (fromJust grip) | ||
692 | timestamp | ||
693 | g | ||
694 | timestamp = trace "TODO: timestamp" 23420 | ||
695 | ys = uid:sigs'++xs'' | ||
610 | 696 | ||
611 | doCmd cmd@(List {}) = do | 697 | doCmd cmd@(List {}) = do |
612 | (homedir,secring,grip) <- getHomeDir cmd | 698 | (homedir,secring,grip) <- getHomeDir cmd |
@@ -620,10 +706,79 @@ main = do | |||
620 | return () | 706 | return () |
621 | 707 | ||
622 | doCmd cmd@(AutoSign {}) = do | 708 | doCmd cmd@(AutoSign {}) = do |
623 | (homedir,secring,grip) <- getHomeDir cmd | 709 | ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome |
624 | (Message sec) <- readPacketsFromFile secring | 710 | , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg |
711 | , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" | ||
712 | ) <- getPGPEnviron cmd | ||
713 | putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip) | ||
625 | (Message pub) <- readPacketsFromFile (input cmd) | 714 | (Message pub) <- readPacketsFromFile (input cmd) |
626 | putStrLn $ "Inspecting packets..." | ||
627 | putStrLn $ listKeys pub | 715 | putStrLn $ listKeys pub |
716 | -- forM_ (zip [1..] pub) $ \(i,k) -> do | ||
717 | -- putStrLn $ show i ++ ": " ++ show k | ||
718 | let torbindings = getTorKeys pub | ||
719 | keyed = uidScan pub | ||
720 | marked = zipWith doit keyed pub | ||
721 | doit (mkey,u) packet = (isTorID packet, (mkey,u,packet)) | ||
722 | where | ||
723 | isTorID (UserIDPacket str) = | ||
724 | and [ uid_topdomain parsed == "onion" | ||
725 | , uid_realname parsed `elem` ["","Anonymous"] | ||
726 | , uid_user parsed == "root" | ||
727 | , fmap (match . fst) (lookup mkey torbindings) | ||
728 | == Just True ] | ||
729 | where parsed = parseUID str | ||
730 | match = ( (==subdom) . take (fromIntegral len)) | ||
731 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | ||
732 | subdom = Char8.unpack subdom0 | ||
733 | len = T.length (uid_subdomain parsed) | ||
734 | |||
735 | isTorID _ = False | ||
736 | |||
737 | g <- newGenIO | ||
738 | let xs:xss = groupBy (\_ (b,_)->not b) marked | ||
739 | pub' = map (snd . cleanup) xs | ||
740 | ++ concatMap (signSelfAuthTorKeys (g::SystemRandom) sec grip) | ||
741 | (map (map cleanup) xss) | ||
742 | cleanup (_,(topkey,_,pkt)) = (topkey,pkt) | ||
743 | putStrLn $ "-------- signed ------> " | ||
744 | putStrLn $ listKeys (sec++pub') | ||
745 | {- | ||
746 | putStrLn $ "------------------- forM_ (zip [1..] marked) $ \\(i,(flag,(_,u,p)))" | ||
747 | forM_ (zip [1..] marked) $ \(i,(flag,(_,u,p))) -> do | ||
748 | putStrLn $ show i ++ ": " ++ show (flag, p) | ||
749 | let marked2 = groupBy (\_ (b,_)->b) (map (\(b,(k,u,v))->(b,(fingerprint k,u,v))) marked) | ||
750 | putStrLn $ "------------------- marked2 ..." | ||
751 | forM_ marked2 $ \v -> do | ||
752 | putStrLn $ show v | ||
753 | -} | ||
754 | {- | ||
755 | putStrLn $ "TOR ID = " ++ show (cursor uidz) | ||
756 | putStrLn $ "parsed = " ++ show parsed | ||
757 | -- forM_ (zip [1..] sec) $ \(i,k) -> do | ||
758 | -- putStrLn $ show i ++ ": " ++ show k | ||
759 | putStrLn $ "tor bindings = " ++ show torbindings | ||
760 | putStrLn $ "should_sign = " ++ show should_sign | ||
761 | -} | ||
762 | putStrLn $ "-------------------" | ||
763 | -- extract all tor keys into base32 hash keyed map | ||
764 | -- use 'signatures' to get signed keys only | ||
765 | -- zipperSpan to tor-style UserIDPacket | ||
766 | -- zipperSpan to SignaturePacket with usage@=tor | ||
767 | -- check the back sig | ||
768 | -- If it's good, then | ||
769 | -- VOUCH for this UID: | ||
770 | -- add a new SignaturePacket after the last SignaturePacket | ||
771 | -- for the tor-style UserIDPacket | ||
628 | return () | 772 | return () |
629 | 773 | ||
774 | groupBindings pub = | ||
775 | let (sigs,bindings) = getBindings pub | ||
776 | bindings' = accBindings bindings | ||
777 | code (c,(m,s),_,_,_) = (fingerprint_material m,-c) | ||
778 | ownerkey (_,(a,_),_,_,_) = a | ||
779 | sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b | ||
780 | -- matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True | ||
781 | -- matchgrip _ = False | ||
782 | gs = {- filter matchgrip $ -} groupBy sameMaster (sortBy (comparing code) bindings') | ||
783 | in gs | ||
784 | |||