From 83bbe5b9fcf12fad348cb4dd2a9ceda20d6e1704 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 31 Oct 2013 20:00:03 -0400 Subject: Renamed keys to kiki --- keys.cabal | 23 -- keys.hs | 1195 ------------------------------------------------------------ kiki.cabal | 23 ++ kiki.hs | 1195 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1218 insertions(+), 1218 deletions(-) delete mode 100644 keys.cabal delete mode 100644 keys.hs create mode 100644 kiki.cabal create mode 100644 kiki.hs diff --git a/keys.cabal b/keys.cabal deleted file mode 100644 index 30c29c2..0000000 --- a/keys.cabal +++ /dev/null @@ -1,23 +0,0 @@ - -Name: keys -Version: 0.0.1 -cabal-version: >= 1.6 -Synopsis: Samizdat gpg tool -Description: gpg operations... TODO -License: Undecided --- License-file: LICENSE TODO -Author: Joseph Crayne -Maintainer: Joseph Crayne ---Homepage: TODO -build-type: Simple - -Executable keys - Main-is: keys.hs - Build-Depends: base -any, cmdargs -any, directory -any, - openpgp-crypto-api -any, - crypto-pubkey -any, cryptohash -any, - asn1-types -any, asn1-encoding -any, - dataenc -any, text -any, pretty -any, pretty-show -any, - bytestring -any, openpgp (==0.6.1), binary -any, - unix, time, crypto-api, cryptocipher (>=0.3.7) - ghc-options: -O2 diff --git a/keys.hs b/keys.hs deleted file mode 100644 index 552a34d..0000000 --- a/keys.hs +++ /dev/null @@ -1,1195 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} -module Main where - -import Debug.Trace -import Data.Binary -import Data.OpenPGP -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as Char8 -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Control.Monad -import qualified Text.Show.Pretty as PP -import Text.PrettyPrint as PP hiding ((<>)) -import Data.List -import Data.OpenPGP.CryptoAPI -import Data.Ord -import Data.Maybe -import Data.Bits -import qualified Data.Text as T -import Data.Text.Encoding -import qualified Codec.Binary.Base32 as Base32 -import qualified Codec.Binary.Base64 as Base64 -import qualified Crypto.Hash.SHA1 as SHA1 -import Data.Char (toLower) -import qualified Crypto.PubKey.RSA as RSA -import Crypto.Random (newGenIO,SystemRandom) -import Data.ASN1.Types -import Data.ASN1.Encoding -import Data.ASN1.BinaryEncoding -import Control.Applicative -import System.Environment -import System.Directory -import System.Exit -import ControlMaybe -import Data.Char -import Control.Arrow (second) -import Data.Traversable -import System.Console.CmdArgs --- import System.Posix.Time -import Data.Time.Clock.POSIX -import System.Posix.IO (fdToHandle,fdRead) -import System.Posix.Files -import Data.Monoid ((<>)) --- import Data.X509 - -data RSAPublicKey = RSAKey MPI MPI deriving Show - -instance ASN1Object RSAPublicKey where - toASN1 (RSAKey (MPI n) (MPI e)) - = \xs -> Start Sequence - : IntVal n - : IntVal e - : End Sequence - : xs - fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = - Right (RSAKey (MPI modulus) (MPI pubexp) , xs) - fromASN1 _ = - Left "fromASN1: RSAPublicKey: unexpected format" - -data RSAPrivateKey = RSAPrivateKey - { rsaN :: MPI - , rsaE :: MPI - , rsaD :: MPI - , rsaP :: MPI - , rsaQ :: MPI - , rsaDmodP1 :: MPI - , rsaDmodQminus1 :: MPI - , rsaCoefficient :: MPI - } - deriving Show - -{- -RSAPrivateKey ::= SEQUENCE { - version Version, - modulus INTEGER, -- n - publicExponent INTEGER, -- e - privateExponent INTEGER, -- d - prime1 INTEGER, -- p - prime2 INTEGER, -- q - exponent1 INTEGER, -- d mod (p1) - exponent2 INTEGER, -- d mod (q-1) - coefficient INTEGER, -- (inverse of q) mod p - otherPrimeInfos OtherPrimeInfos OPTIONAL -} --} - -instance ASN1Object RSAPrivateKey where - toASN1 rsa@(RSAPrivateKey {}) - = \xs -> Start Sequence - : IntVal 0 - : mpiVal rsaN - : mpiVal rsaE - : mpiVal rsaD - : mpiVal rsaP - : mpiVal rsaQ - : mpiVal rsaDmodP1 - : mpiVal rsaDmodQminus1 - : mpiVal rsaCoefficient - : End Sequence - : xs - where mpiVal f = IntVal x where MPI x = f rsa - - fromASN1 ( Start Sequence - : IntVal _ -- version - : IntVal n - : IntVal e - : IntVal d - : IntVal p - : IntVal q - : IntVal dmodp1 - : IntVal dmodqminus1 - : IntVal coefficient - : ys) = - Right ( privkey, tail $ dropWhile notend ys) - where - notend (End Sequence) = False - notend _ = True - privkey = RSAPrivateKey - { rsaN = MPI n - , rsaE = MPI e - , rsaD = MPI d - , rsaP = MPI p - , rsaQ = MPI q - , rsaDmodP1 = MPI dmodp1 - , rsaDmodQminus1 = MPI dmodqminus1 - , rsaCoefficient = MPI coefficient - } - fromASN1 _ = - Left "fromASN1: RSAPrivateKey: unexpected format" - -rsaKeyFromPacket p@(PublicKeyPacket {}) = do - n <- lookup 'n' $ key p - e <- lookup 'e' $ key p - return $ RSAKey n e -rsaKeyFromPacket p@(SecretKeyPacket {}) = do - n <- lookup 'n' $ key p - e <- lookup 'e' $ key p - return $ RSAKey n e -rsaKeyFromPacket _ = Nothing -derRSA rsa = do - k <- rsaKeyFromPacket rsa - return $ encodeASN1 DER (toASN1 k []) - -getPackets :: IO [Packet] -getPackets = do - input <- L.getContents - case decodeOrFail input of - Right (_,_,Message pkts) -> return pkts - Left (_,_,_) -> return [] - - -secretToPublic pkt@(SecretKeyPacket {}) = - PublicKeyPacket { version = version pkt - , timestamp = timestamp pkt - , key_algorithm = key_algorithm pkt - , key = let seckey = key pkt - pubs = public_key_fields (key_algorithm pkt) - in filter (\(k,v) -> k `elem` pubs) seckey - , is_subkey = is_subkey pkt - , v3_days_of_validity = Nothing - } -secretToPublic pkt = pkt - - -extractPEM typ pem = dta - where - dta = case ys of - _:dta_lines -> Char8.concat dta_lines - [] -> "" - xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) - ys = takeWhile (/="-----END " <> typ <> "-----") xs - -isKey (PublicKeyPacket {}) = True -isKey (SecretKeyPacket {}) = True -isKey _ = False - -isUserID (UserIDPacket {}) = True -isUserID _ = False - -isEmbeddedSignature (EmbeddedSignaturePacket {}) = True -isEmbeddedSignature _ = False - -isCertificationSig (CertificationSignature {}) = True -isCertificationSig _ = True - -issuer (IssuerPacket issuer) = Just issuer -issuer _ = Nothing -backsig (EmbeddedSignaturePacket s) = Just s -backsig _ = Nothing - -isSubkeySignature (SubkeySignature {}) = True -isSubkeySignature _ = False - -isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k -isMasterKey _ = False - -now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime - -usage (NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = u - }) = Just u -usage _ = Nothing - -verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) - where - verified = do - sig <- signatures (Message nonkeys) - let v = verify (Message keys) sig - guard (not . null $ signatures_over v) - return v - (top,othersigs) = partition isSubkeySignature verified - embedded = do - sub <- top - let sigover = signatures_over sub - unhashed = sigover >>= unhashed_subpackets - subsigs = mapMaybe backsig unhashed - sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) - let v = verify (Message [subkey sub]) sig - guard (not . null $ signatures_over v) - return v - -grip k = drop 32 $ fingerprint k - -smallpr k = drop 24 $ fingerprint k - --- matchpr computes the fingerprint of the given key truncated to --- be the same lenght as the given fingerprint for comparison. -matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp - - -disjoint_fp ks = {- concatMap group2 $ -} transpose grouped - where - grouped = groupBy samepr . sortBy (comparing smallpr) $ ks - samepr a b = smallpr a == smallpr b - - {- - -- useful for testing - group2 :: [a] -> [[a]] - group2 (x:y:ys) = [x,y]:group2 ys - group2 [x] = [[x]] - group2 [] = [] - -} - -verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures) -verifyBindingsEx pkts = bicat . unzip $ do - let (keys,_) = partition isKey pkts - keys <- disjoint_fp keys - return $ verifyBindings keys pkts - where - bicat (xs,ys) = (concat xs,concat ys) - -getBindings :: - [Packet] - -> - ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets - -- that were used for the verifications - , [(Word8, - (Packet, Packet), -- (topkey,subkey) - [String], -- usage flags - [SignatureSubpacket], -- hashed data - [Packet])] -- ^ binding signatures - ) -getBindings pkts = (sigs,bindings) - where - (sigs,concat->bindings) = unzip $ do - let (keys,nonkeys) = partition isKey pkts - keys <- disjoint_fp keys - let (bs,sigs) = verifyBindings keys pkts - return . ((keys,sigs),) $ do - b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs - i <- map signature_issuer (signatures_over b) - i <- maybeToList i - who <- maybeToList $ find_key fingerprint (Message keys) i - let (code,claimants) = - case () of - _ | who == topkey b -> (1,[]) - _ | who == subkey b -> (2,[]) - _ -> (0,[who]) - let hashed = signatures_over b >>= hashed_subpackets - kind = guard (code==1) >> hashed >>= maybeToList . usage - return (code,(topkey b,subkey b), kind, hashed,claimants) - --- Returned data is simmilar to getBindings but the Word8 codes --- are ORed together. -accBindings :: - Bits t => - [(t, (Packet, Packet), [a], [a1], [a2])] - -> [(t, (Packet, Packet), [a], [a1], [a2])] -accBindings bs = as - where - gs = groupBy samePair . sortBy (comparing bindingPair) $ bs - as = map (foldl1 combine) gs - bindingPair (_,p,_,_,_) = pub2 p - where - pub2 (a,b) = (pub a, pub b) - pub a = fingerprint_material a - samePair a b = bindingPair a == bindingPair b - combine (ac,p,akind,ahashed,aclaimaints) - (bc,_,bkind,bhashed,bclaimaints) - = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) - - -data UserIDRecord = UserIDRecord { - uid_full :: String, - uid_realname :: T.Text, - uid_user :: T.Text, - uid_subdomain :: T.Text, - uid_topdomain :: T.Text -} - deriving Show - -isBracket '<' = True -isBracket '>' = True -isBracket _ = False - -parseUID str = UserIDRecord { - uid_full = str, - uid_realname = realname, - uid_user = user, - uid_subdomain = subdomain, - uid_topdomain = topdomain - } - where - text = T.pack str - (T.strip-> realname, T.dropAround isBracket-> email) - = T.break (=='<') text - (user, T.tail-> hostname) = T.break (=='@') email - ( T.reverse -> topdomain, - T.reverse . T.drop 1 -> subdomain) - = T.break (=='.') . T.reverse $ hostname - - -derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy - -fpmatch grip key = - (==) Nothing - (fmap (backend (fingerprint key)) grip >>= guard . not) - where - backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) - -listKeys pkts = listKeysFiltered [] pkts - -listKeysFiltered grips pkts = do - let (certs,bs) = getBindings pkts - as = accBindings bs - defaultkind (k:_) hs = k - defaultkind [] hs = maybe "subkey" - id - ( listToMaybe - . mapMaybe (fmap usageString . keyflags) - $ hs) - kinds = map (\(_,_,k,h,_)->defaultkind k h) as - kindwidth = maximum $ map length kinds - kindcol = min 20 kindwidth - code (c,(m,s),_,_,_) = (fingerprint_material m,-c) - ownerkey (_,(a,_),_,_,_) = a - sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b - matchgrip _ | null grips = True - matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True - matchgrip _ = False - gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) - subs <- gs - let (code,(top,sub), kind, hashed,claimants):_ = subs - subkeys = do - (code,(top,sub), kind, hashed,claimants) <- subs - let ar = case code of - 0 -> " ??? " - 1 -> " --> " - 2 -> " <-- " - 3 -> " <-> " - formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' - -- torhash = maybe "" id $ derToBase32 <$> derRSA sub - concat [ " " - -- , grip top - , (if not (null claimants) - then trace ("claimants: "++show (map fingerprint claimants)) - else id) ar - , formkind - , " " - , fingerprint sub - -- , " " ++ torhash - , "\n" ] - -- ++ ppShow hashed - torkeys = do - (code,(top,sub), kind, hashed,claimants) <- subs - guard ("tor" `elem` kind) - guard (code .&. 0x2 /= 0) - maybeToList $ derToBase32 <$> derRSA sub - uid = {- maybe "" id . listToMaybe $ -} do - (keys,sigs) <- certs - sig <- sigs - guard (isCertificationSig sig) - guard (topkey sig == top) - let issuers = do - sig_over <- signatures_over sig - i <- maybeToList $ signature_issuer sig_over - maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i))) - (primary,secondary) = partition (==top) issuers - - -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return () - -- trace ("SECONDARY: "++show (map fingerprint secondary)) $ return () - guard (not (null primary)) - - let UserIDPacket uid = user_id sig - parsed = parseUID uid - ar = maybe " --> " (const " <-> ") $ do - guard (uid_topdomain parsed == "onion" ) - guard ( uid_realname parsed `elem` ["","Anonymous"]) - guard ( uid_user parsed == "root" ) - let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] - len = L.length subdom0 - subdom = Char8.unpack subdom0 - match = ( (==subdom) . take (fromIntegral len)) - guard (len >= 16) - listToMaybe $ filter match torkeys - unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ] - ++ map (\k -> " " ++ "^ signed: " ++ fingerprint k) secondary - (_,sigs) = unzip certs - "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" - - -data PGPKeyFlags = - Special - | Vouch -- Signkey - | Sign - | VouchSign - | Communication - | VouchCommunication - | SignCommunication - | VouchSignCommunication - | Storage - | VouchStorage - | SignStorage - | VouchSignStorage - | Encrypt - | VouchEncrypt - | SignEncrypt - | VouchSignEncrypt - deriving (Eq,Show,Read,Enum) - -usageString flgs = - case flgs of - Special -> "special" - Vouch -> "vouch" -- signkey - Sign -> "sign" - VouchSign -> "vouch-sign" - Communication -> "communication" - VouchCommunication -> "vouch-communication" - SignCommunication -> "sign-communication" - VouchSignCommunication -> "vouch-sign-communication" - Storage -> "storage" - VouchStorage -> "vouch-storage" - SignStorage -> "sign-storage" - VouchSignStorage -> "vouch-sign-storage" - Encrypt -> "encrypt" - VouchEncrypt -> "vouch-encrypt" - SignEncrypt -> "sign-encrypt" - VouchSignEncrypt -> "vouch-sign-encrypt" - - -keyflags flgs@(KeyFlagsPacket {}) = - Just . toEnum $ - ( bit 0x1 certify_keys - .|. bit 0x2 sign_data - .|. bit 0x4 encrypt_communication - .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags - -- other flags: - -- split_key - -- authentication (ssh-client) - -- group_key - where - bit v f = if f flgs then v else 0 -keyflags _ = Nothing - - -modifyUID (UserIDPacket str) = UserIDPacket str' - where - (fstname,rst) = break (==' ') str - str' = mod fstname ++ rst - mod "Bob" = "Bob Fucking" - mod x = x -modifyUID other = other - -todo = error "unimplemented" - --- TODO: switch to System.Environment.lookupEnv --- when linking against newer base libraries. -lookupEnv var = - handleIO_ (return Nothing) $ fmap Just (getEnv var) - -unmaybe def = fmap (maybe def id) - -expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) - | otherwise = c:cs -expandPath path [] = [] - - -readPacketsFromFile :: FilePath -> IO Message -readPacketsFromFile fname = do - input <- L.readFile fname - return $ - case decodeOrFail input of - Right (_,_,msg ) -> msg - Left (_,_,_) -> Message [] - - -parseOptionFile fname = do - xs <- fmap lines (readFile fname) - let ys = filter notComment xs - notComment ('#':_) = False - notComment cs = not (all isSpace cs) - return ys - -{- -options_from_file :: - (forall a. [String] -> Term a -> IO (Either EvalExit a)) - -> Term b - -> (String,String,Term (Maybe String)) - -> ([String],Term (Maybe String)) - -> IO [String] -options_from_file unwrapCmd term (homevar,appdir,home) (optfile_alts,options_file) = doit - where - homedir = envhomedir <$> home - envhomedir opt = do - gnupghome <- lookupEnv homevar >>= - \d -> return $ d >>= guard . (/="") >> d - home <- flip fmap getHomeDirectory $ - \d -> fmap (const d) $ guard (d/="") - let homegnupg = (++('/':appdir)) <$> home - let val = (opt `mplus` gnupghome `mplus` homegnupg) - return $ val - - doit = do - args <- getArgs - {- - let wants_help = - not . null $ filter cryForHelp args - where cryForHelp "--help" = True - cryForHelp "--version" = True - cryForHelp x = - and (zipWith (==) x "--help=") - -} - (o,h) <- do - val <- unwrapCmd args (liftA2 (,) options_file homedir) - case val of - Left e -> return (Nothing,Nothing) - Right (o,h) -> (o,) <$> h - ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> - let optfiles = map (second ((h++"/")++)) - (maybe optfile_alts' (:[]) o') - optfile_alts' = zip (False:repeat True) optfile_alts - o' = fmap (False,) o - in filterM (doesFileExist . snd) optfiles - args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do - let h' = fromJust h - newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname - let toArgs = toHead ("--"++) . words - toHead f (x:xs) = f x : xs - toHead f [] = [] - voidTerm = fmap (const ()) - appendArgs as [] = return as - appendArgs as (configline:cs) = do - let xs = toArgs configline - w <-unwrap (xs++as) (voidTerm term,defTI) - case w of - Left _ -> appendArgs as cs - Right _ -> appendArgs (xs++as) cs - -- TODO: check errors if forgive = False - appendArgs args newargs - return args - -runWithOptionsFile :: (Term (IO b), TermInfo) -> IO b -runWithOptionsFile (term,ti) = do - as <- options_from_file unwrapCmd - term - ("GNUPGHOME",".gnupg",opt_homedir) - (["keys.conf","gpg.conf-2","gpg.conf"] - ,opt_options) - q <- eval as (term , ti) - q - where - unwrapCmd args term = unwrap args (term,defTI) - -runChoiceWithOptionsFile :: - (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b -runChoiceWithOptionsFile (realterm,ti) choices = do - as <- options_from_file unwrapCmd - realterm - ("GNUPGHOME",".gnupg",opt_homedir) - (["keys.conf","gpg.conf-2","gpg.conf"] - ,opt_options) - -- putStrLn $ "as = " ++ show as - q <- evalChoice as (realterm , ti) choices - q - where - unwrapCmd args t = - unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices) - neuter term (t,ti) = (t <:> term, ti) - -data Command = - List - | Autosign - deriving (Eq,Show,Read,Enum) - -capitolizeFirstLetter (x:xs) = toUpper x : xs -capitolizeFirstLetter xs = xs - -instance ArgVal Command where - converter = - ( maybe (Left $ text "unknown command") Right - . fmap fst . listToMaybe . reads - . capitolizeFirstLetter . map toLower - , text . map toLower . show - ) -class AutoMaybe a -instance AutoMaybe Command -instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where - converter = - ( toRight Just . fst converter - , maybe (text "(unspecified)") id . fmap (snd converter) - ) - -toRight f (Right x) = Right (f x) -toRight f (Left y) = Left y - -cmd :: Term Command -cmd = required . pos 0 Nothing $ posInfo - { posName = "command" - , posDoc = "What action to perform." - } - -a <:> b = flip const <$> a <*> b -infixr 2 <:> - -selectAction cmd actions = actions !! fromEnum cmd - -cmdInfo :: ArgVal cmd => - cmd -> String -> Term a -> (cmd, (Term a, TermInfo)) -cmdInfo cmd doc action = - ( cmd - , ( action - , defTI { termName = print cmd - , termDoc = doc } ) ) - where - print = show . snd converter - -cmdlist :: (Command, (Term (IO ()), TermInfo)) -cmdlist = cmdInfo List "list key pairs for which secrets are known" $ - (>>= putStrLn . listKeys . unMessage) <$> secret_packets - where unMessage (Message pkts) = pkts - -cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $ - pure (putStrLn "autosign") - - -multiCommand :: - TermInfo - -> [(Command, (Term a, TermInfo))] - -> ( (Term a, TermInfo) - , [(Term a, TermInfo)] ) -multiCommand ti choices = - ( ( selectAction <$> cmd <*> sequenceA (map strip choices) - , ti ) - , map snd choices ) - where - selectAction cmd choices = - fromJust $ lookup (cmd::Command) choices - strip (cmd,(action,_)) = fmap (cmd,) action --} - - -trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs - -guessKeyFormat 'P' "ssh-client" = "SSH" -guessKeyFormat 'S' "ssh-client" = "PEM" -guessKeyFormat 'S' "ssh-host" = "PEM" -guessKeyFormat _ _ = "PEM" -- "PGP" - -readKeyFromFile False "PEM" fname = do - timestamp <- modificationTime <$> getFileStatus fname - input <- L.readFile fname - let dta = extractPEM "RSA PRIVATE KEY" input - -- Char8.putStrLn $ "dta = " <> dta - let rsa = do - e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) - asn1 <- either (const Nothing) Just e - k <- either (const Nothing) (Just . fst) (fromASN1 asn1) - let _ = k :: RSAPrivateKey - return k - -- putStrLn $ "rsa = "++ show rsa - return . Message $ do - rsa <- maybeToList rsa - return $ SecretKeyPacket - { version = 4 - , timestamp = toEnum (fromEnum timestamp) - , key_algorithm = RSA - , key = [ -- public fields... - ('n',rsaN rsa) - ,('e',rsaE rsa) - -- secret fields - ,('d',rsaD rsa) - ,('p',rsaQ rsa) -- Note: p & q swapped - ,('q',rsaP rsa) -- Note: p & q swapped - ,('u',rsaCoefficient rsa) - ] - , s2k_useage = 0 - , s2k = S2K 100 "" - , symmetric_algorithm = Unencrypted - , encrypted_data = "" - , is_subkey = True - } -readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) - -data Arguments = - List { homedir :: Maybe FilePath } - | WorkingKey { homedir :: Maybe FilePath } - | AutoSign { homedir :: Maybe FilePath - , passphrase_fd :: Maybe Int - , input :: FilePath - , output :: FilePath} - | Public { homedir :: Maybe FilePath - , output :: FilePath} - | Add { homedir :: Maybe FilePath - , passphrase_fd :: Maybe Int - , key_usage :: String - , seckey :: String - , output :: FilePath } - | PemFP { homedir :: Maybe FilePath - , seckey :: String } - | CatPub { homedir :: Maybe FilePath - , catpub_args :: [String] } - {- - | Decrypt { homedir :: Maybe FilePath - , passphrase_fd :: Maybe Int - , output :: FilePath } - -} - deriving (Show, Data, Typeable) - -getPassphrase cmd = - case passphrase_fd cmd of - Just fd -> do pwh <- fdToHandle (toEnum fd) - fmap trimCR $ S.hGetContents pwh - Nothing -> return "" - - -#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) - -main = do - args <- cmdArgs $ modes - [ List HOMEOPTION - &= help "List key pairs in the secret keyring." - &= auto - , WorkingKey HOMEOPTION - &= help "Shows the current working key set that will be used to make signatures." - , Public HOMEOPTION - (def &= argPos 1 &= typFile ) - &= help "Extract public keys into the given file." - , AutoSign HOMEOPTION - (def &= opt ("passphrase"::String) - &= typ "FD" - &= (help . concat) ["file descriptor from " - ,"which to read passphrase"]) - (def &= argPos 1 &= typFile ) - (def &=argPos 2 &= typFile) - &= (help . concat) - [ "Copies the first file to the second while adding" - , " signatures for tor-style uids that match" - , " cross-certified keys." ] - {- - , Decrypt HOMEOPTION - (def &= opt ("passphrase"::String) - &= typ "FD" - &= (help . concat) ["file descriptor from " - ,"which to read passphrase"]) - (def &= argPos 1 &= typFile ) - -- (def &= argPos 3 &= typ "PUBLIC-KEY") - &= (help . concat) - [ "Remove password protection from the working keyring" - , " and save the result into the given file."] - -} - , CatPub HOMEOPTION - (def &= args &= typ "KEYSPEC FILES") - &= help "Extract a public subkey to stdout." - , Add HOMEOPTION - (def &= opt ("passphrase"::String) - &= typ "FD" - &= (help . concat) ["file descriptor from " - ,"which to read passphrase"]) - (def &= argPos 1 &= typ "USAGE") - (def &= argPos 2 &= typ "PRIVATE-KEY") - (def &= argPos 3 &= typFile) - -- (def &= argPos 3 &= typ "PUBLIC-KEY") - &= (help . concat) - [ "Add a subkey." - , " USAGE is the usage@ annotation of the subkey." - , " Keys are specified as FMT:FILE where" - , " FMT may be one of following: PEM." - , " Results are written to the given file." ] - - , PemFP HOMEOPTION - (def &= argPos 1 &= typFile ) - &= (help . concat) - [ "Display the fingerprint of a PEM key pair."] - ] - &= program "keys" - &= summary "keys - a pgp key editing utility" - doCmd args - where - envhomedir opt = do - gnupghome <- lookupEnv homevar >>= - \d -> return $ d >>= guard . (/="") >> d - home <- flip fmap getHomeDirectory $ - \d -> fmap (const d) $ guard (d/="") - let homegnupg = (++('/':appdir)) <$> home - let val = (opt `mplus` gnupghome `mplus` homegnupg) - return $ val - - homevar = "GNUPGHOME" - appdir = ".gnupg" - optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] - - getHomeDir cmd = do - homedir <- envhomedir (homedir cmd) - flip (maybe (error "Could not determine home directory.")) - homedir $ \homedir -> do - -- putStrLn $ "homedir = " ++show homedir - let secring = homedir ++ "/" ++ "secring.gpg" - -- putStrLn $ "secring = " ++ show secring - workingkey <- getWorkingKey homedir - return (homedir,secring,workingkey) - - getWorkingKey homedir = do - let o = Nothing - h = Just homedir - args = ["hi"] - ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> - let optfiles = map (second ((h++"/")++)) - (maybe optfile_alts' (:[]) o') - optfile_alts' = zip (False:repeat True) optfile_alts - o' = fmap (False,) o - in filterM (doesFileExist . snd) optfiles - args <- flip (maybe $ return []) ofile $ - \(forgive,fname) -> parseOptionFile fname - let config = map (topair . words) args - where topair (x:xs) = (x,xs) - return $ lookup "default-key" config >>= listToMaybe - - getPGPEnviron cmd = do - (homedir,secring,grip) <- getHomeDir cmd - (Message sec) <- readPacketsFromFile secring - let (keys,_) = partition (\k -> case k of - { SecretKeyPacket {} -> True - ; _ -> False }) - sec - return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys)) - - getTorKeys pub = do - xs <- groupBindings pub - (_,(top,sub),us,_,_) <- xs - guard ("tor" `elem` us) - let torhash = maybe "" id $ derToBase32 <$> derRSA sub - return (top,(torhash,sub)) - - uidScan pub = scanl (\(mkey,u) w -> - case () of - _ | isMasterKey w -> (w,u) - _ | isUserID w -> (mkey,w) - _ | otherwise -> (mkey,u) - ) - (w0,w0) - ws - where - w0:ws = pub - - signSelfAuthTorKeys pw g sec grip timestamp xs = ys - where - keys = filter isKey sec - selfkey = find_key fingerprint (Message keys) (fromJust grip) >>= decryptKey - where - decryptKey k = decryptSecretKey pw k - mainpubkey = fst (head xs) - uid:xs' = map snd xs - (sigs, xs'') = span isSignaturePacket xs' - overs sig = signatures $ Message (keys++[uid,sig]) - vs :: [ ( Packet -- signature - , Maybe SignatureOver) -- Nothing means non-verified - ] - vs = do - sig <- sigs - let vs = overs sig >>= return . verify (Message keys) - ws = filter (not . null . signatures_over) vs - ws' = if null ws then [Nothing] else map Just ws - v <- ws' - return (sig,v) - has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs - sigs' = if has_self - then sigs - {- - else trace ( "key params: "++params (fromJust selfkey)++"\n" - ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig) - -} - else sigs ++ signatures_over new_sig - modsig sig = sig { signature = map id (signature sig) } - where plus1 (MPI x) = MPI (x+1) - params newtop = public ++ map fst (key newtop) ++ "}" - where - public = case newtop of - PublicKeyPacket {} -> "public{" - SecretKeyPacket {} -> if L.null (encrypted_data newtop ) - then "secret{" - else "encrypted{" - _ -> "??????{" - traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) - ,"new_sig topkey:"++ (show . fingerprint $ newtop) - ,"new_sig topkey params: "++ params newtop - ,"new_sig user_id:"++ (show newuid) - ,"new_sig |over| = " ++ (show . length $ new_sig) - ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) - ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) - ,"new_sig type: " ++ (show . map signature_type $ new_sig) - ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) - ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) - ,"issuer = " ++ show (map signature_issuer new_sig) - ]) - new_sig = fst $ sign (Message (maybeToList selfkey)) - (CertificationSignature mainpubkey - uid - []) --fromJust selfkey, uid]) - SHA1 - (fromJust grip) - timestamp - g - ys = uid:sigs'++xs'' - - doCmd cmd@(List {}) = do - (homedir,secring,grip) <- getHomeDir cmd - (Message sec) <- readPacketsFromFile secring - putStrLn $ listKeys sec - - doCmd cmd@(WorkingKey {}) = do - (homedir,secring,grip) <- getHomeDir cmd - (Message sec) <- readPacketsFromFile secring - -- let s2k' = map s2k (filter isKey sec) - -- putStrLn $ "s2k = " ++ show s2k' - putStrLn $ listKeysFiltered (maybeToList grip) sec - return () - - doCmd cmd@(AutoSign {}) = do - ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome - , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg - , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" - ) <- getPGPEnviron cmd - S8.putStrLn $ "pasphrase_fd = " <> S8.pack (show (passphrase_fd cmd)) - pw <- getPassphrase cmd - -- 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 pw (g::SystemRandom) sec grip timestamp) - (map (map cleanup) xss) - cleanup (_,(topkey,_,pkt)) = (topkey,pkt) - putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub') - putStrLn "" - putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub')) (sec++pub') - - let signed_bs = encode (Message pub') - L.writeFile (output cmd) signed_bs - - doCmd cmd@(Public {}) = do - ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome - , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg - , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" - ) <- getPGPEnviron cmd - let pub = map secretToPublic sec - bs = encode (Message pub) - L.writeFile (output cmd) bs - - {- - doCmd cmd@(Decrypt {}) = do - ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome - , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg - , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" - ) <- getPGPEnviron cmd - pw <- getPassphrase cmd - - let sec' = map decrypt sec - decrypt k@(SecretKeyPacket {}) = k -- TODO - - L.writeFile (output cmd) (encode $ Message sec') - - {- - let wk = grip >>= find_key fingerprint (Message sec) - case wk of - Nothing -> error "No working key?" - Just wk -> do - putStrLn $ "wk = " ++ fingerprint wk - -} - -} - - doCmd cmd@(CatPub {}) = do - let spec:files = catpub_args cmd - putStrLn $ "spec = " ++show spec - putStrLn $ "files = " ++ show files - return () - - 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 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 - - 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 - -- -- Message pubkey <- readKeyFromFile True pubfmt pubfile - - -- putStrLn $ "parsedkey = " ++ show (head parsedkey) - -- putStrLn $ "----------" - - {- - let seckeys = filter isSecretKey sec - isSecretKey (SecretKeyPacket {}) = True - isSecretKey _ = False - algos = map symmetric_algorithm seckeys - putStrLn $ show $ symmetric_algorithm wk - putStrLn $ show $ s2k wk - putStrLn $ show $ s2k_useage wk - putStrLn $ PP.ppShow sec - let -- e = encryptSecretKey wk pw (head seckey) - e = head seckey - d = if symmetric_algorithm e /= Unencrypted - then maybeToList $ decryptSecretKey pw e - else [e] - putStrLn $ "e = " ++ show (e) - -} - -- putStrLn $ "wkun = " ++ show wkun - -- putStrLn $ "head subkeys = " ++ show (head subkeys) - - 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) - 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] - - 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 = key_usage cmd - } - ] - - 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 cmd) (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 () - - 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 - putStrLn $ fingerprint (head seckey) - - - - -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 - - -seek_key :: String -> [Packet] -> ([Packet],[Packet]) -seek_key grip sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred _ = False diff --git a/kiki.cabal b/kiki.cabal new file mode 100644 index 0000000..e730186 --- /dev/null +++ b/kiki.cabal @@ -0,0 +1,23 @@ + +Name: kiki +Version: 0.0.1 +cabal-version: >= 1.6 +Synopsis: Samizdat gpg tool +Description: gpg operations... TODO +License: Undecided +-- License-file: LICENSE TODO +Author: Joseph Crayne +Maintainer: Joseph Crayne +--Homepage: TODO +build-type: Simple + +Executable kiki + Main-is: kiki.hs + Build-Depends: base -any, cmdargs -any, directory -any, + openpgp-crypto-api -any, + crypto-pubkey -any, cryptohash -any, + asn1-types -any, asn1-encoding -any, + dataenc -any, text -any, pretty -any, pretty-show -any, + bytestring -any, openpgp (==0.6.1), binary -any, + unix, time, crypto-api, cryptocipher (>=0.3.7) + ghc-options: -O2 diff --git a/kiki.hs b/kiki.hs new file mode 100644 index 0000000..c9483a0 --- /dev/null +++ b/kiki.hs @@ -0,0 +1,1195 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +module Main where + +import Debug.Trace +import Data.Binary +import Data.OpenPGP +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as Char8 +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Control.Monad +import qualified Text.Show.Pretty as PP +import Text.PrettyPrint as PP hiding ((<>)) +import Data.List +import Data.OpenPGP.CryptoAPI +import Data.Ord +import Data.Maybe +import Data.Bits +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Codec.Binary.Base32 as Base32 +import qualified Codec.Binary.Base64 as Base64 +import qualified Crypto.Hash.SHA1 as SHA1 +import Data.Char (toLower) +import qualified Crypto.PubKey.RSA as RSA +import Crypto.Random (newGenIO,SystemRandom) +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Control.Applicative +import System.Environment +import System.Directory +import System.Exit +import ControlMaybe +import Data.Char +import Control.Arrow (second) +import Data.Traversable +import System.Console.CmdArgs +-- import System.Posix.Time +import Data.Time.Clock.POSIX +import System.Posix.IO (fdToHandle,fdRead) +import System.Posix.Files +import Data.Monoid ((<>)) +-- import Data.X509 + +data RSAPublicKey = RSAKey MPI MPI deriving Show + +instance ASN1Object RSAPublicKey where + toASN1 (RSAKey (MPI n) (MPI e)) + = \xs -> Start Sequence + : IntVal n + : IntVal e + : End Sequence + : xs + fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = + Right (RSAKey (MPI modulus) (MPI pubexp) , xs) + fromASN1 _ = + Left "fromASN1: RSAPublicKey: unexpected format" + +data RSAPrivateKey = RSAPrivateKey + { rsaN :: MPI + , rsaE :: MPI + , rsaD :: MPI + , rsaP :: MPI + , rsaQ :: MPI + , rsaDmodP1 :: MPI + , rsaDmodQminus1 :: MPI + , rsaCoefficient :: MPI + } + deriving Show + +{- +RSAPrivateKey ::= SEQUENCE { + version Version, + modulus INTEGER, -- n + publicExponent INTEGER, -- e + privateExponent INTEGER, -- d + prime1 INTEGER, -- p + prime2 INTEGER, -- q + exponent1 INTEGER, -- d mod (p1) + exponent2 INTEGER, -- d mod (q-1) + coefficient INTEGER, -- (inverse of q) mod p + otherPrimeInfos OtherPrimeInfos OPTIONAL +} +-} + +instance ASN1Object RSAPrivateKey where + toASN1 rsa@(RSAPrivateKey {}) + = \xs -> Start Sequence + : IntVal 0 + : mpiVal rsaN + : mpiVal rsaE + : mpiVal rsaD + : mpiVal rsaP + : mpiVal rsaQ + : mpiVal rsaDmodP1 + : mpiVal rsaDmodQminus1 + : mpiVal rsaCoefficient + : End Sequence + : xs + where mpiVal f = IntVal x where MPI x = f rsa + + fromASN1 ( Start Sequence + : IntVal _ -- version + : IntVal n + : IntVal e + : IntVal d + : IntVal p + : IntVal q + : IntVal dmodp1 + : IntVal dmodqminus1 + : IntVal coefficient + : ys) = + Right ( privkey, tail $ dropWhile notend ys) + where + notend (End Sequence) = False + notend _ = True + privkey = RSAPrivateKey + { rsaN = MPI n + , rsaE = MPI e + , rsaD = MPI d + , rsaP = MPI p + , rsaQ = MPI q + , rsaDmodP1 = MPI dmodp1 + , rsaDmodQminus1 = MPI dmodqminus1 + , rsaCoefficient = MPI coefficient + } + fromASN1 _ = + Left "fromASN1: RSAPrivateKey: unexpected format" + +rsaKeyFromPacket p@(PublicKeyPacket {}) = do + n <- lookup 'n' $ key p + e <- lookup 'e' $ key p + return $ RSAKey n e +rsaKeyFromPacket p@(SecretKeyPacket {}) = do + n <- lookup 'n' $ key p + e <- lookup 'e' $ key p + return $ RSAKey n e +rsaKeyFromPacket _ = Nothing +derRSA rsa = do + k <- rsaKeyFromPacket rsa + return $ encodeASN1 DER (toASN1 k []) + +getPackets :: IO [Packet] +getPackets = do + input <- L.getContents + case decodeOrFail input of + Right (_,_,Message pkts) -> return pkts + Left (_,_,_) -> return [] + + +secretToPublic pkt@(SecretKeyPacket {}) = + PublicKeyPacket { version = version pkt + , timestamp = timestamp pkt + , key_algorithm = key_algorithm pkt + , key = let seckey = key pkt + pubs = public_key_fields (key_algorithm pkt) + in filter (\(k,v) -> k `elem` pubs) seckey + , is_subkey = is_subkey pkt + , v3_days_of_validity = Nothing + } +secretToPublic pkt = pkt + + +extractPEM typ pem = dta + where + dta = case ys of + _:dta_lines -> Char8.concat dta_lines + [] -> "" + xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) + ys = takeWhile (/="-----END " <> typ <> "-----") xs + +isKey (PublicKeyPacket {}) = True +isKey (SecretKeyPacket {}) = True +isKey _ = False + +isUserID (UserIDPacket {}) = True +isUserID _ = False + +isEmbeddedSignature (EmbeddedSignaturePacket {}) = True +isEmbeddedSignature _ = False + +isCertificationSig (CertificationSignature {}) = True +isCertificationSig _ = True + +issuer (IssuerPacket issuer) = Just issuer +issuer _ = Nothing +backsig (EmbeddedSignaturePacket s) = Just s +backsig _ = Nothing + +isSubkeySignature (SubkeySignature {}) = True +isSubkeySignature _ = False + +isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k +isMasterKey _ = False + +now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime + +usage (NotationDataPacket + { human_readable = True + , notation_name = "usage@" + , notation_value = u + }) = Just u +usage _ = Nothing + +verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) + where + verified = do + sig <- signatures (Message nonkeys) + let v = verify (Message keys) sig + guard (not . null $ signatures_over v) + return v + (top,othersigs) = partition isSubkeySignature verified + embedded = do + sub <- top + let sigover = signatures_over sub + unhashed = sigover >>= unhashed_subpackets + subsigs = mapMaybe backsig unhashed + sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) + let v = verify (Message [subkey sub]) sig + guard (not . null $ signatures_over v) + return v + +grip k = drop 32 $ fingerprint k + +smallpr k = drop 24 $ fingerprint k + +-- matchpr computes the fingerprint of the given key truncated to +-- be the same lenght as the given fingerprint for comparison. +matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp + + +disjoint_fp ks = {- concatMap group2 $ -} transpose grouped + where + grouped = groupBy samepr . sortBy (comparing smallpr) $ ks + samepr a b = smallpr a == smallpr b + + {- + -- useful for testing + group2 :: [a] -> [[a]] + group2 (x:y:ys) = [x,y]:group2 ys + group2 [x] = [[x]] + group2 [] = [] + -} + +verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures) +verifyBindingsEx pkts = bicat . unzip $ do + let (keys,_) = partition isKey pkts + keys <- disjoint_fp keys + return $ verifyBindings keys pkts + where + bicat (xs,ys) = (concat xs,concat ys) + +getBindings :: + [Packet] + -> + ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets + -- that were used for the verifications + , [(Word8, + (Packet, Packet), -- (topkey,subkey) + [String], -- usage flags + [SignatureSubpacket], -- hashed data + [Packet])] -- ^ binding signatures + ) +getBindings pkts = (sigs,bindings) + where + (sigs,concat->bindings) = unzip $ do + let (keys,nonkeys) = partition isKey pkts + keys <- disjoint_fp keys + let (bs,sigs) = verifyBindings keys pkts + return . ((keys,sigs),) $ do + b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs + i <- map signature_issuer (signatures_over b) + i <- maybeToList i + who <- maybeToList $ find_key fingerprint (Message keys) i + let (code,claimants) = + case () of + _ | who == topkey b -> (1,[]) + _ | who == subkey b -> (2,[]) + _ -> (0,[who]) + let hashed = signatures_over b >>= hashed_subpackets + kind = guard (code==1) >> hashed >>= maybeToList . usage + return (code,(topkey b,subkey b), kind, hashed,claimants) + +-- Returned data is simmilar to getBindings but the Word8 codes +-- are ORed together. +accBindings :: + Bits t => + [(t, (Packet, Packet), [a], [a1], [a2])] + -> [(t, (Packet, Packet), [a], [a1], [a2])] +accBindings bs = as + where + gs = groupBy samePair . sortBy (comparing bindingPair) $ bs + as = map (foldl1 combine) gs + bindingPair (_,p,_,_,_) = pub2 p + where + pub2 (a,b) = (pub a, pub b) + pub a = fingerprint_material a + samePair a b = bindingPair a == bindingPair b + combine (ac,p,akind,ahashed,aclaimaints) + (bc,_,bkind,bhashed,bclaimaints) + = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) + + +data UserIDRecord = UserIDRecord { + uid_full :: String, + uid_realname :: T.Text, + uid_user :: T.Text, + uid_subdomain :: T.Text, + uid_topdomain :: T.Text +} + deriving Show + +isBracket '<' = True +isBracket '>' = True +isBracket _ = False + +parseUID str = UserIDRecord { + uid_full = str, + uid_realname = realname, + uid_user = user, + uid_subdomain = subdomain, + uid_topdomain = topdomain + } + where + text = T.pack str + (T.strip-> realname, T.dropAround isBracket-> email) + = T.break (=='<') text + (user, T.tail-> hostname) = T.break (=='@') email + ( T.reverse -> topdomain, + T.reverse . T.drop 1 -> subdomain) + = T.break (=='.') . T.reverse $ hostname + + +derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy + +fpmatch grip key = + (==) Nothing + (fmap (backend (fingerprint key)) grip >>= guard . not) + where + backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) + +listKeys pkts = listKeysFiltered [] pkts + +listKeysFiltered grips pkts = do + let (certs,bs) = getBindings pkts + as = accBindings bs + defaultkind (k:_) hs = k + defaultkind [] hs = maybe "subkey" + id + ( listToMaybe + . mapMaybe (fmap usageString . keyflags) + $ hs) + kinds = map (\(_,_,k,h,_)->defaultkind k h) as + kindwidth = maximum $ map length kinds + kindcol = min 20 kindwidth + code (c,(m,s),_,_,_) = (fingerprint_material m,-c) + ownerkey (_,(a,_),_,_,_) = a + sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b + matchgrip _ | null grips = True + matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True + matchgrip _ = False + gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) + subs <- gs + let (code,(top,sub), kind, hashed,claimants):_ = subs + subkeys = do + (code,(top,sub), kind, hashed,claimants) <- subs + let ar = case code of + 0 -> " ??? " + 1 -> " --> " + 2 -> " <-- " + 3 -> " <-> " + formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' + -- torhash = maybe "" id $ derToBase32 <$> derRSA sub + concat [ " " + -- , grip top + , (if not (null claimants) + then trace ("claimants: "++show (map fingerprint claimants)) + else id) ar + , formkind + , " " + , fingerprint sub + -- , " " ++ torhash + , "\n" ] + -- ++ ppShow hashed + torkeys = do + (code,(top,sub), kind, hashed,claimants) <- subs + guard ("tor" `elem` kind) + guard (code .&. 0x2 /= 0) + maybeToList $ derToBase32 <$> derRSA sub + uid = {- maybe "" id . listToMaybe $ -} do + (keys,sigs) <- certs + sig <- sigs + guard (isCertificationSig sig) + guard (topkey sig == top) + let issuers = do + sig_over <- signatures_over sig + i <- maybeToList $ signature_issuer sig_over + maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i))) + (primary,secondary) = partition (==top) issuers + + -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return () + -- trace ("SECONDARY: "++show (map fingerprint secondary)) $ return () + guard (not (null primary)) + + let UserIDPacket uid = user_id sig + parsed = parseUID uid + ar = maybe " --> " (const " <-> ") $ do + guard (uid_topdomain parsed == "onion" ) + guard ( uid_realname parsed `elem` ["","Anonymous"]) + guard ( uid_user parsed == "root" ) + let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] + len = L.length subdom0 + subdom = Char8.unpack subdom0 + match = ( (==subdom) . take (fromIntegral len)) + guard (len >= 16) + listToMaybe $ filter match torkeys + unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ] + ++ map (\k -> " " ++ "^ signed: " ++ fingerprint k) secondary + (_,sigs) = unzip certs + "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" + + +data PGPKeyFlags = + Special + | Vouch -- Signkey + | Sign + | VouchSign + | Communication + | VouchCommunication + | SignCommunication + | VouchSignCommunication + | Storage + | VouchStorage + | SignStorage + | VouchSignStorage + | Encrypt + | VouchEncrypt + | SignEncrypt + | VouchSignEncrypt + deriving (Eq,Show,Read,Enum) + +usageString flgs = + case flgs of + Special -> "special" + Vouch -> "vouch" -- signkey + Sign -> "sign" + VouchSign -> "vouch-sign" + Communication -> "communication" + VouchCommunication -> "vouch-communication" + SignCommunication -> "sign-communication" + VouchSignCommunication -> "vouch-sign-communication" + Storage -> "storage" + VouchStorage -> "vouch-storage" + SignStorage -> "sign-storage" + VouchSignStorage -> "vouch-sign-storage" + Encrypt -> "encrypt" + VouchEncrypt -> "vouch-encrypt" + SignEncrypt -> "sign-encrypt" + VouchSignEncrypt -> "vouch-sign-encrypt" + + +keyflags flgs@(KeyFlagsPacket {}) = + Just . toEnum $ + ( bit 0x1 certify_keys + .|. bit 0x2 sign_data + .|. bit 0x4 encrypt_communication + .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags + -- other flags: + -- split_key + -- authentication (ssh-client) + -- group_key + where + bit v f = if f flgs then v else 0 +keyflags _ = Nothing + + +modifyUID (UserIDPacket str) = UserIDPacket str' + where + (fstname,rst) = break (==' ') str + str' = mod fstname ++ rst + mod "Bob" = "Bob Fucking" + mod x = x +modifyUID other = other + +todo = error "unimplemented" + +-- TODO: switch to System.Environment.lookupEnv +-- when linking against newer base libraries. +lookupEnv var = + handleIO_ (return Nothing) $ fmap Just (getEnv var) + +unmaybe def = fmap (maybe def id) + +expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs) + | otherwise = c:cs +expandPath path [] = [] + + +readPacketsFromFile :: FilePath -> IO Message +readPacketsFromFile fname = do + input <- L.readFile fname + return $ + case decodeOrFail input of + Right (_,_,msg ) -> msg + Left (_,_,_) -> Message [] + + +parseOptionFile fname = do + xs <- fmap lines (readFile fname) + let ys = filter notComment xs + notComment ('#':_) = False + notComment cs = not (all isSpace cs) + return ys + +{- +options_from_file :: + (forall a. [String] -> Term a -> IO (Either EvalExit a)) + -> Term b + -> (String,String,Term (Maybe String)) + -> ([String],Term (Maybe String)) + -> IO [String] +options_from_file unwrapCmd term (homevar,appdir,home) (optfile_alts,options_file) = doit + where + homedir = envhomedir <$> home + envhomedir opt = do + gnupghome <- lookupEnv homevar >>= + \d -> return $ d >>= guard . (/="") >> d + home <- flip fmap getHomeDirectory $ + \d -> fmap (const d) $ guard (d/="") + let homegnupg = (++('/':appdir)) <$> home + let val = (opt `mplus` gnupghome `mplus` homegnupg) + return $ val + + doit = do + args <- getArgs + {- + let wants_help = + not . null $ filter cryForHelp args + where cryForHelp "--help" = True + cryForHelp "--version" = True + cryForHelp x = + and (zipWith (==) x "--help=") + -} + (o,h) <- do + val <- unwrapCmd args (liftA2 (,) options_file homedir) + case val of + Left e -> return (Nothing,Nothing) + Right (o,h) -> (o,) <$> h + ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> + let optfiles = map (second ((h++"/")++)) + (maybe optfile_alts' (:[]) o') + optfile_alts' = zip (False:repeat True) optfile_alts + o' = fmap (False,) o + in filterM (doesFileExist . snd) optfiles + args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do + let h' = fromJust h + newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname + let toArgs = toHead ("--"++) . words + toHead f (x:xs) = f x : xs + toHead f [] = [] + voidTerm = fmap (const ()) + appendArgs as [] = return as + appendArgs as (configline:cs) = do + let xs = toArgs configline + w <-unwrap (xs++as) (voidTerm term,defTI) + case w of + Left _ -> appendArgs as cs + Right _ -> appendArgs (xs++as) cs + -- TODO: check errors if forgive = False + appendArgs args newargs + return args + +runWithOptionsFile :: (Term (IO b), TermInfo) -> IO b +runWithOptionsFile (term,ti) = do + as <- options_from_file unwrapCmd + term + ("GNUPGHOME",".gnupg",opt_homedir) + (["keys.conf","gpg.conf-2","gpg.conf"] + ,opt_options) + q <- eval as (term , ti) + q + where + unwrapCmd args term = unwrap args (term,defTI) + +runChoiceWithOptionsFile :: + (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b +runChoiceWithOptionsFile (realterm,ti) choices = do + as <- options_from_file unwrapCmd + realterm + ("GNUPGHOME",".gnupg",opt_homedir) + (["keys.conf","gpg.conf-2","gpg.conf"] + ,opt_options) + -- putStrLn $ "as = " ++ show as + q <- evalChoice as (realterm , ti) choices + q + where + unwrapCmd args t = + unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices) + neuter term (t,ti) = (t <:> term, ti) + +data Command = + List + | Autosign + deriving (Eq,Show,Read,Enum) + +capitolizeFirstLetter (x:xs) = toUpper x : xs +capitolizeFirstLetter xs = xs + +instance ArgVal Command where + converter = + ( maybe (Left $ text "unknown command") Right + . fmap fst . listToMaybe . reads + . capitolizeFirstLetter . map toLower + , text . map toLower . show + ) +class AutoMaybe a +instance AutoMaybe Command +instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where + converter = + ( toRight Just . fst converter + , maybe (text "(unspecified)") id . fmap (snd converter) + ) + +toRight f (Right x) = Right (f x) +toRight f (Left y) = Left y + +cmd :: Term Command +cmd = required . pos 0 Nothing $ posInfo + { posName = "command" + , posDoc = "What action to perform." + } + +a <:> b = flip const <$> a <*> b +infixr 2 <:> + +selectAction cmd actions = actions !! fromEnum cmd + +cmdInfo :: ArgVal cmd => + cmd -> String -> Term a -> (cmd, (Term a, TermInfo)) +cmdInfo cmd doc action = + ( cmd + , ( action + , defTI { termName = print cmd + , termDoc = doc } ) ) + where + print = show . snd converter + +cmdlist :: (Command, (Term (IO ()), TermInfo)) +cmdlist = cmdInfo List "list key pairs for which secrets are known" $ + (>>= putStrLn . listKeys . unMessage) <$> secret_packets + where unMessage (Message pkts) = pkts + +cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $ + pure (putStrLn "autosign") + + +multiCommand :: + TermInfo + -> [(Command, (Term a, TermInfo))] + -> ( (Term a, TermInfo) + , [(Term a, TermInfo)] ) +multiCommand ti choices = + ( ( selectAction <$> cmd <*> sequenceA (map strip choices) + , ti ) + , map snd choices ) + where + selectAction cmd choices = + fromJust $ lookup (cmd::Command) choices + strip (cmd,(action,_)) = fmap (cmd,) action +-} + + +trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs + +guessKeyFormat 'P' "ssh-client" = "SSH" +guessKeyFormat 'S' "ssh-client" = "PEM" +guessKeyFormat 'S' "ssh-host" = "PEM" +guessKeyFormat _ _ = "PEM" -- "PGP" + +readKeyFromFile False "PEM" fname = do + timestamp <- modificationTime <$> getFileStatus fname + input <- L.readFile fname + let dta = extractPEM "RSA PRIVATE KEY" input + -- Char8.putStrLn $ "dta = " <> dta + let rsa = do + e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) + asn1 <- either (const Nothing) Just e + k <- either (const Nothing) (Just . fst) (fromASN1 asn1) + let _ = k :: RSAPrivateKey + return k + -- putStrLn $ "rsa = "++ show rsa + return . Message $ do + rsa <- maybeToList rsa + return $ SecretKeyPacket + { version = 4 + , timestamp = toEnum (fromEnum timestamp) + , key_algorithm = RSA + , key = [ -- public fields... + ('n',rsaN rsa) + ,('e',rsaE rsa) + -- secret fields + ,('d',rsaD rsa) + ,('p',rsaQ rsa) -- Note: p & q swapped + ,('q',rsaP rsa) -- Note: p & q swapped + ,('u',rsaCoefficient rsa) + ] + , s2k_useage = 0 + , s2k = S2K 100 "" + , symmetric_algorithm = Unencrypted + , encrypted_data = "" + , is_subkey = True + } +readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) + +data Arguments = + List { homedir :: Maybe FilePath } + | WorkingKey { homedir :: Maybe FilePath } + | AutoSign { homedir :: Maybe FilePath + , passphrase_fd :: Maybe Int + , input :: FilePath + , output :: FilePath} + | Public { homedir :: Maybe FilePath + , output :: FilePath} + | Add { homedir :: Maybe FilePath + , passphrase_fd :: Maybe Int + , key_usage :: String + , seckey :: String + , output :: FilePath } + | PemFP { homedir :: Maybe FilePath + , seckey :: String } + | CatPub { homedir :: Maybe FilePath + , catpub_args :: [String] } + {- + | Decrypt { homedir :: Maybe FilePath + , passphrase_fd :: Maybe Int + , output :: FilePath } + -} + deriving (Show, Data, Typeable) + +getPassphrase cmd = + case passphrase_fd cmd of + Just fd -> do pwh <- fdToHandle (toEnum fd) + fmap trimCR $ S.hGetContents pwh + Nothing -> return "" + + +#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) + +main = do + args <- cmdArgs $ modes + [ List HOMEOPTION + &= help "List key pairs in the secret keyring." + &= auto + , WorkingKey HOMEOPTION + &= help "Shows the current working key set that will be used to make signatures." + , Public HOMEOPTION + (def &= argPos 1 &= typFile ) + &= help "Extract public keys into the given file." + , AutoSign HOMEOPTION + (def &= opt ("passphrase"::String) + &= typ "FD" + &= (help . concat) ["file descriptor from " + ,"which to read passphrase"]) + (def &= argPos 1 &= typFile ) + (def &=argPos 2 &= typFile) + &= (help . concat) + [ "Copies the first file to the second while adding" + , " signatures for tor-style uids that match" + , " cross-certified keys." ] + {- + , Decrypt HOMEOPTION + (def &= opt ("passphrase"::String) + &= typ "FD" + &= (help . concat) ["file descriptor from " + ,"which to read passphrase"]) + (def &= argPos 1 &= typFile ) + -- (def &= argPos 3 &= typ "PUBLIC-KEY") + &= (help . concat) + [ "Remove password protection from the working keyring" + , " and save the result into the given file."] + -} + , CatPub HOMEOPTION + (def &= args &= typ "KEYSPEC FILES") + &= help "Extract a public subkey to stdout." + , Add HOMEOPTION + (def &= opt ("passphrase"::String) + &= typ "FD" + &= (help . concat) ["file descriptor from " + ,"which to read passphrase"]) + (def &= argPos 1 &= typ "USAGE") + (def &= argPos 2 &= typ "PRIVATE-KEY") + (def &= argPos 3 &= typFile) + -- (def &= argPos 3 &= typ "PUBLIC-KEY") + &= (help . concat) + [ "Add a subkey." + , " USAGE is the usage@ annotation of the subkey." + , " Keys are specified as FMT:FILE where" + , " FMT may be one of following: PEM." + , " Results are written to the given file." ] + + , PemFP HOMEOPTION + (def &= argPos 1 &= typFile ) + &= (help . concat) + [ "Display the fingerprint of a PEM key pair."] + ] + &= program "kiki" + &= summary "kiki - a pgp key editing utility" + doCmd args + where + envhomedir opt = do + gnupghome <- lookupEnv homevar >>= + \d -> return $ d >>= guard . (/="") >> d + home <- flip fmap getHomeDirectory $ + \d -> fmap (const d) $ guard (d/="") + let homegnupg = (++('/':appdir)) <$> home + let val = (opt `mplus` gnupghome `mplus` homegnupg) + return $ val + + homevar = "GNUPGHOME" + appdir = ".gnupg" + optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] + + getHomeDir cmd = do + homedir <- envhomedir (homedir cmd) + flip (maybe (error "Could not determine home directory.")) + homedir $ \homedir -> do + -- putStrLn $ "homedir = " ++show homedir + let secring = homedir ++ "/" ++ "secring.gpg" + -- putStrLn $ "secring = " ++ show secring + workingkey <- getWorkingKey homedir + return (homedir,secring,workingkey) + + getWorkingKey homedir = do + let o = Nothing + h = Just homedir + args = ["hi"] + ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> + let optfiles = map (second ((h++"/")++)) + (maybe optfile_alts' (:[]) o') + optfile_alts' = zip (False:repeat True) optfile_alts + o' = fmap (False,) o + in filterM (doesFileExist . snd) optfiles + args <- flip (maybe $ return []) ofile $ + \(forgive,fname) -> parseOptionFile fname + let config = map (topair . words) args + where topair (x:xs) = (x,xs) + return $ lookup "default-key" config >>= listToMaybe + + getPGPEnviron cmd = do + (homedir,secring,grip) <- getHomeDir cmd + (Message sec) <- readPacketsFromFile secring + let (keys,_) = partition (\k -> case k of + { SecretKeyPacket {} -> True + ; _ -> False }) + sec + return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys)) + + getTorKeys pub = do + xs <- groupBindings pub + (_,(top,sub),us,_,_) <- xs + guard ("tor" `elem` us) + let torhash = maybe "" id $ derToBase32 <$> derRSA sub + return (top,(torhash,sub)) + + uidScan pub = scanl (\(mkey,u) w -> + case () of + _ | isMasterKey w -> (w,u) + _ | isUserID w -> (mkey,w) + _ | otherwise -> (mkey,u) + ) + (w0,w0) + ws + where + w0:ws = pub + + signSelfAuthTorKeys pw g sec grip timestamp xs = ys + where + keys = filter isKey sec + selfkey = find_key fingerprint (Message keys) (fromJust grip) >>= decryptKey + where + decryptKey k = decryptSecretKey pw k + mainpubkey = fst (head xs) + uid:xs' = map snd xs + (sigs, xs'') = span isSignaturePacket xs' + overs sig = signatures $ Message (keys++[uid,sig]) + vs :: [ ( Packet -- signature + , Maybe SignatureOver) -- Nothing means non-verified + ] + vs = do + sig <- sigs + let vs = overs sig >>= return . verify (Message keys) + ws = filter (not . null . signatures_over) vs + ws' = if null ws then [Nothing] else map Just ws + v <- ws' + return (sig,v) + has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs + sigs' = if has_self + then sigs + {- + else trace ( "key params: "++params (fromJust selfkey)++"\n" + ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig) + -} + else sigs ++ signatures_over new_sig + modsig sig = sig { signature = map id (signature sig) } + where plus1 (MPI x) = MPI (x+1) + params newtop = public ++ map fst (key newtop) ++ "}" + where + public = case newtop of + PublicKeyPacket {} -> "public{" + SecretKeyPacket {} -> if L.null (encrypted_data newtop ) + then "secret{" + else "encrypted{" + _ -> "??????{" + traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) + ,"new_sig topkey:"++ (show . fingerprint $ newtop) + ,"new_sig topkey params: "++ params newtop + ,"new_sig user_id:"++ (show newuid) + ,"new_sig |over| = " ++ (show . length $ new_sig) + ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) + ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) + ,"new_sig type: " ++ (show . map signature_type $ new_sig) + ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) + ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) + ,"issuer = " ++ show (map signature_issuer new_sig) + ]) + new_sig = fst $ sign (Message (maybeToList selfkey)) + (CertificationSignature mainpubkey + uid + []) --fromJust selfkey, uid]) + SHA1 + (fromJust grip) + timestamp + g + ys = uid:sigs'++xs'' + + doCmd cmd@(List {}) = do + (homedir,secring,grip) <- getHomeDir cmd + (Message sec) <- readPacketsFromFile secring + putStrLn $ listKeys sec + + doCmd cmd@(WorkingKey {}) = do + (homedir,secring,grip) <- getHomeDir cmd + (Message sec) <- readPacketsFromFile secring + -- let s2k' = map s2k (filter isKey sec) + -- putStrLn $ "s2k = " ++ show s2k' + putStrLn $ listKeysFiltered (maybeToList grip) sec + return () + + doCmd cmd@(AutoSign {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + S8.putStrLn $ "pasphrase_fd = " <> S8.pack (show (passphrase_fd cmd)) + pw <- getPassphrase cmd + -- 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 pw (g::SystemRandom) sec grip timestamp) + (map (map cleanup) xss) + cleanup (_,(topkey,_,pkt)) = (topkey,pkt) + putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub') + putStrLn "" + putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub')) (sec++pub') + + let signed_bs = encode (Message pub') + L.writeFile (output cmd) signed_bs + + doCmd cmd@(Public {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + let pub = map secretToPublic sec + bs = encode (Message pub) + L.writeFile (output cmd) bs + + {- + doCmd cmd@(Decrypt {}) = do + ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome + , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg + , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" + ) <- getPGPEnviron cmd + pw <- getPassphrase cmd + + let sec' = map decrypt sec + decrypt k@(SecretKeyPacket {}) = k -- TODO + + L.writeFile (output cmd) (encode $ Message sec') + + {- + let wk = grip >>= find_key fingerprint (Message sec) + case wk of + Nothing -> error "No working key?" + Just wk -> do + putStrLn $ "wk = " ++ fingerprint wk + -} + -} + + doCmd cmd@(CatPub {}) = do + let spec:files = catpub_args cmd + putStrLn $ "spec = " ++show spec + putStrLn $ "files = " ++ show files + return () + + 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 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 + + 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 + -- -- Message pubkey <- readKeyFromFile True pubfmt pubfile + + -- putStrLn $ "parsedkey = " ++ show (head parsedkey) + -- putStrLn $ "----------" + + {- + let seckeys = filter isSecretKey sec + isSecretKey (SecretKeyPacket {}) = True + isSecretKey _ = False + algos = map symmetric_algorithm seckeys + putStrLn $ show $ symmetric_algorithm wk + putStrLn $ show $ s2k wk + putStrLn $ show $ s2k_useage wk + putStrLn $ PP.ppShow sec + let -- e = encryptSecretKey wk pw (head seckey) + e = head seckey + d = if symmetric_algorithm e /= Unencrypted + then maybeToList $ decryptSecretKey pw e + else [e] + putStrLn $ "e = " ++ show (e) + -} + -- putStrLn $ "wkun = " ++ show wkun + -- putStrLn $ "head subkeys = " ++ show (head subkeys) + + 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) + 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] + + 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 = key_usage cmd + } + ] + + 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 cmd) (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 () + + 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 + putStrLn $ fingerprint (head seckey) + + + + +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 + + +seek_key :: String -> [Packet] -> ([Packet],[Packet]) +seek_key grip sec = (pre, subs) + where + (pre,subs) = break pred sec + pred p@(SecretKeyPacket {}) = matchpr grip p == grip + pred _ = False -- cgit v1.2.3