2 files changed, 471 insertions, 400 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 5547673..9fd65f8 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -9,23 +9,35 @@ import System.Environment
 import Control.Monad
 import Data.Maybe
 import Data.Char
+import Data.Ord
 import Data.List
 import Data.OpenPGP
 import Data.Functor
 import Data.Bits              ( (.|.) )
--- import Control.Applicative    ( (<$>) )
+import Control.Applicative    ( liftA2, (<$>) )
 import System.Directory       ( getHomeDirectory, doesFileExist )
 import Control.Arrow          ( first, second )
-import Data.OpenPGP.Util      ( fingerprint )
+import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
 import Data.ByteString.Lazy   ( ByteString )
 import Text.Show.Pretty as PP ( ppShow )
 import Data.Word ( Word8 )
 import Data.Binary ( decode )
 import ControlMaybe ( handleIO_ )
+import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
+       , ASN1(Start,End,IntVal,OID,BitString), ASN1ConstructionType(Sequence) )
+import Data.ASN1.BitArray ( BitArray(..), toBitArray )
+import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1' )
+import Data.ASN1.BinaryEncoding ( DER(..) )
+import Data.Time.Clock.POSIX ( getPOSIXTime )
 import qualified Data.Map as Map
 import qualified Data.ByteString.Lazy as L ( null, readFile, ByteString )
+import qualified Data.ByteString      as S ( unpack )
 import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break ) 
 import qualified Crypto.Types.PubKey.ECC as ECC
+import qualified Codec.Binary.Base32 as Base32
+import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Data.Text as T ( Text, unpack, pack,
+        strip, reverse, drop, break, dropAround )
 import System.Posix.Types (EpochTime)
 import System.Posix.Files ( modificationTime, getFileStatus )
 
@@ -97,12 +109,69 @@ filesToLock k secring pubring = do
 
 todo = error "unimplemented"
 
-data KikiCondition a = KikiSuccess a | FailedToLock [FilePath]
+data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
+data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
+
+pkcs8 (RSAKey n e) = RSAKey8 n e
+
+instance ASN1Object RSAPublicKey where
+    -- PKCS #1 RSA Public Key
+    toASN1 (RSAKey (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : IntVal n
+                         : IntVal e
+                         : End Sequence
+                         : xs
+    fromASN1 _ =
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+instance ASN1Object PKCS8_RSAPublicKey where
+
+    -- PKCS #8 Public key data
+    toASN1 (RSAKey8 (MPI n) (MPI e))
+                  = \xs -> Start Sequence
+                         : Start Sequence
+                         : OID [1,2,840,113549,1,1,1]
+                         : End Sequence
+                         : BitString (toBitArray bs 0)
+                         : End Sequence
+                         : xs
+        where
+            pubkey = Start Sequence : IntVal n : IntVal e : End Sequence : []
+            bs = encodeASN1' DER pubkey
+
+    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
+        Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
+    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
+        case decodeASN1' DER bs of
+            Right as -> fromASN1 as
+            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
+      where
+        BitArray _ bs = b
+
+    fromASN1 _ =
+        Left "fromASN1: RSAPublicKey: unexpected format"
+
+data RSAPrivateKey = RSAPrivateKey
+    { rsaN :: MPI
+    , rsaE :: MPI
+    , rsaD :: MPI
+    , rsaP :: MPI
+    , rsaQ :: MPI
+    , rsaDmodP1 :: MPI
+    , rsaDmodQminus1 :: MPI
+    , rsaCoefficient :: MPI
+    }
+ deriving Show
+
+
+data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] | BadPassphrase
 
 #define TRIVIAL(OP) fmap _ (OP) = OP
 instance Functor KikiCondition where
     fmap f (KikiSuccess a) = KikiSuccess (f a)
     TRIVIAL( FailedToLock x )
+    TRIVIAL( BadPassphrase )
 instance FunctorToMaybe KikiCondition where
     functorToMaybe (KikiSuccess a) = Just a
     functorToMaybe _               = Nothing
@@ -115,6 +184,8 @@ data KikiReportAction =
         | NewWalletKey String
         | YieldSignature
         | YieldSecretKeyPacket String
+        | UnableToUpdateExpiredSignature
+        | FailedToMakeSignature
 
 data KikiResult a = KikiResult
     { kikiCondition :: KikiCondition a
@@ -130,6 +201,45 @@ usage (NotationDataPacket
         }) = Just u
 usage _    = Nothing
 
+-- torsig g topk wkun uid timestamp extras = todo
+torSigOver topk wkun uid extras
+    = CertificationSignature (secretToPublic topk)
+                             uid
+                             (sigpackets 0x13
+                                         subpackets
+                                         subpackets_unh)
+   where
+    subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
+                 tsign
+                 ++ extras
+    subpackets_unh = [IssuerPacket (fingerprint wkun)]
+    tsign = if keykey wkun == keykey topk
+             then [] -- tsign doesnt make sense for self-signatures
+             else [ TrustSignaturePacket 1 120
+                  , RegularExpressionPacket regex]
+    -- <[^>]+[@.]asdf\.nowhere>$
+    regex = "<[^>]+[@.]"++hostname++">$"
+    -- regex = username ++ "@" ++ hostname
+    -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
+    hostname = subdomain' pu ++ "\\." ++ topdomain' pu
+    pu = parseUID uidstr where UserIDPacket uidstr = uid
+    subdomain' = escape . T.unpack . uid_subdomain
+    topdomain' = escape . T.unpack . uid_topdomain
+    escape s = concatMap echar s
+      where
+        echar '|' = "\\|"
+        echar '*' = "\\*"
+        echar '+' = "\\+"
+        echar '?' = "\\?"
+        echar '.' = "\\."
+        echar '^' = "\\^"
+        echar '$' = "\\$"
+        echar '\\' = "\\\\"
+        echar '[' = "\\["
+        echar ']' = "\\]"
+        echar c = [c]
+
+
 keyflags flgs@(KeyFlagsPacket {}) =
     Just . toEnum $
         (   bit 0x1 certify_keys
@@ -268,6 +378,37 @@ matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us
   where
     us = filter (isInfixOf pat) $ Map.keys uids
 
+data UserIDRecord = UserIDRecord {
+    uid_full :: String,
+    uid_realname :: T.Text,
+    uid_user :: T.Text,
+    uid_subdomain :: T.Text,
+    uid_topdomain :: T.Text
+}
+ deriving Show
+
+parseUID str = UserIDRecord {
+                    uid_full = str,
+                    uid_realname = realname,
+                    uid_user = user,
+                    uid_subdomain = subdomain,
+                    uid_topdomain = topdomain
+                }
+ where
+    text = T.pack str
+    (T.strip-> realname, T.dropAround isBracket-> email)
+                              = T.break (=='<') text
+    (user, T.drop 1-> hostname) = T.break (=='@') email
+    ( T.reverse            -> topdomain,
+      T.reverse . T.drop 1 -> subdomain)
+                              = T.break (=='.') . T.reverse $ hostname
+isBracket :: Char -> Bool
+isBracket '<' = True
+isBracket '>' = True
+isBracket _   = False
+
+
+
 
 data KeySpec =
       KeyGrip String
@@ -309,11 +450,132 @@ buildKeyDB secring pubring grip0 keyring = do
         db0 = foldl' (uncurry . merge) Map.empty ms
 
     wms <- mapM (readw wk) (files iswallet)
-
+    let wms' = do
+            maybeToList wk
+            (fname,xs) <- wms
+            (_,sub,(_,m)) <- xs
+            (tag,top) <- Map.toList m
+            return (top,fname,sub,tag)
+
+        {-
+        importWalletKey db' (top,fname,sub,tag) = do
+            doImportG doDecrypt 
+                      db'
+                      (fmap keykey $ maybeToList wk)
+                      tag
+                      fname
+                      sub
+        -}
+
+    -- db <- foldM importWalletKey db0 ts
     (db,report)  <- return (db0,[]) -- todo
 
     return ( (db, grip), report )
 
+torhash key = maybe "" id $ derToBase32 <$> derRSA key
+
+derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
+
+derRSA rsa = do
+    k <- rsaKeyFromPacket rsa
+    return $ encodeASN1 DER (toASN1 k [])
+
+try :: KikiCondition a -> (a -> IO (KikiCondition b)) -> IO (KikiCondition b)
+try wkun body =
+    case functorToEither wkun of
+           Left e -> return e
+           Right wkun -> body wkun
+
+doImportG
+  :: Ord k =>
+     (Packet -> IO (KikiCondition Packet))
+     -> Map.Map k KeyData
+     -> [k]
+     -> [Char]
+     -> [Char]
+     -> Packet
+     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
+doImportG doDecrypt db m0 tag fname key = do
+    let kk = head m0
+        Just (KeyData top topsigs uids subs) = Map.lookup kk db
+        subkk = keykey key
+        (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
+                                               [])
+                                 ( (False,) . addOrigin )
+                                 (Map.lookup subkk subs)
+                             where
+                                addOrigin (SubKey mp sigs) = 
+                                    let mp' = mp
+                                          { locations = Map.insert fname
+                                                             (origin (packet mp) (-1))
+                                                             (locations mp) }
+                                    in SubKey mp' sigs
+        subs' = Map.insert subkk subkey subs
+
+        istor = do
+            guard (tag == "tor")
+            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+
+    uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
+                let has_torid = do
+                     -- TODO: check for omitted real name field
+                     (sigtrusts,om) <- Map.lookup idstr uids
+                     listToMaybe $ do
+                         s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
+                         signatures_over $ verify (Message [packet top]) s
+                flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
+                wkun <- doDecrypt (packet top)
+
+                try wkun $ \wkun -> do
+
+                let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
+                    uid = UserIDPacket idstr
+                    -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
+                    tor_ov = torSigOver (packet top) wkun uid keyflags
+                sig_ov <- pgpSign (Message [wkun])
+                                  tor_ov
+                                  SHA1
+                                  (fingerprint wkun)
+                flip (maybe $ return $ KikiSuccess (uids,[(fname, FailedToMakeSignature)]))
+                     (sig_ov >>= listToMaybe . signatures_over)
+                     $ \sig -> do
+                let om = Map.singleton fname (origin sig (-1))
+                    trust = Map.empty
+                return $ KikiSuccess 
+                    ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
+                                         , trust)],om) uids
+                    , [] )
+
+    try uids' $ \(uids',report) -> do
+
+    let SubKey subkey_p subsigs = subkey
+        wk = packet top
+        (xs',minsig,ys') = findTag tag wk key subsigs
+        doInsert mbsig db = do
+            sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
+            try sig' $ \(sig',report) -> do
+            report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
+            let subs' = Map.insert subkk
+                                   (SubKey subkey_p $ xs'++[sig']++ys')
+                                   subs
+            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
+                                 , report )
+
+    report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
+                                    else id
+                  s = show (fmap fst minsig,fingerprint key)
+              in return (f report)
+
+    case minsig of
+        Nothing          -> doInsert Nothing db    -- we need to create a new sig
+        Just (True,sig)  -> -- we can deduce is_new == False
+                            -- we may need to add a tor id
+                            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
+                                                 , report )
+        Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
+
+
+
 runKeyRing :: KeyRingData -> (KeyRingRuntime -> a) -> IO (KikiResult a)
 runKeyRing keyring op = do
     (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
@@ -409,6 +671,32 @@ isUserID _                 = False
 isTrust (TrustPacket {}) = True
 isTrust _                = False
 
+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]
+
+secretToPublic pkt@(SecretKeyPacket {}) =
+    PublicKeyPacket { version = version pkt
+                    , timestamp = timestamp pkt
+                    , key_algorithm = key_algorithm pkt
+                    -- , ecc_curve = ecc_curve pkt
+                    , key = let seckey = key pkt
+                                pubs = public_key_fields (key_algorithm pkt)
+                            in filter (\(k,v) -> k `elem` pubs) seckey
+                    , is_subkey = is_subkey pkt
+                    , v3_days_of_validity = Nothing
+                    }
+secretToPublic pkt = pkt
+
+
+
 slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
 slurpWIPKeys stamp "" = ([],[])
 slurpWIPKeys stamp cs =
@@ -465,6 +753,18 @@ decode_btc_key timestamp str = do
             , is_subkey = True
             }
 
+rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
+rsaKeyFromPacket p@(PublicKeyPacket {}) = do
+    n <- lookup 'n' $ key p
+    e <- lookup 'e' $ key p
+    return $ RSAKey n e
+rsaKeyFromPacket p@(SecretKeyPacket {}) = do
+    n <- lookup 'n' $ key p
+    e <- lookup 'e' $ key p
+    return $ RSAKey n e
+rsaKeyFromPacket _ = Nothing
+
+
 readPacketsFromWallet :: 
     Maybe Packet
     -> FilePath 
@@ -500,6 +800,149 @@ readPacketsFromFile fname = do
     return $ decode input
 #endif
 
+now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
+
+signature_time ov = case if null cs then ds else cs of
+                                [] -> minBound
+                                xs -> last (sort xs)
+          where
+            ps = signatures_over ov
+            ss = filter isSignaturePacket ps
+            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
+            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
+            creationTime (SignatureCreationTimePacket t) = [t]
+            creationTime _                               = []
+
+splitAtMinBy comp xs = minimumBy comp' xxs
+ where
+    xxs = zip (inits xs) (tails xs)
+    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
+    compM (Just a) (Just b) = comp a b
+    compM Nothing  mb       = GT
+    compM _        _        = LT
+
+
+
+findTag tag wk subkey subsigs = (xs',minsig,ys')
+         where
+            vs = map (\sig ->
+                          (sig, do
+                                sig <- Just (packet . fst $ sig)
+                                guard (isSignaturePacket sig)
+                                guard $ flip isSuffixOf
+                                             (fingerprint wk)
+                                        . maybe "%bad%" id
+                                        . signature_issuer
+                                        $ sig
+                                listToMaybe $
+                                  map (signature_time . verify (Message [wk]))
+                                      (signatures $ Message [wk,subkey,sig])))
+                     subsigs
+            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
+            xs' = map fst xs
+            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
+            minsig = do
+                (sig,ov) <- listToMaybe ys
+                ov
+                let hs = filter (\p->isNotation p && notation_name p=="usage@")
+                                (hashed_subpackets . packet . fst $ sig)
+                    ks = map notation_value hs
+                    isNotation (NotationDataPacket {}) = True
+                    isNotation _ = False
+                return (tag `elem` ks, sig)
+
+
+makeSig doDecrypt top fname subkey_p tag mbsig = do
+    let wk = packet top
+    wkun <- doDecrypt wk
+    try wkun $ \wkun -> do
+    let grip = fingerprint wk
+        addOrigin new_sig = do
+            flip (maybe $ error "Failed to make signature.") 
+                 (new_sig >>= listToMaybe . signatures_over) 
+                 $ \new_sig -> do
+            let mp' = mappedPacket fname new_sig
+            return (mp', Map.empty)
+        parsedkey = [packet $ subkey_p]
+        hashed0 =
+                    [ KeyFlagsPacket
+                        { certify_keys = False
+                        , sign_data = False
+                        , encrypt_communication = False
+                        , encrypt_storage = False
+                        , split_key = False
+                        , authentication = True
+                        , group_key = False }
+                    , NotationDataPacket
+                        { human_readable = True
+                        , notation_name = "usage@"
+                        , notation_value = tag
+                        }
+                    -- implicitly added:
+                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
+                    ]
+        subgrip = fingerprint (head parsedkey)
+
+    back_sig <- pgpSign (Message parsedkey)
+                        (SubkeySignature wk
+                                         (head parsedkey)
+                                         (sigpackets 0x19
+                                                     hashed0
+                                                     [IssuerPacket subgrip]))
+                        (if key_algorithm (head parsedkey)==ECDSA
+                            then SHA256
+                            else SHA1)
+                        subgrip
+    let iss = IssuerPacket (fingerprint wk)
+        cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
+        unhashed0 = maybe [iss] cons_iss back_sig
+
+    new_sig <- pgpSign (Message [wkun])
+                       (SubkeySignature wk
+                                        (head parsedkey)
+                                        (sigpackets 0x18
+                                                   hashed0
+                                                   unhashed0))
+                      SHA1
+                      grip
+    let newSig = do
+            (k,o) <- addOrigin new_sig
+            return $ KikiSuccess ((k,o),[])
+    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
+    let sig = packet mp
+        isCreation (SignatureCreationTimePacket {}) = True
+        isCreation _ = False
+        isExpiration (SignatureExpirationTimePacket {}) = True
+        isExpiration _ = False
+        (cs,ps) = partition isCreation (hashed_subpackets sig)
+        (es,qs) = partition isExpiration ps
+        stamp = listToMaybe . sortBy (comparing Down) $
+                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
+        exp = listToMaybe $ sort $
+                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
+        expires = liftA2 (+) stamp exp
+    timestamp <- now
+    if fmap ( (< timestamp) . fromIntegral) expires == Just True then do
+        return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
+    else do
+        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
+                        $ maybeToList $ do
+                            e <- expires
+                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
+            notation = NotationDataPacket
+                        { notation_name = "usage@"
+                        , notation_value = tag
+                        , human_readable = True }
+            sig' = sig { hashed_subpackets = times ++ [notation] ++ qs }
+        new_sig <- pgpSign (Message [wkun])
+                           (SubkeySignature wk
+                                            (packet subkey_p)
+                                            [sig'] )
+                           SHA1
+                           (fingerprint wk)
+        fmap (KikiSuccess . (,[])) $ addOrigin new_sig
+
+
 
 data OriginFlags = OriginFlags {
         originallyPublic :: Bool,
@@ -696,6 +1139,30 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
     mergeSubSig n sig Nothing = error $
         "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
 
+unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
+unsig fname isPublic (sig,trustmap) = 
+    [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
+  where
+    f n _ = n==fname -- && trace ("fname=n="++show n) True
+    asMapped n p = let m = mappedPacket fname p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
+
+concatSort fname getp f = concat . sortByHint fname getp . map f
+
+sortByHint fname f = sortBy (comparing gethint)
+  where
+    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
+    defnum = -1
+
+flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
+flattenAllUids fname ispub uids =
+    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
+
+flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
+flattenUid fname ispub (str,(sigs,om)) = 
+    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
+
+
  
 {-
 data Kiki a =
diff --git a/kiki.hs b/kiki.hs
index d7ea9c7..3c3fdc9 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -108,61 +108,6 @@ unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
  where p = break (==c) spec
 
 
-data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
-data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
-
-pkcs8 (RSAKey n e) = RSAKey8 n e
-
-instance ASN1Object RSAPublicKey where
-    -- PKCS #1 RSA Public Key
-    toASN1 (RSAKey (MPI n) (MPI e))
-                  = \xs -> Start Sequence
-                         : IntVal n
-                         : IntVal e
-                         : End Sequence
-                         : xs
-    fromASN1 _ =
-        Left "fromASN1: RSAPublicKey: unexpected format"
-
-instance ASN1Object PKCS8_RSAPublicKey where
-
-    -- PKCS #8 Public key data
-    toASN1 (RSAKey8 (MPI n) (MPI e))
-                  = \xs -> Start Sequence
-                         : Start Sequence
-                         : OID [1,2,840,113549,1,1,1]
-                         : End Sequence
-                         : BitString (toBitArray bs 0)
-                         : End Sequence
-                         : xs
-        where
-            pubkey = Start Sequence : IntVal n : IntVal e : End Sequence : []
-            bs = encodeASN1' DER pubkey
-
-    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
-        Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
-    fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
-        case decodeASN1' DER bs of
-            Right as -> fromASN1 as
-            Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
-      where
-        BitArray _ bs = b
-
-    fromASN1 _ =
-        Left "fromASN1: RSAPublicKey: unexpected format"
-
-data RSAPrivateKey = RSAPrivateKey
-    { rsaN :: MPI
-    , rsaE :: MPI
-    , rsaD :: MPI
-    , rsaP :: MPI
-    , rsaQ :: MPI
-    , rsaDmodP1 :: MPI
-    , rsaDmodQminus1 :: MPI
-    , rsaCoefficient :: MPI
-    }
- deriving Show
-
 {-
 RSAPrivateKey ::= SEQUENCE {
   version           Version,
@@ -240,21 +185,6 @@ decode_sshrsa bs = do
     return rsakey
         
 
-rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
-rsaKeyFromPacket p@(PublicKeyPacket {}) = do
-    n <- lookup 'n' $ key p
-    e <- lookup 'e' $ key p
-    return $ RSAKey n e
-rsaKeyFromPacket p@(SecretKeyPacket {}) = do
-    n <- lookup 'n' $ key p
-    e <- lookup 'e' $ key p
-    return $ RSAKey n e
-rsaKeyFromPacket _ = Nothing
-
-derRSA rsa = do
-    k <- rsaKeyFromPacket rsa
-    return $ encodeASN1 DER (toASN1 k [])
-
 rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey
 rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
     -- public fields...
@@ -295,20 +225,6 @@ getPackets = do
 -}
 
 
-secretToPublic pkt@(SecretKeyPacket {}) =
-    PublicKeyPacket { version = version pkt
-                    , timestamp = timestamp pkt
-                    , key_algorithm = key_algorithm pkt
-                    -- , ecc_curve = ecc_curve pkt
-                    , key = let seckey = key pkt
-                                pubs = public_key_fields (key_algorithm pkt)
-                            in filter (\(k,v) -> k `elem` pubs) seckey
-                    , is_subkey = is_subkey pkt
-                    , v3_days_of_validity = Nothing
-                    }
-secretToPublic pkt = pkt
-
-
 extractPEM typ pem = dta
  where
     dta = case ys of
@@ -446,38 +362,6 @@ accBindings bs = as
         = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
 
 
-data UserIDRecord = UserIDRecord {
-    uid_full :: String,
-    uid_realname :: T.Text,
-    uid_user :: T.Text,
-    uid_subdomain :: T.Text,
-    uid_topdomain :: T.Text
-}
- deriving Show
-
-isBracket '<' = True
-isBracket '>' = True
-isBracket _   = False
-
-parseUID str = UserIDRecord {
-                    uid_full = str,
-                    uid_realname = realname,
-                    uid_user = user,
-                    uid_subdomain = subdomain,
-                    uid_topdomain = topdomain
-                }
- where
-    text = T.pack str
-    (T.strip-> realname, T.dropAround isBracket-> email)
-                              = T.break (=='<') text
-    (user, T.drop 1-> hostname) = T.break (=='@') email
-    ( T.reverse            -> topdomain,
-      T.reverse . T.drop 1 -> subdomain)
-                              = T.break (=='.') . T.reverse $ hostname
-
-
-derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
-
 fpmatch grip key =
     (==) Nothing
          (fmap (backend (fingerprint key)) grip >>= guard . not)
@@ -882,8 +766,6 @@ is40digitHex xs = ys == xs && length ys==40
             | 'a' <= c && c <= 'f' = True
     ishex c = False
 
-torhash key = maybe "" id $ derToBase32 <$> derRSA key
-
 flattenKeys :: Bool -> KeyDB -> Message
 flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
  where
@@ -897,22 +779,12 @@ flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPubl
                   isSecret _          = False
 
 
-concatSort fname getp f = concat . sortByHint fname getp . map f
-
 flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
 flattenTop fname ispub (KeyData key sigs uids subkeys) =
     unk ispub key : 
             ( flattenAllUids fname ispub uids
              ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
 
-flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
-flattenAllUids fname ispub uids =
-    concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
-
-flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
-flattenUid fname ispub (str,(sigs,om)) = 
-    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
-
 flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
 flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
 
@@ -920,14 +792,6 @@ unk :: Bool -> MappedPacket -> MappedPacket
 unk isPublic = if isPublic then toPacket secretToPublic else id
                 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
 
-unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
-unsig fname isPublic (sig,trustmap) = 
-    [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
-  where
-    f n _ = n==fname -- && trace ("fname=n="++show n) True
-    asMapped n p = let m = mappedPacket fname p
-                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
-
 ifSecret (SecretKeyPacket {}) t f = t
 ifSecret _                    t f = f
 
@@ -940,11 +804,6 @@ showPacket p | isKey p   = (if is_subkey p
              | otherwise = showPacket0 p
 showPacket0 p = concat . take 1 $ words (show p)
 
-sortByHint fname f = sortBy (comparing gethint)
-  where
-    gethint = maybe defnum originalNum . Map.lookup fname . locations . f
-    defnum = -1
-
 keyMappedPacket (KeyData k _ _ _) = k
 
 writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO ()
@@ -1160,15 +1019,6 @@ parseSpec grip spec = (topspec,subspec)
                 "" | top=="" && is40digitHex sub -> Nothing
                 "" -> listToMaybe sub >> Just sub
 
-splitAtMinBy comp xs = minimumBy comp' xxs
- where
-    xxs = zip (inits xs) (tails xs)
-    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
-    compM (Just a) (Just b) = comp a b
-    compM Nothing  mb       = GT
-    compM _        _        = LT
-
-
 -- | systemEnv
 -- This is like System.Process.system except that it lets you set
 -- some environment variables.
@@ -1239,34 +1089,6 @@ doExport doDecrypt (db,use_db) (fname,subspec,ms,cmd) =
         writeKeyToFile False "PEM" fname pun
         return (db,use_db)
 
-findTag tag wk subkey subsigs = (xs',minsig,ys')
-         where
-            vs = map (\sig ->
-                          (sig, do
-                                sig <- Just (packet . fst $ sig)
-                                guard (isSignaturePacket sig)
-                                guard $ flip isSuffixOf
-                                             (fingerprint wk)
-                                        . maybe "%bad%" id
-                                        . signature_issuer
-                                        $ sig
-                                listToMaybe $
-                                  map (signature_time . verify (Message [wk]))
-                                      (signatures $ Message [wk,subkey,sig])))
-                     subsigs
-            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
-            xs' = map fst xs
-            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
-            minsig = do
-                (sig,ov) <- listToMaybe ys
-                ov
-                let hs = filter (\p->isNotation p && notation_name p=="usage@")
-                                (hashed_subpackets . packet . fst $ sig)
-                    ks = map notation_value hs
-                    isNotation (NotationDataPacket {}) = True
-                    isNotation _ = False
-                return (tag `elem` ks, sig)
-
 {-
 applyCurve curve x = x*x*x + x*a + b where (a,b)=(geta curve,getb curve)
 
@@ -1426,175 +1248,6 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
         $ error "Key specification is ambiguous."
     doImportG doDecrypt db m0 tag fname key
 
-doImportG doDecrypt db m0 tag fname key = do
-    let error s = do
-                        warn s
-                        exitFailure
-    let kk = head m0
-        Just (KeyData top topsigs uids subs) = Map.lookup kk db
-        subkk = keykey key
-        (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
-                                               [])
-                                 ( (False,) . addOrigin )
-                                 (Map.lookup subkk subs)
-                             where
-                                addOrigin (SubKey mp sigs) = 
-                                    let mp' = mp
-                                          { locations = Map.insert fname
-                                                             (origin (packet mp) (-1))
-                                                             (locations mp) }
-                                    in SubKey mp' sigs
-        subs' = Map.insert subkk subkey subs
-
-        istor = do
-            guard (tag == "tor")
-            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
-
-    uids' <- flip (maybe $ return uids) istor $ \idstr -> do
-                let has_torid = do
-                     -- TODO: check for omitted real name field
-                     (sigtrusts,om) <- Map.lookup idstr uids
-                     listToMaybe $ do
-                         s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
-                         signatures_over $ verify (Message [packet top]) s
-                flip (flip maybe $ const $ return uids) has_torid $ do
-                wkun <- doDecrypt (packet top)
-                flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do
-                let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
-                    uid = UserIDPacket idstr
-                    -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
-                    tor_ov = torSigOver (packet top) wkun uid keyflags
-                sig_ov <- pgpSign (Message [wkun])
-                                  tor_ov
-                                  SHA1
-                                  (fingerprint wkun)
-                flip (maybe $ warn "Failed to make signature" >> return uids)
-                     (sig_ov >>= listToMaybe . signatures_over)
-                     $ \sig -> do
-                let om = Map.singleton fname (origin sig (-1))
-                    trust = Map.empty
-                return $ Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
-                                            ,trust)],om) uids
-
-    let SubKey subkey_p subsigs = subkey
-        wk = packet top
-        (xs',minsig,ys') = findTag tag wk key subsigs
-        doInsert mbsig db = do
-            sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
-            warn $ fname ++ ": yield SignaturePacket"
-            let subs' = Map.insert subkk
-                                   (SubKey subkey_p $ xs'++[sig']++ys')
-                                   subs
-            return $ Map.insert kk (KeyData top topsigs uids' subs') db
-    when is_new (warn $ fname ++ ": yield SecretKeyPacket "++show (fmap fst minsig,fingerprint key))
-    case minsig of
-        Nothing          -> doInsert Nothing db    -- we need to create a new sig
-        Just (True,sig)  -> -- we can deduce is_new == False
-                            -- we may need to add a tor id
-                            return $ Map.insert kk (KeyData top topsigs uids' subs') db
-        Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
-
-
-makeSig doDecrypt top fname subkey_p tag mbsig = do
-    let wk = packet top
-    wkun <- doDecrypt wk
-    flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do
-    let grip = fingerprint wk
-        addOrigin new_sig = do
-            flip (maybe $ error "Failed to make signature.") 
-                 (new_sig >>= listToMaybe . signatures_over) 
-                 $ \new_sig -> do
-            let mp' = mappedPacket fname new_sig
-            return (mp', Map.empty)
-        parsedkey = [packet $ subkey_p]
-        hashed0 =
-                    [ KeyFlagsPacket
-                        { certify_keys = False
-                        , sign_data = False
-                        , encrypt_communication = False
-                        , encrypt_storage = False
-                        , split_key = False
-                        , authentication = True
-                        , group_key = False }
-                    , NotationDataPacket
-                        { human_readable = True
-                        , notation_name = "usage@"
-                        , notation_value = tag
-                        }
-                    -- implicitly added:
-                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
-                    ]
-        subgrip = fingerprint (head parsedkey)
-
-    back_sig <- pgpSign (Message parsedkey)
-                        (SubkeySignature wk
-                                         (head parsedkey)
-                                         (sigpackets 0x19
-                                                     hashed0
-                                                     [IssuerPacket subgrip]))
-                        (if key_algorithm (head parsedkey)==ECDSA
-                            then SHA256
-                            else SHA1)
-                        subgrip
-    let iss = IssuerPacket (fingerprint wk)
-        cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
-        unhashed0 = maybe [iss] cons_iss back_sig
-
-    new_sig <- pgpSign (Message [wkun])
-                       (SubkeySignature wk
-                                        (head parsedkey)
-                                        (sigpackets 0x18
-                                                   hashed0
-                                                   unhashed0))
-                      SHA1
-                      grip
-    let newSig = addOrigin new_sig
-    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
-    let sig = packet mp
-        isCreation (SignatureCreationTimePacket {}) = True
-        isCreation _ = False
-        isExpiration (SignatureExpirationTimePacket {}) = True
-        isExpiration _ = False
-        (cs,ps) = partition isCreation (hashed_subpackets sig)
-        (es,qs) = partition isExpiration ps
-        stamp = listToMaybe . sortBy (comparing Down) $
-                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
-        exp = listToMaybe $ sort $
-                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
-        expires = liftA2 (+) stamp exp
-    timestamp <- now
-    if fmap ( (< timestamp) . fromIntegral) expires == Just True then do
-        warn $ "Unable to update expired signature"
-        return (mp,trustmap)
-    else do
-        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
-                        $ maybeToList $ do
-                            e <- expires
-                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
-            notation = NotationDataPacket
-                        { notation_name = "usage@"
-                        , notation_value = tag
-                        , human_readable = True }
-            sig' = sig { hashed_subpackets = times ++ [notation] ++ qs }
-        new_sig <- pgpSign (Message [wkun])
-                           (SubkeySignature wk
-                                            (packet subkey_p)
-                                            [sig'] )
-                           SHA1
-                           (fingerprint wk)
-        addOrigin new_sig
-
-signature_time ov = case if null cs then ds else cs of
-                                [] -> minBound
-                                xs -> last (sort xs)
-          where
-            ps = signatures_over ov
-            ss = filter isSignaturePacket ps
-            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
-            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
-            creationTime (SignatureCreationTimePacket t) = [t]
-            creationTime _                               = []
-
 -- We return into IO in case we want to make a signature here.
 setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
 setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
@@ -2358,52 +2011,3 @@ makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig
     sig = fst $ torsig g topkey wkun uid timestamp keyflags
 -}
 
--- torsig g topk wkun uid timestamp extras = todo
-torSigOver topk wkun uid extras
-    = CertificationSignature (secretToPublic topk)
-                             uid
-                             (sigpackets 0x13
-                                         subpackets
-                                         subpackets_unh)
-   where
-    subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
-                 tsign
-                 ++ extras
-    subpackets_unh = [IssuerPacket (fingerprint wkun)]
-    tsign = if keykey wkun == keykey topk
-             then [] -- tsign doesnt make sense for self-signatures
-             else [ TrustSignaturePacket 1 120
-                  , RegularExpressionPacket regex]
-    -- <[^>]+[@.]asdf\.nowhere>$
-    regex = "<[^>]+[@.]"++hostname++">$"
-    -- regex = username ++ "@" ++ hostname
-    -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
-    hostname = subdomain' pu ++ "\\." ++ topdomain' pu
-    pu = parseUID uidstr where UserIDPacket uidstr = uid
-    subdomain' = escape . T.unpack . uid_subdomain
-    topdomain' = escape . T.unpack . uid_topdomain
-    escape s = concatMap echar s
-      where
-        echar '|' = "\\|"
-        echar '*' = "\\*"
-        echar '+' = "\\+"
-        echar '?' = "\\?"
-        echar '.' = "\\."
-        echar '^' = "\\^"
-        echar '$' = "\\$"
-        echar '\\' = "\\\\"
-        echar '[' = "\\["
-        echar ']' = "\\]"
-        echar c = [c]
-
-sigpackets typ hashed unhashed = return $
-    signaturePacket
-        4 -- version
-        typ -- 0x18 subkey binding sig, or 0x19 back-signature
-        RSA
-        SHA1
-        hashed
-        unhashed
-        0 -- Word16 -- Left 16 bits of the signed hash value
-        [] -- [MPI]
-