moved more code from kiki.hs to KeyRing.hs for buildKeyDB

1 files changed, 0 insertions, 396 deletions

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]
-