From db0e17c179453e22cbadfb8b514d2e7efede170d Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 14 Apr 2014 21:35:25 -0400 Subject: moved more code from kiki.hs to KeyRing.hs for buildKeyDB --- KeyRing.hs | 475 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 471 insertions(+), 4 deletions(-) (limited to 'KeyRing.hs') 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 " + + 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 = -- cgit v1.2.3