{-# 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 import System.Console.CmdTheLine as CmdTheLine import System.Console.CmdTheLine.GetOpt import System.Console.GetOpt import Control.Applicative import System.Environment import System.Directory import System.Exit import ControlMaybe import Data.Char import Control.Arrow (second) 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 p@(SecretKeyPacket {}) = 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,(m,s),_,_,_) = (fingerprint_material m,-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 ' ' -- torhash = maybe "" id $ derToBase32 <$> derRSA sub concat [ " " -- , grip top , ar , formkind , " " , fingerprint sub -- , " " ++ torhash , "\n" ] -- ++ ppShow hashed torkeys = do (code,(top,sub), kind, hashed,claimants) <- subs guard ("tor" `elem` kind) guard (code .&. 0x2 /= 0) maybeToList $ derToBase32 <$> derRSA sub 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 ++" ...\n" ++ 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 (ssh-client) -- 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 todo = error "unimplemented" -- TODO: switch to System.Environment.lookupEnv -- when linking against newer base libraries. lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) homedir :: Term (IO String) homedir = envhomedir <$> opt_homedir where envhomedir opt = do gnupghome <- lookupEnv "GNUPGHOME" >>= \d -> return $ d >>= guard . (/="") >> d home <- lookupEnv "HOME" >>= \d -> return $ d >>= guard . (/="") >> d {- home <- flip fmap getHomeDirectory $ \d -> fmap (const d) $ guard (d/="") -} let homegnupg = (++"/.gnupg") <$> home return $ maybe "" id (opt `mplus` gnupghome `mplus` homegnupg) opt_homedir = optDescrToTerm $ Option "" ["homedir"] (ReqArg id "dir") (concat [ "path to pubring.gpg" , " and secring.gpg" , " (default = ${GNUPGHOME:-$HOME/.gnupg})" ]) opt_options = optDescrToTerm $ Option "" ["options"] (ReqArg id "file") $ concat [ "Read options from file and do not try to read" , " them from the default options file in the" , " homedir (see --homedir). This option is" , " ignored if used in an options file." , " The default options file is the first existing" , " out of keys.conf, gpg.conf-2, and gpg.conf."] opt_default_key = optDescrToTerm $ Option "" ["default-key"] (ReqArg id "name") $ concat [ "Use name as the default key to sign with. If" , " this option is not used, the default key is" , " the first key found in the secret keyring."] opt_list_secret_keys = optDescrToTerm $ Option "K" ["list-secret-keys"] (NoArg ()) $ concat [ "List all keys from the secret keyrings." ] unmaybe def = fmap (maybe def id) opt_secret_keyring = expandPath <$> unmaybe "" opt_homedir <*> prim where prim = unmaybe "secring.gpg" . optDescrToTerm $ Option "" ["secret-keyring"] (ReqArg id "file") $ concat [ "Utilize secret keys in the specified file." , "(default: secring.gpg)" ] expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) | otherwise = c:cs expandPath path [] = [] secret_packets :: Term (IO Message) secret_packets = readPacketsFromFile <$> opt_secret_keyring readPacketsFromFile :: FilePath -> IO Message readPacketsFromFile fname = do input <- L.readFile fname return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> Message [] parseOptionFile fname = do xs <- fmap lines (readFile fname) let ys = filter notComment xs notComment ('#':_) = False notComment cs = not (all isSpace cs) return ys options_from_file :: Term a -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String] options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit where homedir = envhomedir <$> home envhomedir opt = do gnupghome <- lookupEnv homevar >>= \d -> return $ d >>= guard . (/="") >> d home <- flip fmap getHomeDirectory $ \d -> fmap (const d) $ guard (d/="") let homegnupg = (++('/':appdir)) <$> home return $ (opt `mplus` gnupghome `mplus` homegnupg) doit = do args <- getArgs let wants_help = not . null $ filter cryForHelp args where cryForHelp "--help" = True cryForHelp "--version" = True cryForHelp x = and (zipWith (==) x "--help=") (o,h) <- do val <- unwrap args (liftA2 (,) options_file homedir, defTI) case val of _ | wants_help -> return (Nothing,Nothing) {- Left e -> putStrLn ("Unable to find home directory ") >> exitFailure -} Left e -> return (Nothing,Nothing) Right (o,h) -> fmap (o,) h ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') optfile_alts' = zip (False:repeat True) optfile_alts o' = fmap (False,) o in filterM (doesFileExist . snd) optfiles args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do let h' = fromJust h newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname let toArgs = toHead ("--"++) . words toHead f (x:xs) = f x : xs toHead f [] = [] voidTerm = fmap (const ()) appendArgs as [] = return as appendArgs as (configline:cs) = do let xs = toArgs configline w <-unwrap (xs++as) (voidTerm term,defTI) case w of Left _ -> appendArgs as cs Right _ -> appendArgs (xs++as) cs -- TODO: check errors if forgive = False appendArgs args newargs return args runWithOptionsFile (term,ti) = do as <- options_from_file term ("GNUPGHOME",".gnupg",opt_homedir) (["keys.conf","gpg.conf-2","gpg.conf"] ,opt_options) q <- eval as (term , ti) q main = do q <- runWithOptionsFile (listSecretKeys, defTI { termName = "keys", CmdTheLine.version = "0.1" }) return () where -- showhome = flip const <$> opt_options <*> ( (>>= putStrLn) <$> homedir ) showhome = opt_default_key <:> opt_options <:> ( (>>= putStrLn) <$> homedir ) a <:> b = flip const <$> a <*> b infixr 2 <:> listSecretKeys = opt_options <:> (>>= list) <$> secret_packets list (Message pkts) = putStrLn $ listKeys pkts