{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} module Main where import Debug.Trace import GHC.Exts (Down(..)) import Data.Tuple 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 qualified Data.ByteString.Char8 as S8 import Control.Monad import qualified Text.Show.Pretty as PP import Text.PrettyPrint as PP hiding ((<>)) 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 Codec.Binary.Base64 as Base64 import qualified Crypto.Hash.SHA1 as SHA1 import Data.Char (toLower) import qualified Crypto.PubKey.RSA as RSA import Crypto.Random (newGenIO,SystemRandom) import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding import Data.ASN1.BitArray import Control.Applicative import System.Environment import System.Directory import System.Exit import ControlMaybe import Data.Char import Control.Arrow (second) import Data.Traversable hiding (mapM) import System.Console.CmdArgs -- import System.Posix.Time import Data.Time.Clock.POSIX import System.Posix.IO (fdToHandle,fdRead) import System.Posix.Files import Data.Monoid ((<>)) -- import Data.X509 import qualified Data.Map as Map unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) where p = break (==c) spec data RSAPublicKey = RSAKey MPI MPI deriving Show data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show pkcs8 (RSAKey n e) = RSAKey8 n e instance ASN1Object RSAPublicKey where -- PKCS #1 RSA Public Key toASN1 (RSAKey (MPI n) (MPI e)) = \xs -> Start Sequence : IntVal n : IntVal e : End Sequence : xs fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" instance ASN1Object PKCS8_RSAPublicKey where -- PKCS #8 Public key data toASN1 (RSAKey8 (MPI n) (MPI e)) = \xs -> Start Sequence : Start Sequence : OID [1,2,840,113549,1,1,1] : End Sequence : BitString (toBitArray bs 0) : End Sequence : xs where pubkey = Start Sequence : IntVal n : IntVal e : End Sequence : [] bs = encodeASN1' DER pubkey fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs) fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) = case decodeASN1' DER bs of Right as -> fromASN1 as Left e -> Left ("fromASN1: RSAPublicKey: "++show e) where BitArray _ bs = b fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" data RSAPrivateKey = RSAPrivateKey { rsaN :: MPI , rsaE :: MPI , rsaD :: MPI , rsaP :: MPI , rsaQ :: MPI , rsaDmodP1 :: MPI , rsaDmodQminus1 :: MPI , rsaCoefficient :: MPI } deriving Show {- RSAPrivateKey ::= SEQUENCE { version Version, modulus INTEGER, -- n publicExponent INTEGER, -- e privateExponent INTEGER, -- d prime1 INTEGER, -- p prime2 INTEGER, -- q exponent1 INTEGER, -- d mod (p1) exponent2 INTEGER, -- d mod (q-1) coefficient INTEGER, -- (inverse of q) mod p otherPrimeInfos OtherPrimeInfos OPTIONAL } -} instance ASN1Object RSAPrivateKey where toASN1 rsa@(RSAPrivateKey {}) = \xs -> Start Sequence : IntVal 0 : mpiVal rsaN : mpiVal rsaE : mpiVal rsaD : mpiVal rsaP : mpiVal rsaQ : mpiVal rsaDmodP1 : mpiVal rsaDmodQminus1 : mpiVal rsaCoefficient : End Sequence : xs where mpiVal f = IntVal x where MPI x = f rsa fromASN1 ( Start Sequence : IntVal _ -- version : IntVal n : IntVal e : IntVal d : IntVal p : IntVal q : IntVal dmodp1 : IntVal dmodqminus1 : IntVal coefficient : ys) = Right ( privkey, tail $ dropWhile notend ys) where notend (End Sequence) = False notend _ = True privkey = RSAPrivateKey { rsaN = MPI n , rsaE = MPI e , rsaD = MPI d , rsaP = MPI p , rsaQ = MPI q , rsaDmodP1 = MPI dmodp1 , rsaDmodQminus1 = MPI dmodqminus1 , rsaCoefficient = MPI coefficient } fromASN1 _ = Left "fromASN1: RSAPrivateKey: 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 [] secretToPublic pkt@(SecretKeyPacket {}) = PublicKeyPacket { version = version pkt , timestamp = timestamp pkt , key_algorithm = key_algorithm pkt , key = let seckey = key pkt pubs = public_key_fields (key_algorithm pkt) in filter (\(k,v) -> k `elem` pubs) seckey , is_subkey = is_subkey pkt , v3_days_of_validity = Nothing } secretToPublic pkt = pkt extractPEM typ pem = dta where dta = case ys of _:dta_lines -> Char8.concat dta_lines [] -> "" xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) ys = takeWhile (/="-----END " <> typ <> "-----") xs isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isUserID (UserIDPacket {}) = True isUserID _ = False isEmbeddedSignature (EmbeddedSignaturePacket {}) = True isEmbeddedSignature _ = False isCertificationSig (CertificationSignature {}) = True isCertificationSig _ = True isTrust (TrustPacket {}) = True isTrust _ = False issuer (IssuerPacket issuer) = Just issuer issuer _ = Nothing backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k isMasterKey _ = False now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime 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 -- This should consist only of 0x19 values -- subtypes = map signature_type subsigs -- trace ("subtypes = "++show subtypes) (return ()) -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) 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 -- matchpr computes the fingerprint of the given key truncated to -- be the same lenght as the given fingerprint for comparison. matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp 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 [] = [] -} verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures) verifyBindingsEx pkts = bicat . unzip $ do let (keys,_) = partition isKey pkts keys <- disjoint_fp keys return $ verifyBindings keys pkts where bicat (xs,ys) = (concat xs,concat ys) getBindings :: [Packet] -> ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets -- that were used for the verifications , [(Word8, (Packet, Packet), -- (topkey,subkey) [String], -- usage flags [SignatureSubpacket], -- hashed data [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 -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) 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) -- Returned data is simmilar to getBindings but the Word8 codes -- are ORed together. 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 } deriving Show 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 fpmatch grip key = (==) Nothing (fmap (backend (fingerprint key)) grip >>= guard . not) where backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) listKeys pkts = listKeysFiltered [] pkts listKeysFiltered grips 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 matchgrip _ | null grips = True matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True matchgrip _ = False gs = filter matchgrip $ 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 , (if not (null claimants) then trace ("claimants: "++show (map fingerprint claimants)) else id) 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) let issuers = do sig_over <- signatures_over sig i <- maybeToList $ signature_issuer sig_over maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i))) (primary,secondary) = partition (==top) issuers -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return () -- trace ("SECONDARY: "++show (map fingerprint secondary)) $ return () guard (not (null primary)) 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 unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ] ++ map (\k -> " " ++ "^ signed: " ++ fingerprint k) secondary (_,sigs) = unzip certs "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" data PGPKeyFlags = Special | Vouch -- Signkey | 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" -- signkey 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) unmaybe def = fmap (maybe def id) expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) | otherwise = c:cs expandPath path [] = [] readPacketsFromFile :: FilePath -> IO Message readPacketsFromFile fname = do input <- L.readFile fname return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> Message [] readPacketsFromFile' n = fmap (n,) (readPacketsFromFile n) 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 :: (forall a. [String] -> Term a -> IO (Either EvalExit a)) -> Term b -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String] options_from_file unwrapCmd 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 let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val 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 <- unwrapCmd args (liftA2 (,) options_file homedir) case val of Left e -> return (Nothing,Nothing) Right (o,h) -> (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 (IO b), TermInfo) -> IO b runWithOptionsFile (term,ti) = do as <- options_from_file unwrapCmd term ("GNUPGHOME",".gnupg",opt_homedir) (["keys.conf","gpg.conf-2","gpg.conf"] ,opt_options) q <- eval as (term , ti) q where unwrapCmd args term = unwrap args (term,defTI) runChoiceWithOptionsFile :: (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b runChoiceWithOptionsFile (realterm,ti) choices = do as <- options_from_file unwrapCmd realterm ("GNUPGHOME",".gnupg",opt_homedir) (["keys.conf","gpg.conf-2","gpg.conf"] ,opt_options) -- putStrLn $ "as = " ++ show as q <- evalChoice as (realterm , ti) choices q where unwrapCmd args t = unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices) neuter term (t,ti) = (t <:> term, ti) data Command = List | Autosign deriving (Eq,Show,Read,Enum) capitolizeFirstLetter (x:xs) = toUpper x : xs capitolizeFirstLetter xs = xs instance ArgVal Command where converter = ( maybe (Left $ text "unknown command") Right . fmap fst . listToMaybe . reads . capitolizeFirstLetter . map toLower , text . map toLower . show ) class AutoMaybe a instance AutoMaybe Command instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where converter = ( toRight Just . fst converter , maybe (text "(unspecified)") id . fmap (snd converter) ) toRight f (Right x) = Right (f x) toRight f (Left y) = Left y cmd :: Term Command cmd = required . pos 0 Nothing $ posInfo { posName = "command" , posDoc = "What action to perform." } a <:> b = flip const <$> a <*> b infixr 2 <:> selectAction cmd actions = actions !! fromEnum cmd cmdInfo :: ArgVal cmd => cmd -> String -> Term a -> (cmd, (Term a, TermInfo)) cmdInfo cmd doc action = ( cmd , ( action , defTI { termName = print cmd , termDoc = doc } ) ) where print = show . snd converter cmdlist :: (Command, (Term (IO ()), TermInfo)) cmdlist = cmdInfo List "list key pairs for which secrets are known" $ (>>= putStrLn . listKeys . unMessage) <$> secret_packets where unMessage (Message pkts) = pkts cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $ pure (putStrLn "autosign") multiCommand :: TermInfo -> [(Command, (Term a, TermInfo))] -> ( (Term a, TermInfo) , [(Term a, TermInfo)] ) multiCommand ti choices = ( ( selectAction <$> cmd <*> sequenceA (map strip choices) , ti ) , map snd choices ) where selectAction cmd choices = fromJust $ lookup (cmd::Command) choices strip (cmd,(action,_)) = fmap (cmd,) action -} trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs guessKeyFormat 'P' "ssh-client" = "SSH" guessKeyFormat 'S' "ssh-client" = "PEM" guessKeyFormat 'S' "ssh-host" = "PEM" guessKeyFormat _ _ = "PEM" -- "PGP" readKeyFromFile False "PEM" fname = do timestamp <- modificationTime <$> getFileStatus fname input <- L.readFile fname let dta = extractPEM "RSA PRIVATE KEY" input -- Char8.putStrLn $ "dta = " <> dta let rsa = do e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) asn1 <- either (const Nothing) Just e k <- either (const Nothing) (Just . fst) (fromASN1 asn1) let _ = k :: RSAPrivateKey return k -- putStrLn $ "rsa = "++ show rsa return . Message $ do rsa <- maybeToList rsa return $ SecretKeyPacket { version = 4 , timestamp = toEnum (fromEnum timestamp) , key_algorithm = RSA , key = [ -- public fields... ('n',rsaN rsa) ,('e',rsaE rsa) -- secret fields ,('d',rsaD rsa) ,('p',rsaQ rsa) -- Note: p & q swapped ,('q',rsaP rsa) -- Note: p & q swapped ,('u',rsaCoefficient rsa) ] , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) data Arguments = List { homedir :: Maybe FilePath } | WorkingKey { homedir :: Maybe FilePath } | AutoSign { homedir :: Maybe FilePath , passphrase_fd :: Maybe Int , input :: FilePath , output :: FilePath} | Public { homedir :: Maybe FilePath , output :: FilePath} | Add { homedir :: Maybe FilePath , passphrase_fd :: Maybe Int , key_usage :: String , seckey :: String , output :: FilePath } | PemFP { homedir :: Maybe FilePath , seckey :: String } | CatPub { homedir :: Maybe FilePath , catpub_args :: [String] } | MergeSecrets { homedir :: Maybe FilePath , files :: [FilePath] } | Merge { homedir :: Maybe FilePath , files :: [FilePath] } | DumpPackets { homedir :: Maybe FilePath , marshal_test :: String , files :: [FilePath] } {- | Decrypt { homedir :: Maybe FilePath , passphrase_fd :: Maybe Int , output :: FilePath } -} deriving (Show, Data, Typeable) getPassphrase cmd = case passphrase_fd cmd of Just fd -> do pwh <- fdToHandle (toEnum fd) fmap trimCR $ S.hGetContents pwh Nothing -> return "" #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) data KeySpec = KeyGrip String | KeyTag Packet String | KeyUidMatch String is40digitHex xs = ys == xs && length ys==40 where ys = filter ishex xs ishex c | '0' <= c && c <= '9' = True | 'A' <= c && c <= 'F' = True | 'a' <= c && c <= 'f' = True ishex c = False scanPackets filename [] = [] scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps where ret p = (p,Map.empty) doit (top,sub,prev) p = case p of _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) _ | isKey p && is_subkey p -> (top,p,ret p) _ | isUserID p -> (top,p,ret p) _ | isTrust p -> (top,sub,updateTrust top sub prev p) _ | otherwise -> (top,sub,ret p) updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret type SigAndTrust = ( Packet , Map.Map FilePath Packet ) -- trust packets type KeyKey = [Char8.ByteString] data SubKey = SubKey Packet [SigAndTrust] data KeyData = KeyData Packet -- main key [SigAndTrust] -- sigs on main key (Map.Map String [SigAndTrust]) -- uids (Map.Map KeyKey SubKey) -- subkeys type KeyDB = Map.Map KeyKey KeyData keykey key = fingerprint_material key -- TODO: smaller key? uidkey (UserIDPacket str) = str -- Compare master keys, LT is prefered for merging keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT keycomp a b | a==b = EQ keycomp a b = error $ unlines ["Unable to merge keys:" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] -- Compare subkeys, LT is prefered for merging subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT subcomp a b | a==b = EQ subcomp a b = error $ unlines ["Unable to merge subs:" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] merge :: Map.Map KeyKey KeyData -> FilePath -> Message -> Map.Map KeyKey KeyData merge db filename (Message ps) = foldl mergeit db qs where qs = scanPackets filename ps -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit db (top,sub,ptt@(p,trustmap)) | isKey top = Map.alter update (keykey top) db where update v | isKey p && not (is_subkey p) = case v of Nothing -> Just $ KeyData p [] Map.empty Map.empty Just (KeyData key sigs uids subkeys) | keykey key == keykey p -> Just $ KeyData (minimumBy keycomp [key,p]) sigs uids subkeys _ -> error . concat $ ["Unexpected master key merge error: " ,show (fingerprint top, fingerprint p)] update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p = Just $ KeyData key sigs uids (Map.alter (mergeSubkey p) (keykey p) subkeys) update (Just (KeyData key sigs uids subkeys)) | isUserID p = Just $ KeyData key sigs (Map.alter (mergeUid ptt) (uidkey p) uids) subkeys update (Just (KeyData key sigs uids subkeys)) = case sub of MarkerPacket -> Just $ KeyData key (mergeSig ptt sigs) uids subkeys UserIDPacket {} -> Just $ KeyData key sigs (Map.alter (mergeUidSig ptt) (uidkey sub) uids) subkeys _ | isKey sub -> Just $ KeyData key sigs uids (Map.alter (mergeSubSig ptt) (keykey sub) subkeys) _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) mergeit _ (_,_,p) = error $ "Unexpected PGP packet 3: "++whatP p mergeSubkey p Nothing = Just $ SubKey p [] mergeSubkey p (Just (SubKey key sigs)) = Just $ SubKey (minimumBy subcomp [key,p]) sigs mergeUid (UserIDPacket s,_) Nothing = Just [] mergeUid (UserIDPacket s,_) (Just sigs) = Just sigs mergeUid p _ = error $ "Unable to merge into UID record: " ++whatP p whatP (a,_) = concat . take 1 . words . show $ a mergeSig sig sigs = let (xs,ys) = break (isSameSig sig) sigs in if null ys then sigs++[sig] else let y:ys'=ys in xs ++ (mergeSameSig sig y : ys') isSameSig (a,_) (b,_) | isSignaturePacket a && isSignaturePacket b = a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } isSameSig (a,_) (b,_) = a==b mergeSameSig (a,ta) (b,tb) | isSignaturePacket a && isSignaturePacket b = ( b { unhashed_subpackets = foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) } , tb `Map.union` ta ) where mergeItem ys x = if x `elem` ys then ys else ys++[x] mergeSameSig a b = trace ("discarding dup "++show a) b mergeUidSig sig (Just sigs) = Just $ mergeSig sig sigs mergeUidSig sig Nothing = Just [sig] mergeSubSig sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig sig sigs) mergeSubSig sig Nothing = error $ "Unable to merge subkey signature: "++(words (show sig) >>= take 1) flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs $ db) where flattenTop (_,(KeyData key sigs uids subkeys)) = unk key : ( concatMap flattenUid (Map.assocs uids) ++ concatMap flattenSub (Map.assocs subkeys)) flattenUid (str,sigs) = UserIDPacket str : concatMap unsig sigs flattenSub (_,SubKey key sigs) = unk key: concatMap unsig sigs unk k = if isPublic then secretToPublic k else k unsig (sig,trustmap) = [sig]++ take 1 (Map.elems $ Map.filterWithKey f trustmap) where f "%secring" _ = not isPublic f _ _ = isPublic prefilter = if isPublic then id else filter isSecret where isSecret (_,(KeyData (SecretKeyPacket {}) _ _ _)) = True isSecret _ = False {- merge db (Message ps) = scanl mergeit db qs where qs = scanPackets ps mergeit db (top,sub,p) = todo where k = keykey top v = maybe (merge1 (newrec top)) (merge2 sub p) $ Map.lookup k db keykey key = fingerprint_material key -- TODO: smaller key? newrec key | isKey key && not (is_subkey key) = KeyData key [] Map.empty Map.empty newrec _ = error "Unexpected packet." merge1 rec db = Map.insert k rec db merge2 sub p (KeyData mk sigs uids subkeys) | isKey sub = maybe todo todo $ Map.lookup skey subkeys where skey = keykey sub -} main = do args <- cmdArgs $ modes [ List HOMEOPTION &= help "List key pairs in the secret keyring." &= auto , WorkingKey HOMEOPTION &= help "Shows the current working key set that will be used to make signatures." , Public HOMEOPTION (def &= argPos 1 &= typFile ) &= help "Extract public keys into the given file." , AutoSign HOMEOPTION (def &= opt ("passphrase"::String) &= typ "FD" &= (help . concat) ["file descriptor from " ,"which to read passphrase"]) (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) &= (help . concat) [ "Copies the first file to the second while adding" , " signatures for tor-style uids that match" , " cross-certified keys." ] {- , Decrypt HOMEOPTION (def &= opt ("passphrase"::String) &= typ "FD" &= (help . concat) ["file descriptor from " ,"which to read passphrase"]) (def &= argPos 1 &= typFile ) -- (def &= argPos 3 &= typ "PUBLIC-KEY") &= (help . concat) [ "Remove password protection from the working keyring" , " and save the result into the given file."] -} , CatPub HOMEOPTION (def &= args &= typ "KEYSPEC FILES") &= help "Extract a public subkey to stdout." , MergeSecrets HOMEOPTION (def &= args &= typFile) &= help "Merge multiple secret keyrings to stdout." , Merge HOMEOPTION (def &= args &= typFile) &= help "Merge multiple keyrings to stdout. Secrets are filtered." , DumpPackets HOMEOPTION (def &= opt ("n" ::String)) (def &= args &= typFile) &= help "Output secret ring packets in ascii format for debugging." , Add HOMEOPTION (def &= opt ("passphrase"::String) &= typ "FD" &= (help . concat) ["file descriptor from " ,"which to read passphrase"]) (def &= argPos 1 &= typ "USAGE") (def &= argPos 2 &= typ "PRIVATE-KEY") (def &= argPos 3 &= typFile) -- (def &= argPos 3 &= typ "PUBLIC-KEY") &= (help . concat) [ "Add a subkey." , " USAGE is the usage@ annotation of the subkey." , " Keys are specified as FMT:FILE where" , " FMT may be one of following: PEM." , " Results are written to the given file." ] , PemFP HOMEOPTION (def &= argPos 1 &= typFile ) &= (help . concat) [ "Display the fingerprint of a PEM key pair."] ] &= program "kiki" &= summary "kiki - a pgp key editing utility" doCmd args where 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 let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val homevar = "GNUPGHOME" appdir = ".gnupg" optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] getHomeDir cmd = do homedir <- envhomedir (homedir cmd) flip (maybe (error "Could not determine home directory.")) homedir $ \homedir -> do -- putStrLn $ "homedir = " ++show homedir let secring = homedir ++ "/" ++ "secring.gpg" -- putStrLn $ "secring = " ++ show secring workingkey <- getWorkingKey homedir return (homedir,secring,workingkey) getWorkingKey homedir = do let o = Nothing h = Just homedir args = ["hi"] 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 []) ofile $ \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) return $ lookup "default-key" config >>= listToMaybe getPGPEnviron cmd = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring let (keys,_) = partition (\k -> case k of { SecretKeyPacket {} -> True ; _ -> False }) sec return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys)) getTorKeys pub = do xs <- groupBindings pub (_,(top,sub),us,_,_) <- xs guard ("tor" `elem` us) let torhash = maybe "" id $ derToBase32 <$> derRSA sub return (top,(torhash,sub)) uidScan pub = scanl (\(mkey,u) w -> case () of _ | isMasterKey w -> (w,u) _ | isUserID w -> (mkey,w) _ | otherwise -> (mkey,u) ) (w0,w0) ws where w0:ws = pub signSelfAuthTorKeys selfkey g sec grip timestamp xs = ys where keys = filter isKey sec mainpubkey = fst (head xs) uid:xs' = map snd xs (sigs, xs'') = span isSignaturePacket xs' overs sig = signatures $ Message (keys++[uid,sig]) vs :: [ ( Packet -- signature , Maybe SignatureOver) -- Nothing means non-verified ] vs = do sig <- sigs let vs = overs sig >>= return . verify (Message keys) ws = filter (not . null . signatures_over) vs ws' = if null ws then [Nothing] else map Just ws v <- ws' return (sig,v) selfsigs = filter (\(sig,v) -> fmap topkey v == selfkey) vs has_self = not . null $ selfsigs sigs' = if has_self then sigs {- else trace ( "key params: "++params (fromJust selfkey)++"\n" ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ {- map modsig -} (signatures_over new_sig) -} else sigs ++ signatures_over new_sig modsig sig = sig { signature = map id (signature sig) } where plus1 (MPI x) = MPI (x+1) params newtop = public ++ map fst (key newtop) ++ "}" where public = case newtop of PublicKeyPacket {} -> "public{" SecretKeyPacket {} -> if L.null (encrypted_data newtop ) then "secret{" else "encrypted{" _ -> "??????{" traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) ,"new_sig topkey:"++ (show . fingerprint $ newtop) ,"new_sig topkey params: "++ params newtop ,"new_sig user_id:"++ (show newuid) ,"new_sig |over| = " ++ (show . length $ new_sig) ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) ,"new_sig type: " ++ (show . map signature_type $ new_sig) ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) ,"issuer = " ++ show (map signature_issuer new_sig) ]) flgs = if keykey mainpubkey == keykey (fromJust selfkey) then keyFlags0 mainpubkey (map fst selfsigs) else [] new_sig = fst $ torsig g mainpubkey (fromJust selfkey) uid timestamp flgs ys = uid:sigs'++xs'' doCmd cmd@(List {}) = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring putStrLn $ listKeys sec doCmd cmd@(WorkingKey {}) = do (homedir,secring,grip) <- getHomeDir cmd (Message sec) <- readPacketsFromFile secring -- let s2k' = map s2k (filter isKey sec) -- putStrLn $ "s2k = " ++ show s2k' putStrLn $ listKeysFiltered (maybeToList grip) sec return () doCmd cmd@(AutoSign {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd flip (maybe (error "No working key?")) grip $ \grip -> do pw <- getPassphrase cmd let (pre, wk:subs) = seek_key (KeyGrip grip) sec wkun = if symmetric_algorithm wk == Unencrypted then Just wk else do k <- decryptSecretKey pw wk guard (symmetric_algorithm k == Unencrypted) return k flip (maybe (error "Bad passphrase?")) wkun$ \wkun -> do -- putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip) (Message pub) <- readPacketsFromFile (input cmd) putStrLn $ listKeys pub -- forM_ (zip [1..] pub) $ \(i,k) -> do -- putStrLn $ show i ++ ": " ++ show k let torbindings = getTorKeys pub keyed = uidScan pub marked = zipWith doit keyed pub doit (mkey,u) packet = (isTorID packet, (mkey,u,packet)) where isTorID (UserIDPacket str) = and [ uid_topdomain parsed == "onion" , uid_realname parsed `elem` ["","Anonymous"] , uid_user parsed == "root" , fmap (match . fst) (lookup mkey torbindings) == Just True ] where parsed = parseUID str match = ( (==subdom) . take (fromIntegral len)) subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] subdom = Char8.unpack subdom0 len = T.length (uid_subdomain parsed) isTorID _ = False g <- newGenIO timestamp <- now -- timestamp <- epochTime let xs:xss = groupBy (\_ (b,_)->not b) marked pub' = map (snd . cleanup) xs ++ concatMap (signSelfAuthTorKeys (Just wkun) (g::SystemRandom) sec grip timestamp) (map (map cleanup) xss) cleanup (_,(topkey,_,pkt)) = (topkey,pkt) putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub') putStrLn "" putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub')) (sec++pub') let signed_bs = encode (Message pub') L.writeFile (output cmd) signed_bs doCmd cmd@(Public {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd let pub = map secretToPublic sec bs = encode (Message pub) L.writeFile (output cmd) bs {- doCmd cmd@(Decrypt {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd pw <- getPassphrase cmd let sec' = map decrypt sec decrypt k@(SecretKeyPacket {}) = k -- TODO L.writeFile (output cmd) (encode $ Message sec') {- let wk = grip >>= find_key fingerprint (Message sec) case wk of Nothing -> error "No working key?" Just wk -> do putStrLn $ "wk = " ++ fingerprint wk -} -} doCmd cmd@(DumpPackets {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd p <- case files cmd of [] -> return sec fs -> do ms <- mapM readPacketsFromFile fs let unwrap (Message ps) = ps return (concatMap unwrap ms) if map toLower (marshal_test cmd) `elem` ["y","yes"] then L.putStr $ encode (Message p) else putStrLn $ PP.ppShow p doCmd cmd@(MergeSecrets {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd let db = merge Map.empty "%secring" (Message sec) ms <- mapM readPacketsFromFile' (files cmd) let db' = foldl' (uncurry . merge) db ms m = flattenKeys False db' L.putStr (encode m) return () doCmd cmd@(Merge {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd let db = merge Map.empty "%secring" (Message sec) ms <- mapM readPacketsFromFile' (files cmd) let db' = foldl' (uncurry . merge) db ms m = flattenKeys True db' L.putStr (encode m) return () doCmd cmd@(CatPub {}) = do let spec:files = catpub_args cmd let (topspec,subspec) = unprefix '/' spec (toptyp,top) = unprefix ':' topspec (subtyp,sub) = unprefix ':' subspec {- putStrLn $ "files = " ++ show files putStrLn $ "topspec = " ++show (toptyp,top) putStrLn $ "subspec = " ++show (subtyp,sub) -} ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd flip (maybe (error "No working key?")) grip $ \grip -> do ms <- mapM readPacketsFromFile' files let db = merge Map.empty "%secring" (Message sec) db' = foldl' (uncurry . merge) db ms m = flattenKeys True db' Message allpkts = m let topspec = case () of _ | null top && (subtyp=="fp" || (null subtyp && is40digitHex sub)) -> KeyGrip sub _ | null top -> KeyGrip grip _ | toptyp=="fp" || (null toptyp && is40digitHex top) -> {- trace "using top" $ -} KeyGrip top _ | toptyp=="u" -> KeyUidMatch top _ | otherwise -> KeyUidMatch top (pre, wksubs) = seek_key topspec allpkts if null wksubs then error ("No match for "++spec) else do let wk:subs = wksubs (_,wksubs') = seek_key topspec subs -- ambiguity check (_,ys) = case subtyp of "t" -> seek_key (KeyTag wk sub) subs "fp" | top=="" -> ([],wk:subs) "" | top=="" && is40digitHex sub -> ([],wk:subs) "" -> seek_key (KeyTag wk sub) subs when (not (null ys)) $ do let (_,ys') = seek_key (KeyTag wk sub) (tail ys) -- ambiguity check k = head ys rsa = pkcs8 . fromJust $ rsaKeyFromPacket k der = encodeASN1 DER (toASN1 rsa []) qq = Base64.encode (L.unpack der) split64 [] = [] split64 qq = as : split64 bs where (as,bs) = splitAt 64 qq -- putStrLn $ "top = " ++ show top -- putStrLn $ "wk = " ++ fingerprint wk -- putStrLn $ fingerprint k {- putStrLn $ show rsa putStrLn $ show der -} if null ys' && null wksubs' then putStr $ unlines (["-----BEGIN PUBLIC KEY-----"] ++split64 qq ++["-----END PUBLIC KEY-----"]) else error "Key specification is ambiguous." doCmd cmd@(Add {}) = do ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" ) <- getPGPEnviron cmd pw <- getPassphrase cmd flip (maybe (error "No working key?")) grip $ \grip -> do let (pre, wk:subs) = seek_key (KeyGrip grip) sec wkun = if symmetric_algorithm wk == Unencrypted then Just wk else do k <- decryptSecretKey pw wk guard (symmetric_algorithm k == Unencrypted) return k flip (maybe (error "Bad passphrase?")) wkun$ \wkun -> do let (uids,subkeys) = break isSubkey subs isSubkey p = isKey p && is_subkey p (subkeys',remainder) = break isTopKey subkeys isTopKey p@(SecretKeyPacket {}) | not (is_subkey p) = True isTopKey _ = False let parseKeySpec hint spec = case break (==':') spec of (fmt,_:file) -> (fmt,file) (file,"") -> (guessKeyFormat hint (key_usage cmd), file) (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd -- (pubfmt,pubfile) = parseKeySpec 'P' $ pubkey cmd Message parsedkey <- readKeyFromFile False secfmt secfile let pkf = fingerprint (head parsedkey) (prepk,pks) = seek_key (KeyGrip pkf) subkeys' g <- newGenIO timestamp <- now let uids' = do torkey <- parsedkey if key_usage cmd /= "tor" then uids else let ps = makeTorUID (g::SystemRandom) timestamp wkun (keyFlags wkun uids) wk torkey toruid = head ps in if toruid `elem` uids then uids else uids ++ ps if not (null pks) then existingKey (prepk,pks) remainder wkun wk parsedkey (key_usage cmd) pre uids' subkeys (output cmd) grip else newKey wkun wk parsedkey (key_usage cmd) pre uids' subkeys (output cmd) grip doCmd cmd@(PemFP {}) = do let parseKeySpec hint spec = case break (==':') spec of (fmt,_:file) -> (fmt,file) (file,"") -> (guessKeyFormat hint ("ssh-host"), file) (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd Message seckey <- readKeyFromFile False secfmt secfile -- Message pubkey <- readKeyFromFile True pubfmt pubfile -- Tor requires public key file... TODO -- let torhash sub = maybe "" id $ derToBase32 <$> derRSA sub putStrLn $ fingerprint (head seckey) -- ++ " " ++ torhash (head seckey) isSameKey a b = sort (key apub) == sort (key bpub) where apub = secretToPublic a bpub = secretToPublic b existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_file grip = do -- putStrLn "Key already present." let pk:trail = pks (trailsigs,trail') = span isSignaturePacket trail (mysigs,notmines) = partition (endsWith grip . maybe "%bad%" id . signature_issuer) trailsigs endsWith big small = drop (length big - length small) big == small vs = map (\sig -> (sig, map (verify (Message [wk])) (signatures $ Message [wk,pk,sig]))) mysigs (verified,unverified) = partition (not . null . snd) vs sorted = sortBy (comparing (Down . signature_time . head . snd)) verified -- Note: format allows for signatures of type 0x28 Subkey revocation signature. case sorted of [] -> do putStrLn "Adding valid signature to existing key..." newKey wkun wk [pk] tag pre uids (trail++prepk++remainder) output_file grip (sig,ov):vs -> do -- TODO: update sig to contain usage@ = tag let hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets sig) ks = map notation_value hs isNotation (NotationDataPacket {}) = True isNotation _ = False noop = do -- Nothing to do let sec' = pre ++ [wk] ++ uids ++ subkeys putStrLn $ tag ++ " key already present." L.writeFile output_file (encode (Message sec')) if tag `elem` ks then noop else do g <- newGenIO timestamp <- now let isCreation (SignatureCreationTimePacket {}) = True isCreation _ = False isExpiration (SignatureExpirationTimePacket {}) = True isExpiration _ = False (cs,ps) = partition isCreation (hashed_subpackets sig) (es,qs) = partition isExpiration ps stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs where unwrap (SignatureCreationTimePacket x) = x exp = listToMaybe $ sort $ map unwrap es where unwrap (SignatureExpirationTimePacket x) = x expires = liftA2 (+) stamp exp if fmap ( (< timestamp) . fromIntegral) expires == Just True then do putStrLn $ "Unable to update expired signature" noop else do let new_sig = fst $ sign (Message [wkun]) (SubkeySignature wk (head parsedkey) [sig'] ) SHA1 grip timestamp (g::SystemRandom) times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $ maybeToList $ do e <- expires return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) notation = NotationDataPacket { notation_name = "usage@" , notation_value = tag , human_readable = True } sig' = sig { hashed_subpackets = times ++ [notation] ++ qs } -- noop let sec' = pre ++ [wk] ++ uids ++ subkeys sec' = pre ++ [wk] ++ uids ++ prepk ++ [pk] ++ signatures_over new_sig ++ map fst vs ++ map fst unverified ++ notmines ++ trail' ++ remainder putStrLn $ "Adding usage@="++tag L.writeFile output_file (encode (Message sec')) where signature_time ov = case if null cs then ds else cs of [] -> minBound xs -> last (sort xs) where ps = signatures_over ov ss = filter isSignaturePacket ps cs = concatMap (concatMap creationTime . hashed_subpackets) ss ds = concatMap (concatMap creationTime . unhashed_subpackets) ss creationTime (SignatureCreationTimePacket t) = [t] creationTime _ = [] newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do g <- newGenIO timestamp <- now let new_sig = fst $ sign (Message [wkun]) (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 ( IssuerPacket (fingerprint wk) : map EmbeddedSignaturePacket (signatures_over back_sig)))) SHA1 grip timestamp (g::SystemRandom) hashed0 = [ KeyFlagsPacket { certify_keys = False , sign_data = False , encrypt_communication = False , encrypt_storage = False , split_key = False , authentication = True , group_key = False } , NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = tag } , SignatureCreationTimePacket (fromIntegral timestamp) ] subgrip = fingerprint (head parsedkey) back_sig = fst $ sign (Message parsedkey) (SubkeySignature wk (head parsedkey) (sigpackets 0x19 hashed0 [IssuerPacket subgrip])) SHA1 subgrip timestamp (g::SystemRandom) let sec' = pre ++ [wk] ++ uids ++ parsedkey ++ signatures_over new_sig ++ subkeys putStrLn $ listKeys sec' L.writeFile output_file (encode (Message sec')) {- let backsigs = do sig <- signatures (Message sec') sigover <- signatures_over sig subp <- unhashed_subpackets sigover -- guard (isEmbeddedSignature subp) subp <- maybeToList (backsig subp) over <- signatures (Message (filter isKey sec ++ [subp])) return over -- putStrLn $ PP.ppShow backsigs -} return () groupBindings pub = let (sigs,bindings) = getBindings pub bindings' = accBindings bindings code (c,(m,s),_,_,_) = (fingerprint_material m,-c) ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b -- matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True -- matchgrip _ = False gs = {- filter matchgrip $ -} groupBy sameMaster (sortBy (comparing code) bindings') in gs isTopKey p@(SecretKeyPacket {}) | not (is_subkey p) = True isTopKey p@(PublicKeyPacket {}) | not (is_subkey p) = True isTopKey _ = False seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) seek_key (KeyGrip grip) sec = (pre, subs) where (pre,subs) = break pred sec pred p@(SecretKeyPacket {}) = matchpr grip p == grip pred p@(PublicKeyPacket {}) = matchpr grip p == grip pred _ = False seek_key (KeyTag key tag) ps = if null bs then (ps,[]) else if null qs then let (as',bs') = seek_key (KeyTag key tag) (tail bs) in (as ++ (head bs:as'), bs') else (reverse (tail qs), head qs : reverse rs ++ bs) where (as,bs) = break (\p -> isSignaturePacket p && has_tag tag p && isJust (signature_issuer p) && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) ps (rs,qs) = break isKey (reverse as) has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) seek_key (KeyUidMatch pat) ps = if null bs then (ps,[]) else if null qs then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs) in (as ++ (head bs:as'), bs') else (reverse (tail qs), head qs : reverse rs ++ bs) where (as,bs) = break (isInfixOf pat . uidStr) ps (rs,qs) = break isKey (reverse as) uidStr (UserIDPacket s) = s uidStr _ = "" groupTops ps = groupBy (\_ b -> not (isTopKey b)) ps makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig where torhash sub = maybe "" id $ derToBase32 <$> derRSA sub s = "Anonymous " uid = UserIDPacket s sig = fst $ torsig g topkey wkun uid timestamp keyflags torsig g topk wkun uid timestamp extras = sign (Message [wkun]) (CertificationSignature (secretToPublic topk) uid (sigpackets 0x13 subpackets subpackets_unh)) SHA1 (fingerprint wkun) {- (fromJust wkgrip) -} timestamp g where subpackets = [ SignatureCreationTimePacket (fromIntegral timestamp) ] ++ tsign ++ extras subpackets_unh = [IssuerPacket (fingerprint wkun)] tsign = if keykey wkun == keykey topk then [] -- tsign doesnt make sense for self-signatures else [ TrustSignaturePacket 1 120 , RegularExpressionPacket regex] -- <[^>]+[@.]asdf\.nowhere>$ regex = "<[^>]+[@.]"++hostname++">$" -- regex = username ++ "@" ++ hostname -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String hostname = subdomain' pu ++ "\\." ++ topdomain' pu pu = parseUID uidstr where UserIDPacket uidstr = uid subdomain' = escape . T.unpack . uid_subdomain topdomain' = escape . T.unpack . uid_topdomain escape s = concatMap echar s where echar '|' = "\\|" echar '*' = "\\*" echar '+' = "\\+" echar '?' = "\\?" echar '.' = "\\." echar '^' = "\\^" echar '$' = "\\$" echar '\\' = "\\\\" echar '[' = "\\[" echar ']' = "\\]" echar c = [c] sigpackets typ hashed unhashed = return $ signaturePacket 4 -- version typ -- 0x18 subkey binding sig, or 0x19 back-signature RSA SHA1 hashed unhashed 0 -- Word16 -- Left 16 bits of the signed hash value [] -- [MPI] keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) where vs = map (verify (Message [wkun])) (signatures (Message (wkun:uids))) ws = map signatures_over vs xs = filter null ws keyFlags0 wkun uidsigs = concat [ keyflags , preferredsym , preferredhash , preferredcomp , features ] where subs = concatMap hashed_subpackets uidsigs keyflags = filterOr isflags subs $ KeyFlagsPacket { certify_keys = True , sign_data = True , encrypt_communication = False , encrypt_storage = False , split_key = False , authentication = False , group_key = False } preferredsym = filterOr ispreferedsym subs $ PreferredSymmetricAlgorithmsPacket [ AES256 , AES192 , AES128 , CAST5 , TripleDES ] preferredhash = filterOr ispreferedhash subs $ PreferredHashAlgorithmsPacket [ SHA256 , SHA1 , SHA384 , SHA512 , SHA224 ] preferredcomp = filterOr ispreferedcomp subs $ PreferredCompressionAlgorithmsPacket [ ZLIB , BZip2 , ZIP ] features = filterOr isfeatures subs $ FeaturesPacket { supports_mdc = True } filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs isflags (KeyFlagsPacket {}) = True isflags _ = False ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True ispreferedsym _ = False ispreferedhash (PreferredHashAlgorithmsPacket {}) = True ispreferedhash _ = False ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True ispreferedcomp _ = False isfeatures (FeaturesPacket {}) = True isfeatures _ = False