diff options
-rw-r--r-- | OpenPGP.hs | 8 | ||||
-rw-r--r-- | kiki.hs | 10 |
2 files changed, 11 insertions, 7 deletions
@@ -10,6 +10,7 @@ import Data.OpenPGP.CryptoAPI (verify,fingerprint,sign,decryptSecretKey) | |||
10 | import Data.Time.Clock.POSIX | 10 | import Data.Time.Clock.POSIX |
11 | import Control.Applicative ( (<$>) ) | 11 | import Control.Applicative ( (<$>) ) |
12 | import Crypto.Random (newGenIO,SystemRandom) | 12 | import Crypto.Random (newGenIO,SystemRandom) |
13 | import ControlMaybe | ||
13 | 14 | ||
14 | now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime | 15 | now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime |
15 | 16 | ||
@@ -32,11 +33,12 @@ pgpSign :: | |||
32 | -> OpenPGP.SignatureOver -- ^ Data to sign, and optional signature packet | 33 | -> OpenPGP.SignatureOver -- ^ Data to sign, and optional signature packet |
33 | -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use in signature | 34 | -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use in signature |
34 | -> String -- ^ KeyID of key to choose | 35 | -> String -- ^ KeyID of key to choose |
35 | -> IO OpenPGP.SignatureOver | 36 | -> IO (Maybe OpenPGP.SignatureOver) |
36 | pgpSign seckeys dta hash_algo keyid = do | 37 | pgpSign seckeys dta hash_algo keyid = |
38 | handleIO_ (return Nothing) $ do | ||
37 | timestamp <- now | 39 | timestamp <- now |
38 | g <- newGenIO :: IO SystemRandom | 40 | g <- newGenIO :: IO SystemRandom |
39 | let sigs = map (stampit timestamp) $ signatures_over dta | 41 | let sigs = map (stampit timestamp) $ signatures_over dta |
40 | dta' = dta { signatures_over = sigs } | 42 | dta' = dta { signatures_over = sigs } |
41 | let (r,g') = sign seckeys dta' hash_algo keyid timestamp g | 43 | let (r,g') = sign seckeys dta' hash_algo keyid timestamp g |
42 | return r | 44 | return (Just r) |
@@ -1674,7 +1674,7 @@ doImportG doDecrypt db m0 tag fname key = do | |||
1674 | SHA1 | 1674 | SHA1 |
1675 | (fingerprint wkun) | 1675 | (fingerprint wkun) |
1676 | flip (maybe $ warn "Failed to make signature" >> return uids) | 1676 | flip (maybe $ warn "Failed to make signature" >> return uids) |
1677 | (listToMaybe $ signatures_over sig_ov) | 1677 | (sig_ov >>= listToMaybe . signatures_over) |
1678 | $ \sig -> do | 1678 | $ \sig -> do |
1679 | let om = Map.singleton fname (origin sig (-1)) | 1679 | let om = Map.singleton fname (origin sig (-1)) |
1680 | trust = Map.empty | 1680 | trust = Map.empty |
@@ -1706,7 +1706,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do | |||
1706 | let grip = fingerprint wk | 1706 | let grip = fingerprint wk |
1707 | addOrigin new_sig = do | 1707 | addOrigin new_sig = do |
1708 | flip (maybe $ error "Failed to make signature.") | 1708 | flip (maybe $ error "Failed to make signature.") |
1709 | (listToMaybe $ signatures_over new_sig) | 1709 | (new_sig >>= listToMaybe . signatures_over) |
1710 | $ \new_sig -> do | 1710 | $ \new_sig -> do |
1711 | let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1))) | 1711 | let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1))) |
1712 | return (mp', Map.empty) | 1712 | return (mp', Map.empty) |
@@ -1738,8 +1738,9 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do | |||
1738 | [IssuerPacket subgrip])) | 1738 | [IssuerPacket subgrip])) |
1739 | SHA1 | 1739 | SHA1 |
1740 | subgrip | 1740 | subgrip |
1741 | let unhashed0 = ( IssuerPacket (fingerprint wk) | 1741 | let iss = IssuerPacket (fingerprint wk) |
1742 | : map EmbeddedSignaturePacket (signatures_over back_sig)) | 1742 | cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) |
1743 | unhashed0 = maybe [iss] cons_iss back_sig | ||
1743 | 1744 | ||
1744 | new_sig <- pgpSign (Message [wkun]) | 1745 | new_sig <- pgpSign (Message [wkun]) |
1745 | (SubkeySignature wk | 1746 | (SubkeySignature wk |
@@ -2212,6 +2213,7 @@ main = do | |||
2212 | . keykey)) | 2213 | . keykey)) |
2213 | vs | 2214 | vs |
2214 | additional new_sig = do | 2215 | additional new_sig = do |
2216 | new_sig <- maybeToList new_sig | ||
2215 | guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs) | 2217 | guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs) |
2216 | , " for mainkey = "++fingerprint mainpubkey] ) | 2218 | , " for mainkey = "++fingerprint mainpubkey] ) |
2217 | -} | 2219 | -} |