Adapted to IO-based inteface pgpSign to reduce dependency on

random number generator interface.

1 files 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 <root@" ++ take 16 (torhash torkey) ++ ".onion>"
     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