From 89c2b6b175ecf805fdd9e823726b8eec4774c78b Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 13 Dec 2013 04:03:01 -0500 Subject: Adapted to IO-based inteface pgpSign to reduce dependency on random number generator interface. --- kiki.hs | 182 ++++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 97 insertions(+), 85 deletions(-) diff --git a/kiki.hs b/kiki.hs index d468774..bc8b61b 100644 --- a/kiki.hs +++ b/kiki.hs @@ -23,7 +23,8 @@ import Control.Monad import qualified Text.Show.Pretty as PP import Text.PrettyPrint as PP hiding ((<>)) import Data.List -import Data.OpenPGP.CryptoAPI (verify,fingerprint,sign,decryptSecretKey) +-- import Data.OpenPGP.CryptoAPI (verify,fingerprint,sign,decryptSecretKey) +import OpenPGP import Data.Ord import Data.Maybe import Data.Bits @@ -34,7 +35,7 @@ import qualified Codec.Binary.Base64 as Base64 import qualified Crypto.Hash.SHA1 as SHA1 import Data.Char (toLower) import qualified Crypto.PubKey.RSA as RSA -import Crypto.Random (newGenIO,SystemRandom) +-- import Crypto.Random (newGenIO,SystemRandom) import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding @@ -55,6 +56,7 @@ import ControlMaybe import Data.Char import Control.Arrow (first,second) import Data.Traversable hiding (mapM,forM) +import qualified Data.Traversable as Traversable (mapM,forM) import System.Console.CmdArgs -- import System.Posix.Time import Data.Time.Clock.POSIX @@ -1406,11 +1408,14 @@ doImport doDecrypt db (fname,subspec,ms,_) = do flip (flip maybe $ const $ return uids) has_torid $ do wkun <- doDecrypt (packet top) flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do - g <- newGenIO :: IO SystemRandom - timestamp <- now let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) uid = UserIDPacket idstr - sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags + -- 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) (listToMaybe $ signatures_over sig_ov) $ \sig -> do @@ -1441,8 +1446,6 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do let wk = packet top wkun <- doDecrypt wk flip (maybe $ error "Bad passphrase?") wkun $ \wkun -> do - g <- newGenIO :: IO SystemRandom - timestamp <- now let grip = fingerprint wk addOrigin new_sig = do flip (maybe $ error "Failed to make signature.") @@ -1450,21 +1453,8 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do $ \new_sig -> do let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1))) return (mp', Map.empty) - newSig = do - let parsedkey = [packet $ subkey_p] - new_sig = fst $ sign (Message [wkun]) - (SubkeySignature wk - (head parsedkey) - (sigpackets 0x18 - hashed0 - ( IssuerPacket (fingerprint wk) - : map EmbeddedSignaturePacket (signatures_over back_sig)))) - SHA1 - grip - timestamp - (g::SystemRandom) - - hashed0 = + parsedkey = [packet $ subkey_p] + hashed0 = [ KeyFlagsPacket { certify_keys = False , sign_data = False @@ -1478,22 +1468,31 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do , notation_name = "usage@" , notation_value = tag } - , SignatureCreationTimePacket (fromIntegral timestamp) + -- implicitly added: + -- , SignatureCreationTimePacket (fromIntegral timestamp) ] - - subgrip = fingerprint (head parsedkey) - - back_sig = fst $ sign (Message parsedkey) - (SubkeySignature wk - (head parsedkey) - (sigpackets 0x19 - hashed0 - [IssuerPacket subgrip])) - SHA1 - subgrip - timestamp - (g::SystemRandom) - addOrigin new_sig + subgrip = fingerprint (head parsedkey) + + back_sig <- pgpSign (Message parsedkey) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x19 + hashed0 + [IssuerPacket subgrip])) + SHA1 + subgrip + let unhashed0 = ( IssuerPacket (fingerprint wk) + : map EmbeddedSignaturePacket (signatures_over 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 @@ -1507,19 +1506,12 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do 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 new_sig = fst $ sign (Message [wkun]) - (SubkeySignature wk - (packet subkey_p) - [sig'] ) - SHA1 - (fingerprint wk) - timestamp - (g::SystemRandom) - times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) + let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $ maybeToList $ do e <- expires return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) @@ -1528,6 +1520,12 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do , 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 @@ -1765,12 +1763,13 @@ main = do return $ undata (snd elm) undata (KeyData p _ _ _) = packet p - g <- newGenIO - stamp <- now + -- g <- newGenIO + -- stamp <- now wkun <- flip (maybe $ return Nothing) wk $ \wk -> do wkun <- decrypt wk maybe (error $ "Bad passphrase?") (return . Just) wkun - return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db + -- return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db + Traversable.mapM (signTorIds wkun keys) use_db ret_db <- return $ fmap (const use_db) ret_db flip (maybe $ return ()) ret_db . const $ do @@ -1854,28 +1853,25 @@ main = do where w0:ws = pub - signTorIds timestamp selfkey keys - g kd@(KeyData k ksigs umap submap) = (g', KeyData k ksigs umap' submap) + signTorIds selfkey keys kd@(KeyData k ksigs umap submap) = do + umap' <- Traversable.mapM signIfTor (Map.mapWithKey (,) umap) + return (KeyData k ksigs umap' submap) :: IO KeyData where - _ = g :: SystemRandom mkey = packet k - (g',umap') = Map.mapAccumWithKey signIfTor g umap - signIfTor g str ps = if isTorID str then {- trace (unlines - [ "Found tor id: " - ++show (str,fmap fingerprint selfkey) - , "additional = " ++ intercalate "," (map showPacket additional) - ]) -} - (g',ps') - else (g,ps) - where - uidxs0 = map packet $ flattenUid "" True (str,ps) - om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str - tmap = Map.empty - ps' = ( map ( (,tmap) . flip MappedPacket om) additional - ++ fst ps - , Map.union om (snd ps) ) - - (uidxs, additional, xs'',g') = signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0 + signIfTor (str,ps) = + if isTorID str + then do + let uidxs0 = map packet $ flattenUid "" True (str,ps) + -- addition<- signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0 + additional <- signSelfAuthTorKeys' selfkey keys grip mkey uidxs0 + let ps' = ( map ( (,tmap) . flip MappedPacket om) additional + ++ fst ps + , Map.union om (snd ps) ) + om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str + tmap = Map.empty + return ps' + else return ps + torbindings = getTorKeys (map packet $ flattenTop "" True kd) isTorID str = and [ uid_topdomain parsed == "onion" , uid_realname parsed `elem` ["","Anonymous"] @@ -1888,6 +1884,7 @@ main = do subdom = Char8.unpack subdom0 len = T.length (uid_subdomain parsed) + {- signSelfAuthTorKeys selfkey g sec grip timestamp xs = ys where keys = filter isKey sec @@ -1895,8 +1892,16 @@ main = do uidxs0 = map snd xs (uidxs, additional, xs'',g') = signSelfAuthTorKeys' selfkey g keys grip timestamp mainpubkey uidxs0 ys = uidxs++ additional++xs'' + -} - signSelfAuthTorKeys' selfkey g keys grip timestamp mainpubkey (uid:xs') = (uid:sigs,additional,xs'',g') + signSelfAuthTorKeys' selfkey keys grip mainpubkey (uid:xs') = do + new_sig <- let wkun = fromJust selfkey + tor_ov = torSigOver mainpubkey wkun uid flgs + in pgpSign (Message [wkun]) + tor_ov + SHA1 + (fingerprint wkun) + return (additional new_sig) -- (uid:sigs,additional,xs'',g') where (sigs, xs'') = span isSignaturePacket xs' overs sig = signatures $ Message (keys++[mainpubkey,uid,sig]) @@ -1921,7 +1926,7 @@ main = do . (== keykey whosign) . keykey)) vs - additional = do + additional new_sig = do guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs) , " for mainkey = "++fingerprint mainpubkey] ) -} @@ -1952,7 +1957,14 @@ main = do flgs = if keykey mainpubkey == keykey (fromJust selfkey) then keyFlags0 mainpubkey (map (\(x,_,_)->x) selfsigs) else [] - (new_sig,g') = torsig g mainpubkey (fromJust selfkey) uid timestamp flgs + -- (new_sig,g') = todo g mainpubkey (fromJust selfkey) uid timestamp flgs + {- + new_sig <- let wkun = fromJust selfkey + in pgpSign (Message [wkun]) + tor_ov + SHA1 + (fingerprint wkun) + -} -- ys = uid:sigs++ additional++xs'' @@ -2204,6 +2216,7 @@ isSameKey a b = sort (key apub) == sort (key bpub) apub = secretToPublic a bpub = secretToPublic b +{- existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_file grip = do -- putStrLn "Key already present." let pk:trail = pks @@ -2353,6 +2366,7 @@ newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do -} return () +-} @@ -2447,27 +2461,25 @@ seek_key (KeyUidMatch pat) ps = if null bs groupTops ps = groupBy (\_ b -> not (isTopKey b)) ps +{- makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig where torhash sub = maybe "" id $ derToBase32 <$> derRSA sub s = "Anonymous " uid = UserIDPacket s sig = fst $ torsig g topkey wkun uid timestamp keyflags +-} -torsig g topk wkun uid timestamp extras - = sign (Message [wkun]) - (CertificationSignature (secretToPublic topk) - uid - (sigpackets 0x13 - subpackets - subpackets_unh)) - SHA1 - (fingerprint wkun) {- (fromJust wkgrip) -} - timestamp - g +-- torsig g topk wkun uid timestamp extras = todo +torSigOver topk wkun uid extras + = CertificationSignature (secretToPublic topk) + uid + (sigpackets 0x13 + subpackets + subpackets_unh) where - subpackets = [ SignatureCreationTimePacket (fromIntegral timestamp) ] - ++ tsign + subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] + tsign ++ extras subpackets_unh = [IssuerPacket (fingerprint wkun)] tsign = if keykey wkun == keykey topk -- cgit v1.2.3