{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Debug.Trace import Data.Binary import Data.OpenPGP import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.ByteString as S import Control.Monad import Text.Show.Pretty import Data.List import Data.OpenPGP.CryptoAPI import Data.Ord import Data.Maybe import Data.Bits import qualified Data.Text as T import Data.Text.Encoding import qualified Codec.Binary.Base32 as Base32 import qualified Crypto.Hash.SHA1 as SHA1 import Data.Char (toLower) import qualified Crypto.PubKey.RSA as RSA import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding data RSAPublicKey = RSAKey MPI MPI instance ASN1Object RSAPublicKey where toASN1 (RSAKey (MPI n) (MPI e)) = \xs -> Start Sequence : IntVal n : IntVal e : End Sequence : xs fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = Right (RSAKey (MPI modulus) (MPI pubexp) , xs) fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" rsaKeyFromPacket p@(PublicKeyPacket {}) = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p return $ RSAKey n e rsaKeyFromPacket _ = Nothing derRSA rsa = do k <- rsaKeyFromPacket rsa return $ encodeASN1 DER (toASN1 k []) getPackets :: IO [Packet] getPackets = do input <- L.getContents case decodeOrFail input of Right (_,_,Message pkts) -> return pkts Left (_,_,_) -> return [] isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isUserID (UserIDPacket {}) = True isUserID _ = False isEmbeddedSignature (EmbeddedSignaturePacket {}) = True isEmbeddedSignature _ = False isCertificationSig (CertificationSignature {}) = True isCertificationSig _ = True issuer (IssuerPacket issuer) = Just issuer issuer _ = Nothing backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False usage (NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = u }) = Just u usage _ = Nothing verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) where verified = do sig <- signatures (Message nonkeys) let v = verify (Message keys) sig guard (not . null $ signatures_over v) return v (top,othersigs) = partition isSubkeySignature verified embedded = do sub <- top let sigover = signatures_over sub unhashed = sigover >>= unhashed_subpackets subsigs = mapMaybe backsig unhashed sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) let v = verify (Message [subkey sub]) sig guard (not . null $ signatures_over v) return v grip k = drop 32 $ fingerprint k smallpr k = drop 24 $ fingerprint k disjoint_fp ks = {- concatMap group2 $ -} transpose grouped where grouped = groupBy samepr . sortBy (comparing smallpr) $ ks samepr a b = smallpr a == smallpr b {- -- useful for testing group2 :: [a] -> [[a]] group2 (x:y:ys) = [x,y]:group2 ys group2 [x] = [[x]] group2 [] = [] -} getBindings :: [Packet] -> ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets -- that were used for the verifications , [(Word8, (Packet, Packet), [String], [SignatureSubpacket], [Packet])] -- ^ binding signatures ) getBindings pkts = (sigs,bindings) where (sigs,concat->bindings) = unzip $ do let (keys,nonkeys) = partition isKey pkts keys <- disjoint_fp keys let (bs,sigs) = verifyBindings keys pkts return . ((keys,sigs),) $ do b <- bs i <- map signature_issuer (signatures_over b) i <- maybeToList i who <- maybeToList $ find_key fingerprint (Message keys) i let (code,claimants) = case () of _ | who == topkey b -> (1,[]) _ | who == subkey b -> (2,[]) _ -> (0,[who]) let hashed = signatures_over b >>= hashed_subpackets kind = guard (code==1) >> hashed >>= maybeToList . usage return (code,(topkey b,subkey b), kind, hashed,claimants) accBindings :: Bits t => [(t, (Packet, Packet), [a], [a1], [a2])] -> [(t, (Packet, Packet), [a], [a1], [a2])] accBindings bs = as where gs = groupBy samePair . sortBy (comparing bindingPair) $ bs as = map (foldl1 combine) gs bindingPair (_,p,_,_,_) = pub2 p where pub2 (a,b) = (pub a, pub b) pub a = fingerprint_material a samePair a b = bindingPair a == bindingPair b combine (ac,p,akind,ahashed,aclaimaints) (bc,_,bkind,bhashed,bclaimaints) = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) data UserIDRecord = UserIDRecord { uid_full :: String, uid_realname :: T.Text, uid_user :: T.Text, uid_subdomain :: T.Text, uid_topdomain :: T.Text } isBracket '<' = True isBracket '>' = True isBracket _ = False parseUID str = UserIDRecord { uid_full = str, uid_realname = realname, uid_user = user, uid_subdomain = subdomain, uid_topdomain = topdomain } where text = T.pack str (T.strip-> realname, T.dropAround isBracket-> email) = T.break (=='<') text (user, T.tail-> hostname) = T.break (=='@') email ( T.reverse -> topdomain, T.reverse . T.drop 1 -> subdomain) = T.break (=='.') . T.reverse $ hostname derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy listKeys pkts = do let (certs,bs) = getBindings pkts as = accBindings bs defaultkind (k:_) hs = k defaultkind [] hs = maybe "subkey" id ( listToMaybe . mapMaybe (fmap usageString . keyflags) $ hs) kinds = map (\(_,_,k,h,_)->defaultkind k h) as kindwidth = maximum $ map length kinds kindcol = min 20 kindwidth code (c,_,_,_,_) = -c ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b gs = groupBy sameMaster (sortBy (comparing code) as) subs <- gs let (code,(top,sub), kind, hashed,claimants):_ = subs subkeys = do (code,(top,sub), kind, hashed,claimants) <- subs let ar = case code of 0 -> " ??? " 1 -> " --> " 2 -> " <-- " 3 -> " <-> " formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' " " {- ++grip top -} ++ ar ++ formkind ++" "++ fingerprint sub ++ "\n" -- ++ ppShow hashed torkeys = do (code,(top,sub), kind, hashed,claimants) <- subs guard ("tor" `elem` kind) guard (code .&. 0x2 /= 0) der <- maybeToList $ derRSA sub return $ derToBase32 der uid = {- maybe "" id . listToMaybe $ -} do (keys,sigs) <- certs sig <- sigs guard (isCertificationSig sig) guard (topkey sig == top) sig_over <- signatures_over sig guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top) let UserIDPacket uid = user_id sig parsed = parseUID uid ar = maybe " --> " (const " <-> ") $ do guard (uid_topdomain parsed == "onion" ) guard ( uid_realname parsed `elem` ["","Anonymous"]) guard ( uid_user parsed == "root" ) let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] len = L.length subdom0 subdom = Char8.unpack subdom0 match = ( (==subdom) . take (fromIntegral len)) guard (len >= 16) listToMaybe $ filter match torkeys " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n" (_,sigs) = unzip certs "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n" data PGPKeyFlags = Special | Vouch | Sign | VouchSign | Communication | VouchCommunication | SignCommunication | VouchSignCommunication | Storage | VouchStorage | SignStorage | VouchSignStorage | Encrypt | VouchEncrypt | SignEncrypt | VouchSignEncrypt deriving (Eq,Show,Read,Enum) usageString flgs = case flgs of Special -> "special" Vouch -> "vouch" Sign -> "sign" VouchSign -> "vouch-sign" Communication -> "communication" VouchCommunication -> "vouch-communication" SignCommunication -> "sign-communication" VouchSignCommunication -> "vouch-sign-communication" Storage -> "storage" VouchStorage -> "vouch-storage" SignStorage -> "sign-storage" VouchSignStorage -> "vouch-sign-storage" Encrypt -> "encrypt" VouchEncrypt -> "vouch-encrypt" SignEncrypt -> "sign-encrypt" VouchSignEncrypt -> "vouch-sign-encrypt" keyflags flgs@(KeyFlagsPacket {}) = Just . toEnum $ ( bit 0x1 certify_keys .|. bit 0x2 sign_data .|. bit 0x4 encrypt_communication .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags -- other flags: -- split_key -- authentication -- group_key where bit v f = if f flgs then v else 0 keyflags _ = Nothing modifyUID (UserIDPacket str) = UserIDPacket str' where (fstname,rst) = break (==' ') str str' = mod fstname ++ rst mod "Bob" = "Bob Fucking" mod x = x modifyUID other = other main = do pkts <- getPackets putStrLn $ listKeys pkts -- (map modifyUID pkts) return ()