{-# 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 GHC.IO.Exception ( ioException, IOErrorType(..) ) import Data.IORef import Data.Tuple import Data.Binary import Data.OpenPGP as 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.Util (verify,fingerprint,decryptSecretKey,pgpSign) 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 qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 import qualified Crypto.Types.PubKey.ECC as ECC -- import qualified Crypto.Types.PubKey.ECDSA as ECDSA -- import qualified Crypto.PubKey.ECC.ECDSA as ECDSA 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 qualified Data.Foldable as Foldable import qualified Data.Sequence as Sequence import Control.Applicative import System.Environment import System.Directory import System.FilePath import System.Exit import System.Process import System.Posix.IO (fdToHandle,fdRead) import System.Posix.Files import System.Posix.Signals import System.Posix.Types (EpochTime) import System.Process.Internals (runGenProcess_,defaultSignal) import System.IO (hPutStrLn,stderr,withFile,IOMode(..)) import System.IO.Error import ControlMaybe import Data.Char import Control.Arrow (first,second) import Data.Traversable hiding (mapM,forM,sequence) import qualified Data.Traversable as Traversable (mapM,forM,sequence) -- import System.Console.CmdArgs -- import System.Posix.Time import Data.Time.Clock.POSIX import Data.Monoid ((<>)) -- import Data.X509 import qualified Data.Map as Map import DotLock -- import Codec.Crypto.ECC.Base -- hecc package import Text.Printf import qualified CryptoCoins as CryptoCoins import qualified Hosts import Network.Socket -- (SockAddr) -- instance Default S.ByteString where def = S.empty -- DER-encoded elliptic curve ids nistp256_id = 0x2a8648ce3d030107 secp256k1_id = 0x2b8104000a isCryptoCoinKey p = and [ isKey p , key_algorithm p == ECDSA , lookup 'c' (key p) == Just (MPI secp256k1_id) ] getCryptoCoinTag p | isSignaturePacket p = do -- CryptoCoins.secret let sps = hashed_subpackets p ++ unhashed_subpackets p u <- listToMaybe $ mapMaybe usage sps CryptoCoins.lookupNetwork CryptoCoins.network_name u getCryptoCoinTag _ = Nothing warn str = hPutStrLn stderr str 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) -- ?? d mod (p-1) 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 :: Packet -> Maybe RSAPublicKey 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 []) rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do -- public fields... n <- lookup 'n' $ key pkt e <- lookup 'e' $ key pkt -- secret fields MPI d <- lookup 'd' $ key pkt MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped -- Note: Here we fail if 'u' key is missing. -- Ideally, it would be better to compute (inverse q) mod p -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg -- (package constructive-algebra) coefficient <- lookup 'u' $ key pkt let dmodp1 = MPI $ d `mod` (p - 1) dmodqminus1 = MPI $ d `mod` (q - 1) return $ RSAPrivateKey { rsaN = n , rsaE = e , rsaD = MPI d , rsaP = MPI p , rsaQ = MPI q , rsaDmodP1 = dmodp1 , rsaDmodQminus1 = dmodqminus1 , rsaCoefficient = coefficient } rsaPrivateKeyFromPacket _ = Nothing {- 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 -- , ecc_curve = ecc_curve 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 writePEM typ dta = pem where pem = unlines . concat $ [ ["-----BEGIN " <> typ <> "-----"] , split64s dta , ["-----END " <> typ <> "-----"] ] split64s "" = [] split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta -- 64 byte lines 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 isPublicMaster k@(PublicKeyPacket {}) = not $ is_subkey k isPublicMaster _ = 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.drop 1-> 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 ecc_curve k = printf "%x" num :: String where unmpi (MPI num) = num num = maybe 0 unmpi $ lookup 'c' (key k) 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) showsigs claimants = map (\k -> " " ++ "^ signed: " ++ fingerprint k) claimants 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 (netid,kind') = maybe (0x0,"bitcoin") (\n->(CryptoCoins.publicByteFromName n,n)) $ listToMaybe kind unlines $ concat [ " " -- , grip top , ar , formkind , " " , fingerprint sub -- , " " ++ torhash -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) ] -- ++ ppShow hashed : if isCryptoCoinKey sub -- then (" " ++ "B⃦ " ++ bitcoinAddress sub) : showsigs claimants -- then (" " ++ "BTC " ++ bitcoinAddress sub) : showsigs claimants then (" " ++ "¢ "++kind'++":" ++ bitcoinAddress netid sub) : showsigs claimants else showsigs claimants 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 ] ++ showsigs 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" #if MIN_VERSION_base(4,6,0) #else lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif unmaybe def = fmap (maybe def id) expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) | otherwise = c:cs expandPath path [] = [] -- type TimeStamp = Word32 slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) slurpWIPKeys stamp "" = ([],[]) slurpWIPKeys stamp cs = let (b58,xs) = Char8.span (\x -> elem x base58chars) cs mb = decode_btc_key stamp (Char8.unpack b58) in if L.null b58 then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs (ks,js) = slurpWIPKeys stamp xs' in (ks,ys:js) else let (ks,js) = slurpWIPKeys stamp xs in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb readPacketsFromWallet :: Maybe Packet -> FilePath -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] readPacketsFromWallet wk fname = do timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname input <- L.readFile fname let (ks,junk) = slurpWIPKeys timestamp input when (not (null ks)) $ do -- decrypt wk -- create sigs -- return key/sig pairs return () return $ do wk <- maybeToList wk guard (not $ null ks) let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk)) where tag = CryptoCoins.nameFromSecretByte tagbyte (wk,MarkerPacket,(MarkerPacket,Map.empty)) :map prep ks readPacketsFromFile :: FilePath -> IO Message readPacketsFromFile fname = do -- warn $ fname ++ ": reading..." input <- L.readFile fname #if MIN_VERSION_binary(0,6,4) return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> trace (fname++": read fail") $ Message [] #else return $ decode input #endif lockFiles fs = do let dolock f = do lk <- dotlock_create f 0 let fail = return Nothing dotake lk = do e <- dotlock_take lk (-1) if e==0 then return (Just lk) else fail v <- maybe fail dotake lk return (v,f) ls <- mapM dolock fs let (lks, fails) = partition (isJust . fst) ls return (map (\(lk,f)->(fromJust lk,f)) lks, map snd fails) unlockFiles lks = forM_ lks $ \(lk,f) -> do -- warn $ "unlocking "++show f dotlock_release lk 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" writeKeyToFile False "PEM" fname packet = case key_algorithm packet of RSA -> do flip (maybe (return ())) (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey $ \rsa -> do let asn1 = toASN1 rsa [] bs = encodeASN1 DER asn1 dta = Base64.encode (L.unpack bs) output = writePEM "RSA PRIVATE KEY" dta stamp = toEnum . fromEnum $ timestamp packet createDirectoryIfMissing True (takeDirectory fname) handleIO_ (warn $ fname ++ ": write failure") $ do saved_mask <- setFileCreationMask 0o077 writeFile fname output -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. setFileTimes fname stamp stamp setFileCreationMask saved_mask return () warn $ fname ++ ": exported" return () algo -> warn $ fname ++ ": unable to export "++show algo++" key "++fingerprint packet readKeyFromFile False "PEM" fname = do -- warn $ fname ++ ": reading ..." -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 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) ] -- , ecc_curve = def , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) {- 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 deriving Show 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 :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] 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 data OriginFlags = OriginFlags { originallyPublic :: Bool, originalNum :: Int } deriving Show origin :: Packet -> Int -> OriginFlags origin p n = OriginFlags ispub n where ispub = case p of SecretKeyPacket {} -> False _ -> True type OriginMap = Map.Map FilePath OriginFlags data MappedPacket = MappedPacket { packet :: Packet , usage_tag :: Maybe String , locations :: OriginMap } mappedPacket filename p = MappedPacket { packet = p , usage_tag = Nothing , locations = Map.singleton filename (origin p (-1)) } type TrustMap = Map.Map FilePath Packet type SigAndTrust = ( MappedPacket , TrustMap ) -- trust packets type KeyKey = [Char8.ByteString] data SubKey = SubKey MappedPacket [SigAndTrust] data KeyData = KeyData MappedPacket -- main key [SigAndTrust] -- sigs on main key (Map.Map String ([SigAndTrust],OriginMap)) -- uids (Map.Map KeyKey SubKey) -- subkeys type KeyDB = Map.Map KeyKey KeyData torhash key = maybe "" id $ derToBase32 <$> derRSA key keykey key = -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, the same key with a different timestamp is -- considered distinct using this keykey implementation. fingerprint_material (key {timestamp=0}) -- 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 | keykey a==keykey 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 | keykey a==keykey b = EQ subcomp a b = error $ unlines ["Unable to merge subs:" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] subcomp_m a b = subcomp (packet a) (packet b) merge :: KeyDB -> FilePath -> Message -> KeyDB merge db filename (Message ps) = merge_ db filename qs where qs = scanPackets filename ps merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) where asMapped n p = let m = mappedPacket filename p in m { locations = fmap (\x->x {originalNum=n}) (locations m) } asSigAndTrust n (p,tm) = (asMapped n p,tm) emptyUids = Map.empty -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db where -- NOTE: -- if a keyring file has both a public key packet and a secret key packet -- for the same key, then only one of them will survive, which ever is -- later in the file. -- -- This is due to the use of statements like -- (Map.insert filename (origin p n) (locations key)) -- update v | isKey p && not (is_subkey p) = case v of Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p])) { locations = Map.insert filename (origin p n) (locations key) } ) 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 n p) (keykey p) subkeys) update (Just (KeyData key sigs uids subkeys)) | isUserID p = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) subkeys update (Just (KeyData key sigs uids subkeys)) = case sub of MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys UserIDPacket {} -> Just $ KeyData key sigs (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) subkeys _ | isKey sub -> Just $ KeyData key sigs uids (Map.alter (mergeSubSig n 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 :: Int -> Packet -> Maybe SubKey -> Maybe SubKey mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] mergeSubkey n p (Just (SubKey key sigs)) = Just $ SubKey ((asMapped n (minimumBy subcomp [packet key,p])) { locations = Map.insert filename (origin p n) (locations key) }) sigs mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n)) mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m) mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p whatP (a,_) = concat . take 1 . words . show $ a mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust] mergeSig n sig sigs = let (xs,ys) = break (isSameSig sig) sigs in if null ys then sigs++[first (asMapped n) sig] else let y:ys'=ys in xs ++ (mergeSameSig n sig y : ys') isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } isSameSig (a,_) (MappedPacket {packet=b},_) = a==b mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b = ( m { packet = (b { unhashed_subpackets = foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) }) , locations = Map.insert filename (origin a n) locs } , tb `Map.union` ta ) where -- TODO: when merging items, we should delete invalidated origins -- from the orgin map. mergeItem ys x = if x `elem` ys then ys else ys++[x] mergeSameSig n a b = trace ("discarding dup "++show a) b mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m) mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty) mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs) mergeSubSig n sig Nothing = error $ "Unable to merge subkey signature: "++(words (show sig) >>= take 1) flattenKeys :: Bool -> KeyDB -> Message flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) where prefilter = if isPublic then id else filter isSecret where isSecret (_,(KeyData (MappedPacket { packet=(SecretKeyPacket {})}) _ _ _)) = True isSecret _ = False concatSort fname getp f = concat . sortByHint fname getp . map f flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] flattenTop fname ispub (KeyData key sigs uids subkeys) = unk ispub key : ( flattenAllUids fname ispub uids ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] flattenAllUids fname ispub uids = concatSort fname head (flattenUid fname ispub) (Map.assocs uids) flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] flattenUid fname ispub (str,(sigs,om)) = (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs unk :: Bool -> MappedPacket -> MappedPacket unk isPublic = if isPublic then toPacket secretToPublic else id where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] unsig fname isPublic (sig,trustmap) = [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) where f n _ = n==fname -- && trace ("fname=n="++show n) True asMapped n p = let m = mappedPacket fname p in m { locations = fmap (\x->x {originalNum=n}) (locations m) } ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f showPacket :: Packet -> String showPacket p | isKey p = (if is_subkey p then showPacket0 p else ifSecret p "----Secret-----" "----Public-----") ++ " "++show (key_algorithm p)++" "++fingerprint p | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) | otherwise = showPacket0 p showPacket0 p = concat . take 1 $ words (show p) sortByHint fname f = sortBy (comparing gethint) where gethint = maybe defnum originalNum . Map.lookup fname . locations . f defnum = -1 keyPacket (KeyData k _ _ _) = k writeOutKeyrings :: Map.Map FilePath DotLock -> KeyDB -> IO () writeOutKeyrings lkmap db = do let ks = Map.elems db fs = Map.keys (foldr unionfiles Map.empty ks) where unionfiles (KeyData p _ _ _) m = Map.union m (locations p) fromfile f (KeyData p _ _ _) = Map.member f $ locations p let s = do f <- fs let x = do d@(KeyData p _ _ _) <- filter (fromfile f) (sortByHint f keyPacket ks) n <- maybeToList $ Map.lookup f (locations p) flattenTop f (originallyPublic n) d changes = filter isnew x where isnew p = isNothing (Map.lookup f $ locations p) {- trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++ ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do -} return (f,(changes,x)) towrites <- fmap catMaybes $ Control.Monad.forM s $ \(f,(changes,x)) -> do let noop = return Nothing write f = return (Just f) case changes of [] -> noop -- warn (f ++": nothing to do.") >> noop cs -> case Map.lookup f lkmap of Just lk -> do forM_ cs $ \c -> warn $ f++": new "++showPacket (packet c) write (f,lk,x) Nothing -> do forM_ cs $ \c -> warn $ f++": missing "++showPacket (packet c) noop forM_ towrites $ \(f,lk,x) -> do let m = Message $ map packet x -- warn $ "writing "++f L.writeFile f (encode m) cross_merge doDecrypt grip0 keyrings wallets f = do let relock = do (fsns,failed_locks) <- lockFiles keyrings (wsns,failed_wlocks) <- lockFiles wallets forM_ (failed_locks++failed_wlocks) $ \f -> warn $ "Failed to lock: " ++ f return (fsns,wsns,failed_locks,failed_wlocks) sec_n:_ = keyrings (fsns,wsns,failed_locks,failed_wlocks) <- relock -- let (lks,fs) = unzip fsns -- forM_ fs $ \f -> warn $ "locked: " ++ f let readp n = fmap (n,) (readPacketsFromFile n) readw wk n = fmap (n,) (readPacketsFromWallet wk n) let pass n (fsns,failed_locks) = do ms <- mapM readp (map snd fsns++failed_locks) let db0 = foldl' (uncurry . merge) Map.empty ms fstkey = listToMaybe $ mapMaybe isSecringKey ms where isSecringKey (fn,Message ps) | fn==sec_n = listToMaybe ps isSecringKey _ = Nothing grip = grip0 `mplus` (fingerprint <$> fstkey) wk = listToMaybe $ do fp <- maybeToList grip elm <- Map.toList db0 guard $ matchSpec (KeyGrip fp) elm let undata (KeyData p _ _ _) = packet p return $ undata (snd elm) wms <- mapM (readw wk) (map snd wsns++failed_wlocks) let -- db1= foldl' (uncurry . merge_) db0 wms ts = do maybeToList wk (fname,xs) <- wms (_,sub,(_,m)) <- xs (tag,top) <- Map.toList m return (top,fname,sub,tag) -- sig' <- makeSig doDecrypt top fname subkey_p tag mbsig importWalletKey db' (top,fname,sub,tag) = do doImportG doDecrypt db' (fmap keykey $ maybeToList wk) tag fname sub db <- foldM importWalletKey db0 ts let cs = do wk <- maybeToList wk let kk = keykey wk KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db (subkk,SubKey mp sigs) <- Map.toList subs let sub = packet mp guard $ isCryptoCoinKey sub tag <- take 1 $ mapMaybe getCryptoCoinTag (map (packet . fst) sigs) return (tag,mp) -- export wallet keys forM_ wsns $ \(_,n) -> do let cs' = do (nw,mp) <- cs let fns = Map.keys (locations mp) -- trace ("COIN KEY: "++show fns) $ return () guard . not $ Map.member n (locations mp) let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp) return (CryptoCoins.network_name nw,wip) handleIO_ (return ()) $ do withFile n AppendMode $ \fh -> do forM_ cs' $ \(net,wip) -> do warn $ n++": new WalletKey "++net hPutStrLn fh wip -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings ------------------------------- from external tools. (db',_) <- f (sec_n,grip) db -- lk <- relock --------------- The design is not quite safe, so it is disabled for now. let lk = (fsns,failed_locks) -- ------------------------------- maybe (if n==0 then pass 1 lk else return (lk,db)) (return . (lk,)) db' ((fsns,failed_locks),db) <- pass 0 (fsns,failed_locks) let lkmap = Map.fromList $ map swap fsns writeOutKeyrings lkmap db unlockFiles fsns unlockFiles wsns return () {- data Arguments = Cross_Merge { homedir :: Maybe FilePath , passphrase_fd :: Maybe Int , files :: [FilePath] } deriving (Show, Data, Typeable) -} toLast f [] = [] toLast f [x] = [f x] toLast f (x:xs) = x : toLast f xs partitionStaticArguments specs args = psa args where smap = Map.fromList specs psa [] = ([],[]) psa (a:as) = case Map.lookup a smap of Nothing -> second (a:) $ psa as Just n -> first ((a:take n as):) $ psa (drop n as) show_wk secring_file grip db = do let sec_db = Map.filter gripmatch db gripmatch (KeyData p _ _ _) = Map.member secring_file (locations p) Message sec = flattenKeys False sec_db putStrLn $ listKeysFiltered (maybeToList grip) sec show_all db = do let Message packets = flattenKeys True db -- let ks = filter isKey packets -- forM_ ks (warn . showPacket) -- warn $ "BEGIN LIST "++show (length packets)++" packets." putStrLn $ listKeys packets -- warn $ "END LIST "++show (length packets)++" packets." show_pem keyspec wkgrip db = do let s = parseSpec wkgrip keyspec flip (maybe $ warn (keyspec ++ ": not found") >> return ()) (selectPublicKey s db) $ \k -> do let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k der = encodeASN1 DER (toASN1 rsa []) qq = Base64.encode (L.unpack der) putStrLn $ writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec) show_key keyspec wkgrip db = do let s = parseSpec "" keyspec let ps = do (_,k) <- filterMatches (fst s) (Map.toList db) mp <- flattenTop "" True k return $ packet mp -- putStrLn $ "show key " ++ show s putStrLn $ listKeys ps show_wip keyspec wkgrip db = do let s = parseSpec wkgrip keyspec flip (maybe $ warn (keyspec ++ ": not found") >> return ()) (selectSecretKey s db) $ \k -> do let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s putStrLn $ walletImportFormat nwb k parseSpec :: String -> String -> (KeySpec,Maybe String) parseSpec grip spec = (topspec,subspec) where (topspec0,subspec0) = unprefix '/' spec (toptyp,top) = unprefix ':' topspec0 (subtyp,sub) = unprefix ':' subspec0 topspec = case () of _ | null top && or [ subtyp=="fp" , null subtyp && is40digitHex sub ] -> KeyGrip sub _ | null top && null grip -> KeyUidMatch sub _ | null top -> KeyGrip grip _ | toptyp=="fp" || (null toptyp && is40digitHex top) -> {- trace "using top" $ -} KeyGrip top _ | toptyp=="u" -> KeyUidMatch top _ | otherwise -> KeyUidMatch top subspec = case subtyp of "t" -> Just sub "fp" | top=="" -> Nothing "" | top=="" && is40digitHex sub -> Nothing "" -> listToMaybe sub >> Just sub splitAtMinBy comp xs = minimumBy comp' xxs where xxs = zip (inits xs) (tails xs) comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) compM (Just a) (Just b) = comp a b compM Nothing mb = GT compM _ _ = LT -- | systemEnv -- This is like System.Process.system except that it lets you set -- some environment variables. systemEnv _ "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") systemEnv vars cmd = do env0 <- getEnvironment let env1 = filter (isNothing . flip lookup vars . fst) env0 env = vars ++ env1 syncProcess "system" $ (shell cmd) {env=Just env} where -- This is a non-exported function from System.Process syncProcess fun c = do -- The POSIX version of system needs to do some manipulation of signal -- handlers. Since we're going to be synchronously waiting for the child, -- we want to ignore ^C in the parent, but handle it the default way -- in the child (using SIG_DFL isn't really correct, it should be the -- original signal handler, but the GHC RTS will have already set up -- its own handler and we don't want to use that). old_int <- installHandler sigINT Ignore Nothing old_quit <- installHandler sigQUIT Ignore Nothing (_,_,_,p) <- runGenProcess_ fun c (Just defaultSignal) (Just defaultSignal) r <- waitForProcess p _ <- installHandler sigINT old_int Nothing _ <- installHandler sigQUIT old_quit Nothing return r doExport doDecrypt (db,use_db) (fname,subspec,ms,cmd) = case ms of [_] -> export (_:_) -> ambiguous [] -> shcmd where ambiguous = error "Key specification is ambiguous." shcmd = do let noop warning = do warn warning return (db,use_db) if null cmd then noop (fname ++ ": missing.") else do let vars = [ ("file",fname) , ("usage",maybe "" id subspec) ] e <- systemEnv vars cmd case e of ExitFailure num -> noop $ fname ++ ": failed external (code="++show num++")" ExitSuccess -> do warn $ fname ++ ": generated" return (Nothing,use_db) -- need another pass export = do let [kk] = ms Just (KeyData key sigs uids subkeys) = Map.lookup kk use_db p = flip (maybe (Just $ packet key)) subspec $ \tag -> do let subs = Map.elems subkeys doSearch (SubKey sub_mp sigtrusts) = let (_,v,_) = findTag tag (packet key) (packet sub_mp) sigtrusts in fmap fst v==Just True case filter doSearch subs of [SubKey mp _] -> Just $ packet mp [] -> Nothing _ -> ambiguous flip (maybe shcmd) p $ \p -> do pun <- doDecrypt p flip (maybe $ error "Bad passphrase?") pun $ \pun -> do writeKeyToFile False "PEM" fname pun return (db,use_db) findTag tag wk subkey subsigs = (xs',minsig,ys') where vs = map (\sig -> (sig, do sig <- Just (packet . fst $ sig) guard (isSignaturePacket sig) guard $ flip isSuffixOf (fingerprint wk) . maybe "%bad%" id . signature_issuer $ sig listToMaybe $ map (signature_time . verify (Message [wk])) (signatures $ Message [wk,subkey,sig]))) subsigs (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs xs' = map fst xs ys' = map fst $ if isNothing minsig then ys else drop 1 ys minsig = do (sig,ov) <- listToMaybe ys ov let hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets . packet . fst $ sig) ks = map notation_value hs isNotation (NotationDataPacket {}) = True isNotation _ = False return (tag `elem` ks, sig) {- applyCurve curve x = x*x*x + x*a + b where (a,b)=(geta curve,getb curve) secp256k1_oid = [1,3,132,0,10] secp256k1_curve = ECi l a b p r where -- y² = x³ + 7 (mod p) p = 0x0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F a = 0 b = 7 -- group order (also order of base point G) r = n n = 0x0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 -- cofactor h = 1 -- bit length l = 256 secp256k1_G = ECPa secp256k1_curve 0x79BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798 0x483ADA7726A3C4655DA4FBFC0E1108A8FD17B448A68554199C47D08FFB10D4B8 {- The base point G in compressed form is: G = 02 79BE667E F9DCBBAC 55A06295 CE870B07 029BFCDB 2DCE28D9 59F2815B 16F81798 and in uncompressed form is: G = 04 79BE667E F9DCBBAC 55A06295 CE870B07 029BFCDB 2DCE28D9 59F2815B 16F81798 483ADA77 26A3C465 5DA4FBFC 0E1108A8 FD17B448 A6855419 9C47D08F FB10D4B8 -} -} base58chars = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" base58digits :: [Char] -> Maybe [Int] base58digits str = sequence mbs where mbs = map (flip elemIndex base58chars) str -- 5HueCGU8rMjxEXxiPuD5BDku4MkFqeZyd4dZ1jvhTVqvbTLvyTJ base58_decode :: [Char] -> Maybe (Word8,[Word8]) base58_decode str = do ds <- base58digits str let n = foldl' (\a b-> a*58 + b) 0 $ ( map fromIntegral ds :: [Integer] ) rbytes = unfoldr getbyte n getbyte d = do guard (d/=0) let (q,b) = d `divMod` 256 return (fromIntegral b,q) let (rcksum,rpayload) = splitAt 4 $ rbytes a_payload = reverse rpayload hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload expected_hash = S.pack $ reverse rcksum (network_id,payload) = splitAt 1 a_payload network_id <- listToMaybe network_id guard (hash_result==expected_hash) return (network_id,payload) walletImportFormat idbyte k = secret_base58_foo where isSecret (SecretKeyPacket {}) = True isSecret _ = False secret_base58_foo = base58_encode seckey Just d = lookup 'd' (key k) (len16,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) seckey = S.cons idbyte bigendian base58_encode :: S.ByteString -> String base58_encode hash = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits) where zcount = S.length . S.takeWhile (==0) $ hash cksum = S.take 4 . SHA256.hash . SHA256.hash $ hash n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hash, cksum] asInteger x = fromIntegral x :: Integer rdigits = unfoldr getdigit n where getdigit d = do guard (d/=0) let (q,b) = d `divMod` 58 return (fromIntegral b,q) cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8] where numToBytes n = reverse $ unfoldr getbyte n where getbyte d = do guard (d/=0) let (q,b) = d `divMod` 256 return (fromIntegral b,q) pad32 xs = replicate zlen 0 ++ xs where zlen = 32 - length xs oidToDER ns = S.pack $ b1 : concatMap encode ys where (xs,ys) = splitAt 2 ns b1 = fromIntegral $ foldl' (\a b->a*40+b) 0 xs encode x | x <= 127 = [fromIntegral x] | otherwise = (\(x:xs)-> reverse (x:map (0x80 .|.) xs)) (base128r x) base128r n = unfoldr getbyte n where getbyte d = do guard (d/=0) let (q,b) = d `divMod` 128 return (fromIntegral b,q) nistp256=[1,2,840,10045,3,1,7] nistp256_der=[0x2A,0x86,0x48,0xCE,0x3D,0x03,0x01,0x07] -- "\x2a\x86\x48\xce\x3d\x03\x01\x07" {- OID Curve description Curve name ---------------------------------------------------------------- 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256" 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384" 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521" Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST P-521". The hexadecimal representation used in the public and private key encodings are: Curve Name Len Hexadecimal representation of the OID ---------------------------------------------------------------- "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 -} bitcoinAddress network_id k = address where Just (MPI x) = lookup 'x' (key k) Just (MPI y) = lookup 'y' (key k) pub = cannonical_eckey x y hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub address = base58_encode hash -- gpg supported ECDSA curve: 2A8648CE3D030107 -- 2A 86 48 CE 3D 03 01 07 -- 1,2,134,72,206,61,3,1,7 -- 6*128+0x48 840 -- 0x4e*128+0x3d 10045 -- 1.2.840.10045.3.1.7 --> NIST P-256 -- decode_btc_key timestamp str = do (network_id,us) <- base58_decode str return . (network_id,) $ Message $ do let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) {- xy = secp256k1_G `pmul` d x = getx xy y = gety xy -- y² = x³ + 7 (mod p) y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve) y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve) -} secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1 pub = cannonical_eckey x y hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub address = base58_encode hash pubstr = concatMap (printf "%02x") $ pub _ = pubstr :: String return $ {- trace (unlines ["pub="++show pubstr ,"add="++show address ,"y ="++show y ,"y' ="++show y' ,"y''="++show y'']) -} SecretKeyPacket { version = 4 , timestamp = toEnum (fromEnum timestamp) , key_algorithm = ECDSA , key = [ -- public fields... ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve) ,('l',MPI 256) ,('x',MPI x) ,('y',MPI y) -- secret fields ,('d',MPI d) ] , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } doBTCImport doDecrypt db (ms,subspec,content) = do let fetchkey = do timestamp <- now let mbk = fmap discardNetworkID $ decode_btc_key timestamp content discardNetworkID = snd return $ maybe (Message []) id mbk let error s = do warn s exitFailure flip (maybe $ error "Cannot import master key.") subspec $ \tag -> do Message parsedkey <- fetchkey flip (maybe $ return db) (listToMaybe parsedkey) $ \key -> do let (m0,tailms) = splitAt 1 ms when (not (null tailms) || null m0) $ error "Key specification is ambiguous." doImportG doDecrypt db m0 tag "" key doImport doDecrypt db (fname,subspec,ms,_) = do let fetchkey = readKeyFromFile False "PEM" fname let error s = do warn s exitFailure flip (maybe $ error "Cannot import master key.") subspec $ \tag -> do Message parsedkey <- fetchkey flip (maybe $ return db) (listToMaybe parsedkey) $ \key -> do let (m0,tailms) = splitAt 1 ms when (not (null tailms) || null m0) $ error "Key specification is ambiguous." doImportG doDecrypt db m0 tag fname key doImportG doDecrypt db m0 tag fname key = do let error s = do warn s exitFailure let kk = head m0 Just (KeyData top topsigs uids subs) = Map.lookup kk db subkk = keykey key (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) []) ( (False,) . addOrigin ) (Map.lookup subkk subs) where addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) (locations mp) } in SubKey mp' sigs subs' = Map.insert subkk subkey subs istor = do guard (tag == "tor") return $ "Anonymous " uids' <- flip (maybe $ return uids) istor $ \idstr -> do let has_torid = do -- TODO: check for omitted real name field (sigtrusts,om) <- Map.lookup idstr uids listToMaybe $ do s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) signatures_over $ verify (Message [packet top]) s flip (flip maybe $ const $ return uids) has_torid $ do wkun <- doDecrypt (packet top) flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) uid = UserIDPacket idstr -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags tor_ov = torSigOver (packet top) wkun uid keyflags sig_ov <- pgpSign (Message [wkun]) tor_ov SHA1 (fingerprint wkun) flip (maybe $ warn "Failed to make signature" >> return uids) (sig_ov >>= listToMaybe . signatures_over) $ \sig -> do let om = Map.singleton fname (origin sig (-1)) trust = Map.empty return $ Map.insert idstr ([( (mappedPacket fname sig) {locations=om} ,trust)],om) uids let SubKey subkey_p subsigs = subkey wk = packet top (xs',minsig,ys') = findTag tag wk key subsigs doInsert mbsig db = do sig' <- makeSig doDecrypt top fname subkey_p tag mbsig warn $ fname ++ ": yield SignaturePacket" let subs' = Map.insert subkk (SubKey subkey_p $ xs'++[sig']++ys') subs return $ Map.insert kk (KeyData top topsigs uids' subs') db when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key)) case minsig of Nothing -> doInsert Nothing db -- we need to create a new sig Just (True,sig) -> -- we can deduce is_new == False -- we may need to add a tor id return $ Map.insert kk (KeyData top topsigs uids' subs') db Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag makeSig doDecrypt top fname subkey_p tag mbsig = do let wk = packet top wkun <- doDecrypt wk flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do let grip = fingerprint wk addOrigin new_sig = do flip (maybe $ error "Failed to make signature.") (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do let mp' = mappedPacket fname new_sig return (mp', Map.empty) parsedkey = [packet $ subkey_p] 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 } -- implicitly added: -- , SignatureCreationTimePacket (fromIntegral timestamp) ] subgrip = fingerprint (head parsedkey) back_sig <- pgpSign (Message parsedkey) (SubkeySignature wk (head parsedkey) (sigpackets 0x19 hashed0 [IssuerPacket subgrip])) (if key_algorithm (head parsedkey)==ECDSA then SHA256 else SHA1) subgrip let iss = IssuerPacket (fingerprint wk) cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) unhashed0 = maybe [iss] cons_iss back_sig new_sig <- pgpSign (Message [wkun]) (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0)) SHA1 grip let newSig = addOrigin new_sig flip (maybe newSig) mbsig $ \(mp,trustmap) -> do let sig = packet mp 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 timestamp <- now if fmap ( (< timestamp) . fromIntegral) expires == Just True then do warn $ "Unable to update expired signature" return (mp,trustmap) else do let 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 } new_sig <- pgpSign (Message [wkun]) (SubkeySignature wk (packet subkey_p) [sig'] ) SHA1 (fingerprint wk) addOrigin new_sig 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 _ = [] -- We return into IO in case we want to make a signature here. setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = -- TODO: we are removing the origin from the UID OriginMap, -- when we should be removing origins from the locations -- field of the sig's MappedPacket records. -- Call getHostnames and compare to see if no-op. if not (pred addr) || names0 == names \\ onions then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) , " file: "++show (map Char8.unpack names) , " pred: "++show (pred addr)]) -} (return kd) else do -- We should be sure to remove origins so that the data is written -- (but only if something changed). -- Filter all hostnames present in uids -- Write notations into first uid {- trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) , " file: "++show (map Char8.unpack names) ]) $ do -} return $ KeyData topmp topsigs uids1 subs where topk = packet topmp addr = fingerdress topk names :: [Char8.ByteString] names = Hosts.namesForAddress addr hosts (_,(onions,names0)) = getHostnames kd notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) isName (NotationDataPacket True "hostname@" _) = True isName _ = False uids0 = fmap zapIfHasName uids fstuid = head $ do p <- map packet $ flattenAllUids "" True uids guard $ isUserID p return $ uidkey p uids1 = Map.adjust addnames fstuid uids0 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin where (ss,ts) = splitAt 1 sigs f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) else (sig, tm) where p' = (packet sig) { unhashed_subpackets=uh } uh = unhashed_subpackets (packet sig) ++ notations zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin else (sigs,om) where (bs, sigs') = unzip $ map unhash sigs unhash (sig,tm) = ( not (null ns) , ( sig { packet = p', locations = Map.empty } , tm ) ) where psig = packet sig p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } else psig uh = unhashed_subpackets $ psig (ns,ps) = partition isName uh socketFamily (SockAddrInet _ _) = AF_INET socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 socketFamily (SockAddrUnix _) = AF_UNIX hasFingerDress :: KeyDB -> SockAddr -> Bool hasFingerDress db addr | socketFamily addr/=AF_INET6 = False hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) where (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr g' = map toUpper g fingerdress :: Packet -> SockAddr fingerdress topk = maybe zero id $ Hosts.inet_pton addr_str where zero = SockAddrInet 0 0 addr_str = colons $ "fd" ++ (drop 10 $ map toLower $ fingerprint topk) colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs colons xs = xs {- onionName :: KeyData -> (SockAddr,L.ByteString) onionName kd = (addr,name) where (addr,(name:_,_)) = getHostnames kd -} getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) where othernames = do mp <- flattenAllUids "" True uids let p = packet mp guard $ isSignaturePacket p uh <- unhashed_subpackets p case uh of NotationDataPacket True "hostname@" v -> return $ Char8.pack v _ -> mzero addr = fingerdress topk name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key? topk = packet topmp torkeys = do SubKey k sigs <- Map.elems subs let subk = packet k let sigs' = do torsig <- filter (has_tag "tor") $ map (packet . fst) sigs sig <- (signatures $ Message [topk,subk,torsig]) let v = verify (Message [topk]) sig -- Require parent's signature guard (not . null $ signatures_over v) let unhashed = unhashed_subpackets torsig subsigs = mapMaybe backsig unhashed -- This should consist only of 0x19 values -- subtypes = map signature_type subsigs sig' <- signatures . Message $ [topk,subk]++subsigs let v' = verify (Message [subk]) sig' -- Require subkey's signature guard . not . null $ signatures_over v' return torsig guard (not $ null sigs') return $ subk has_tag tag p = isSignaturePacket p && or [ tag `elem` mapMaybe usage (hashed_subpackets p) , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] subkeyPacket (SubKey k _ ) = k onames :: [L.ByteString] onames = map ( (<> ".onion") . Char8.pack . take 16 . torhash ) torkeys kiki_usage = do putStr . unlines $ ["kiki - a pgp key editing utility" ,"" ,"kiki [OPTIONS]" ,"" ," kiki merges a set of keyring files into a combined database and then" ," uses the database to update the files so that they have the most complete" ," information." ,"" ," The files pubring.gpg and subring.gpg in the directory specified by the " ," --homedir option are implicitly included in the keyring set." ,"" ," kiki can also import or export secret subkeys by using the --keypairs option." ,"" ," Subkeys that are imported with kiki are given an annotation \"usage@\" which" ," indicates what the key is for. This tag can be used as a SPEC to select a" ," particular key. Master keys may be specified by using fingerprints or by" ," specifying a substring of an associated UID." ,"" ,"Flags:" ," --homedir DIR" ," Where to find the the files secring.gpg and pubring.gpg. The " ," default location is taken from the environment variable " ," GNUPGHOME." ,"" ," --passphrase-fd N" ," Read passphrase from the given file descriptor." ,"" ," --import Add master keys to pubring.gpg. Without this option, only UID" ," and subkey data is updated. " ,"" ," --autosign Sign all cross-certified tor-style UIDs." ," A tor-style UID is of the form:" ," Anonymous " ," It is considered cross certified if there exists a cross-certified" ," 'tor' subkey corresponding to the address HOSTNAME.onion." ,"" ,"Merging:" ," --keyrings FILE FILE..." ," Provide keyring files other than the implicit secring.gpg and" ," pubring.gpg in the --homedir. This option is implicit unless" ," --keypairs or --wallets is used." ,"" ," --wallets FILE FILE..." ," Provide wallet files with secret crypto-coin keys in Wallet" ," Import Format. The keys will be treated as subkeys of your" ," current working key (the one shown by --show-wk)." ,"" ," --keypairs KEYSPEC KEYSPEC..." ," Each KEYSPEC specifies that a key should match the content and" ," timestamp of an external PKCS #1 private RSA key file." ," " ," KEYSPEC ::= SPEC=FILE{CMD} " ,"" ," If neither SPEC or FILE match any keys, then the CMD will be " ," executed in order to create the FILE." ,"" ,"Output:" ," --show-wk Show fingerprints for the working key (which will be used to" ," make signatures) and all its subkeys and UID." ,"" ," --show-key Show fingerprints for the specified key and all its subkeys" ," and UID." ,"" ," --show-all Show fingerprints and UIDs and usage tags for all known keys." ,"" ," --show-pem SPEC" ," Outputs the PKCS #8 public key corresponding to SPEC." ,"" ," --show-wip SPEC" ," Outputs the secret crypto-coin key in Wallet Input Format." ,"" ," --help Shows this help screen." ] main = do dotlock_init {- args <- cmdArgs $ modes [ Cross_Merge HOMEOPTION (def &= opt ("passphrase"::String) &= typ "FD" &= (help . concat) ["file descriptor from " ,"which to read passphrase"]) (def &= args &= typFile) &= help "Merge multiple secret keyrings to stdout." ] &= program "kiki" &= summary "kiki - a pgp key editing utility" doCmd args -} args_raw <- getArgs let (args,trail1) = break (=="--") args_raw trail = drop 1 trail1 (sargs,margs) = (sargs, foldl' (\m (k:xs)->Map.alter (appendArgs k xs) k m) Map.empty gargs) where (sargs,vargs) = partitionStaticArguments sargspec args sargspec = [ ("--homedir",1) , ("--passphrase-fd",1) , ("--import",0) , ("--autosign",0) , ("--show-wk",0) , ("--show-all",0) , ("--show-key",1) , ("--show-pem",1) , ("--show-wip",1) , ("--help",0) ] argspec = map fst sargspec ++ ["--keyrings" ,"--keypairs" ,"--wallets" ,"--hosts"] -- "--bitcoin-keypairs" -- Disabled. We shouldn't accept private key -- data on the command line. args' = if map (take 1) (take 1 vargs) == ["-"] then vargs else "--keyrings":vargs gargs = (sargs ++) . toLast (++trail) . groupBy (\_ s-> take 1 s /= "-") $ args' appendArgs k xs opt = if k `elem` argspec then Just . maybe xs (++xs) $ opt else error . unlines $ [ "unrecognized option "++k , "Use --help for usage." ] -- putStrLn $ "margs = " ++ show (Map.assocs margs) unkeysRef <- newIORef Map.empty pwRef <- newIORef Nothing let keypairs0 = flip map (maybe [] id $ Map.lookup "--keypairs" margs) $ \specfile -> do let (spec,efilecmd) = break (=='=') specfile guard $ take 1 efilecmd=="=" let filecmd = drop 1 efilecmd let (file,bcmdb0) = break (=='{') filecmd bcmdb = if null bcmdb0 then "{}" else bcmdb0 guard $ take 1 bcmdb=="{" let bdmcb = (dropWhile isSpace . reverse) bcmdb guard $ take 1 bdmcb == "}" let cmd = (drop 1 . reverse . drop 1) bdmcb Just (spec,file,cmd) btcpairs0 = flip map (maybe [] id $ Map.lookup "--bitcoin-keypairs" margs) $ \specfile -> do let (spec,efilecmd) = break (=='=') specfile (spec,protocnt) <- do return $ if take 1 efilecmd=="=" then (spec,drop 1 efilecmd) else ("",spec) let (proto,content) = break (==':') protocnt spec <- return $ if null spec then "bitcoin" else spec return $ if take 1 content =="=" then (spec,proto,drop 1 content) else (spec,"base58",proto) publics = flip map (maybe [] id $ Map.lookup "--public" margs) $ \specfile -> do let (spec,efile) = break (=='=') specfile guard $ take 1 efile=="=" let file= drop 1 efile Just (spec,file) keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs wallets = maybe [] id $ Map.lookup "--wallets" margs passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs decrypt wk = do -- warn $ "decryptKey "++fingerprint wk unkeys <- readIORef unkeysRef let kk = keykey wk flip (flip maybe $ return . Just) (Map.lookup kk unkeys) $ do let ret wkun = do writeIORef unkeysRef (Map.insert kk wkun unkeys) return (Just wkun) if symmetric_algorithm wk == Unencrypted then ret wk else do pw <- do pw <- readIORef pwRef flip (flip maybe return) pw $ do case passphrase_fd of Just fd -> do pwh <- fdToHandle (read fd) pw <- fmap trimCR $ S.hGetContents pwh writeIORef pwRef (Just pw) return pw Nothing -> return "" let wkun = do k <- decryptSecretKey pw wk guard (symmetric_algorithm k == Unencrypted) return k maybe (return Nothing) ret wkun when (not . null $ filter isNothing keypairs0) $ do warn "syntax error" exitFailure let keypairs = catMaybes keypairs0 btcpairs = catMaybes btcpairs0 (homedir,secring,pubring,grip0) <- getHomeDir ( concat <$> Map.lookup "--homedir" margs) let keyrings = secring:pubring:keyrings_ {- putStrLn $ "keypairs = "++show keypairs putStrLn $ "publics = "++show publics putStrLn $ "keyrings = "++show keyrings -} cross_merge decrypt grip0 keyrings wallets $ \(secfile,grip) db -> do let get_use_db = maybe (return db) import_db $ Map.lookup "--import" margs import_db _ = do forM_ to_alters $ \(_,KeyData c _ _ _) -> warn $ pubring ++ ": new "++showPacket (packet c) let db' = Map.union (Map.fromList altered) db return db' where to_alters = filter (dont_have . snd) $ Map.toList db altered = map (second append_loc) to_alters append_loc (KeyData p a b c) = KeyData p' a b c where p' = p { locations = Map.insert pubring (origin (secretToPublic (packet p)) (-1)) (locations p) } dont_have (KeyData p _ _ _) = not . Map.member pubring $ locations p use_db0 <- get_use_db let pkeypairs = maybe [] id $ do keygrip <- grip return $ map (\(spec,f,cmd)-> (parseSpec keygrip spec,f,cmd)) keypairs fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do -- Note that it's important to discard the KeyData objects -- returned by filterMatches and retain only the keys. -- Otherwise, the iterations within the foldM would not be -- able to alter them by returning a modified KeyDB. let ms = map fst $ filterMatches topspec (Map.toList db) f_found <- doesFileExist f return (f_found,(f,subspec,ms,cmd)) let (imports,exports) = partition fst fs use_db <- foldM (doImport decrypt) use_db0 (map snd imports) let (btcs,bad_btcs) = partition isSupportedBTC btcpairs isSupportedBTC (spec,"base58",cnt) = True isSupportedBTC _ = False dblist = Map.toList use_db pbtcs = maybe [] id $ do keygrip <- grip let conv (spec,proto,cnt) = let (topspec,subspec) = parseSpec keygrip spec ms = map fst $ filterMatches topspec dblist in (ms,subspec,cnt) return $ map conv btcs use_db <- foldM (doBTCImport decrypt) use_db pbtcs (ret_db,_) <- foldM (doExport decrypt) (Just use_db,use_db) (map snd exports) use_db <- flip (maybe $ return use_db) (lookup "--autosign" $ map (\(x:xs)->(x,xs)) sargs) $ \_ -> do let keys = map undata $ Map.elems use_db wk = listToMaybe $ do fp <- maybeToList grip elm <- Map.toList use_db guard $ matchSpec (KeyGrip fp) elm return $ undata (snd elm) undata (KeyData p _ _ _) = packet p -- g <- newGenIO -- stamp <- now wkun <- flip (maybe $ return Nothing) wk $ \wk -> do wkun <- decrypt wk maybe (error $ "Bad passphrase?") (return . Just) wkun -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db Traversable.mapM (signTorIds wkun keys) use_db ret_db <- return $ fmap (const use_db) ret_db ret_db <- flip (maybe $ return ret_db) ret_db $ \db -> do let hns = maybe [] id $ Map.lookup "--hosts" margs hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns let gpgnames = map getHostnames $ Map.elems db os = do (addr,(ns,_)) <- gpgnames n <- ns return (addr,n) setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os -- we ensure .onion names are set properly hostdbs = map setOnions hostdbs0 outgoing_names = do (addr,(_,gns)) <- gpgnames guard . not $ null gns guard $ all (null . Hosts.namesForAddress addr) hostdbs0 return addr -- putStrLn $ "hostdbs = " ++ show hostdbs -- 1. let U = union all the host dbs -- preserving whitespace and comments of the first let u0 = foldl' Hosts.plus Hosts.empty hostdbs -- we filter U to be only finger-dresses u1 = Hosts.filterAddrs (hasFingerDress db) u0 let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h {- putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" putStrLn $ "--> " ++ show (nf (head hostdbs)) putStrLn $ "u0 = {\n" ++ show u0 ++ "}" putStrLn $ "--> " ++ show (nf u0) putStrLn $ "u1 = {\n" ++ show u1 ++ "}" putStrLn $ "--> " ++ show (nf u1) -} -- 2. replace gpg annotations with those in U -- forM use_db db' <- Traversable.mapM (setHostnames (\a -> not $ elem a outgoing_names) u1) db -- 3. add hostnames from gpg for addresses not in U let u = foldl' f u1 ans ans = reverse $ do (addr,(_,ns)) <- gpgnames guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 n <- ns return (addr,n) f h (addr,n) = Hosts.assignNewName addr n h {- putStrLn $ "u = {\n" ++ show u ++ "}" putStrLn $ "--> " ++ show (nf u) -} -- 4. for each host db H, union H with U and write it out as H' -- only if there is a non-empty diff forM_ (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do let h = h1 `Hosts.plus` u d = Hosts.diff h0 h fnamecolon = Char8.pack fname <> ": " {- putStrLn $ "h = {\n" ++ show h ++ "}" putStrLn $ "--> " ++ show (nf h) -} Char8.hPutStrLn stderr $ Char8.unlines (map (fnamecolon <>) d) when (not $ null d) $ L.writeFile fname $ Hosts.encode h return () return (Just db') flip (maybe $ return ()) ret_db . const $ do -- On last pass, interpret --show-* commands. let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip) ,("--show-all",const $ show_all) ,("--show-key",\[x] -> show_key x $ maybe "" id grip) ,("--show-pem",\[x] -> show_pem x $ maybe "" id grip) ,("--show-wip",\[x] -> show_wip x $ maybe "" id grip) ,("--help", \_ _ ->kiki_usage)] shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs forM_ shargs $ \(cmd,args) -> cmd args use_db return $ (ret_db,use_db) return() 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 protohome = do homedir <- envhomedir protohome flip (maybe (error "Could not determine home directory.")) homedir $ \homedir -> do -- putStrLn $ "homedir = " ++show homedir let secring = homedir ++ "/" ++ "secring.gpg" pubring = homedir ++ "/" ++ "pubring.gpg" -- putStrLn $ "secring = " ++ show secring workingkey <- getWorkingKey homedir return (homedir,secring,pubring,workingkey) -- TODO: rename this to getGrip 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,pubring,grip) <- getHomeDir (homedir 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 _ | isPublicMaster w -> (w,u) _ | isUserID w -> (mkey,w) _ | otherwise -> (mkey,u) ) (w0,w0) ws where w0:ws = pub signTorIds selfkey keys kd@(KeyData k ksigs umap submap) = do umap' <- Traversable.mapM signIfTor (Map.mapWithKey (,) umap) return (KeyData k ksigs umap' submap) :: IO KeyData where mkey = packet k signIfTor (str,ps) = if isTorID str then do let uidxs0 = map packet $ flattenUid "" True (str,ps) -- addition<- signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0 additional <- signSelfAuthTorKeys' selfkey keys grip mkey uidxs0 let ps' = ( map ( (,tmap) . toMappedPacket om) additional ++ fst ps , Map.union om (snd ps) ) toMappedPacket om p = (mappedPacket "" p) {locations=om} om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str tmap = Map.empty return ps' else return ps torbindings = getTorKeys (map packet $ flattenTop "" True kd) isTorID 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) {- signSelfAuthTorKeys selfkey g sec grip timestamp xs = ys where keys = filter isKey sec mainpubkey = fst (head xs) uidxs0 = map snd xs (uidxs, additional, xs'',g') = signSelfAuthTorKeys' selfkey g keys grip timestamp mainpubkey uidxs0 ys = uidxs++ additional++xs'' -} signSelfAuthTorKeys' selfkey keys grip mainpubkey (uid:xs') = do new_sig <- let wkun = fromJust selfkey tor_ov = torSigOver mainpubkey wkun uid flgs in pgpSign (Message [wkun]) tor_ov SHA1 (fingerprint wkun) return (additional new_sig) -- (uid:sigs,additional,xs'',g') where (sigs, xs'') = span isSignaturePacket xs' overs sig = signatures $ Message (keys++[mainpubkey,uid,sig]) vs :: [ ( Packet -- signature , Maybe SignatureOver -- Nothing means non-verified , Packet ) -- key who signed ] vs = do sig <- sigs o <- overs sig k <- keys let ov = verify (Message [k]) $ o signatures_over ov return (sig,Just ov,k) {- mainsigs = filter (\(sig,v,whosign) -> isJust (v >> Just mainpubkey >>= guard . (== keykey whosign) . keykey)) vs -} selfsigs = filter (\(sig,v,whosign) -> isJust (v >> selfkey >>= guard . (== keykey whosign) . keykey)) vs additional new_sig = do new_sig <- maybeToList new_sig guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs) , " for mainkey = "++fingerprint mainpubkey] ) -} (null $ selfsigs) 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 (\(x,_,_)->x) selfsigs) else [] -- (new_sig,g') = todo g mainpubkey (fromJust selfkey) uid timestamp flgs {- new_sig <- let wkun = fromJust selfkey in pgpSign (Message [wkun]) tor_ov SHA1 (fingerprint wkun) -} -- ys = uid:sigs++ additional++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 isPublicMaster 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@(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@(Cross_Merge {}) = do (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd) -- grip0 may be empty, in which case we should use the first key cross_merge (secring:pubring:files cmd) $ \_ db -> return $ (Just db,db) 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 -- sig exists. -- 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')) 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 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec) ks selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectKey0 wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db ys = snd $ seek_key spec ps flip (maybe (listToMaybe ys)) mtag $ \tag -> do let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys zs = snd $ seek_key subspec ys1 listToMaybe zs matchSpec (KeyGrip grip) (_,KeyData p _ _ _) | matchpr grip (packet p)==grip = True | otherwise = False matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps where ps = map (packet .fst) sigs match p = isSignaturePacket p && has_tag tag p && has_issuer key p has_issuer key p = isJust $ do issuer <- signature_issuer p guard $ matchpr issuer key == issuer has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us where us = filter (isInfixOf pat) $ Map.keys uids 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 = todo torSigOver topk wkun uid extras = CertificationSignature (secretToPublic topk) uid (sigpackets 0x13 subpackets subpackets_unh) where subpackets = -- implicit: [ 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