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 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- kiki.hs | 396 --------------------------------------------------- 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 " + + 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 " - - 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] - -- cgit v1.2.3