path: root/keys.hs

{-# 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