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

1 files changed, 471 insertions, 4 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 =