From 43478c909db3efb9ea1f7ab1942c92c46026f869 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 13 Dec 2013 01:48:50 -0500 Subject: Updated to patched OpenPGP with ecc_curve fields --- kiki.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/kiki.hs b/kiki.hs index 22000d0..789bc07 100644 --- a/kiki.hs +++ b/kiki.hs @@ -23,7 +23,7 @@ import Control.Monad import qualified Text.Show.Pretty as PP import Text.PrettyPrint as PP hiding ((<>)) import Data.List -import Data.OpenPGP.CryptoAPI +import Data.OpenPGP.CryptoAPI (verify,fingerprint,sign,decryptSecretKey) import Data.Ord import Data.Maybe import Data.Bits @@ -236,10 +236,13 @@ getPackets = do Left (_,_,_) -> return [] +instance Default S.ByteString where def = S.empty + secretToPublic pkt@(SecretKeyPacket {}) = PublicKeyPacket { version = version pkt , timestamp = timestamp pkt , key_algorithm = key_algorithm pkt + , ecc_curve = def , key = let seckey = key pkt pubs = public_key_fields (key_algorithm pkt) in filter (\(k,v) -> k `elem` pubs) seckey @@ -844,6 +847,7 @@ readKeyFromFile False "PEM" fname = do { version = 4 , timestamp = toEnum (fromEnum timestamp) , key_algorithm = RSA + , ecc_curve = def , key = [ -- public fields... ('n',rsaN rsa) ,('e',rsaE rsa) -- cgit v1.2.3 From 6dbfdc5dd5dde98858a46afcc96e5692b21c2cc2 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 13 Dec 2013 01:52:42 -0500 Subject: Oops --- kiki.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kiki.hs b/kiki.hs index 789bc07..d468774 100644 --- a/kiki.hs +++ b/kiki.hs @@ -242,7 +242,7 @@ secretToPublic pkt@(SecretKeyPacket {}) = PublicKeyPacket { version = version pkt , timestamp = timestamp pkt , key_algorithm = key_algorithm pkt - , ecc_curve = def + , 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 -- cgit v1.2.3 From 8c56ffda40444e777d5442135dd75b6858ff0843 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 13 Dec 2013 04:02:20 -0500 Subject: OpenPGP module to insulate the code from Data.OpenPGP.CryptoAPI --- OpenPGP.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 OpenPGP.hs diff --git a/OpenPGP.hs b/OpenPGP.hs new file mode 100644 index 0000000..7fef0b5 --- /dev/null +++ b/OpenPGP.hs @@ -0,0 +1,42 @@ +module OpenPGP + ( verify + , fingerprint + , pgpSign + , decryptSecretKey + ) where + +import Data.OpenPGP as OpenPGP +import Data.OpenPGP.CryptoAPI (verify,fingerprint,sign,decryptSecretKey) +import Data.Time.Clock.POSIX +import Control.Applicative ( (<$>) ) +import Crypto.Random (newGenIO,SystemRandom) + +now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime + +stampit timestamp sig = sig { hashed_subpackets = hashed' } + where + hashed_stamps = filter isStamp (hashed_subpackets sig) + unhashed_stamps = filter isStamp (unhashed_subpackets sig) + hashed' = case hashed_stamps ++ unhashed_stamps of + [] -> SignatureCreationTimePacket (fromIntegral timestamp) + : hashed_subpackets sig + _ -> hashed_subpackets sig + isStamp (SignatureCreationTimePacket {}) = True + isStamp _ = False + +-- | Make a signature +-- +-- In order to set more options on a signature, pass in a signature packet. +pgpSign :: + OpenPGP.Message -- ^ SecretKeys, one of which will be used + -> OpenPGP.SignatureOver -- ^ Data to sign, and optional signature packet + -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use in signature + -> String -- ^ KeyID of key to choose + -> IO OpenPGP.SignatureOver +pgpSign seckeys dta hash_algo keyid = do + timestamp <- now + g <- newGenIO :: IO SystemRandom + let sigs = map (stampit timestamp) $ signatures_over dta + dta' = dta { signatures_over = sigs } + let (r,g') = sign seckeys dta' hash_algo keyid timestamp g + return r -- cgit v1.2.3 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 From de42e2f46ec64f84317ef3696bd304a3836a38f9 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 13 Dec 2013 04:27:54 -0500 Subject: Changed pgpSign to return a Maybe in case a signature cannot be made. --- OpenPGP.hs | 8 +++++--- kiki.hs | 10 ++++++---- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/OpenPGP.hs b/OpenPGP.hs index 7fef0b5..75054b3 100644 --- a/OpenPGP.hs +++ b/OpenPGP.hs @@ -10,6 +10,7 @@ import Data.OpenPGP.CryptoAPI (verify,fingerprint,sign,decryptSecretKey) import Data.Time.Clock.POSIX import Control.Applicative ( (<$>) ) import Crypto.Random (newGenIO,SystemRandom) +import ControlMaybe now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime @@ -32,11 +33,12 @@ pgpSign :: -> OpenPGP.SignatureOver -- ^ Data to sign, and optional signature packet -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use in signature -> String -- ^ KeyID of key to choose - -> IO OpenPGP.SignatureOver -pgpSign seckeys dta hash_algo keyid = do + -> IO (Maybe OpenPGP.SignatureOver) +pgpSign seckeys dta hash_algo keyid = + handleIO_ (return Nothing) $ do timestamp <- now g <- newGenIO :: IO SystemRandom let sigs = map (stampit timestamp) $ signatures_over dta dta' = dta { signatures_over = sigs } let (r,g') = sign seckeys dta' hash_algo keyid timestamp g - return r + return (Just r) diff --git a/kiki.hs b/kiki.hs index bc8b61b..7c77f64 100644 --- a/kiki.hs +++ b/kiki.hs @@ -1417,7 +1417,7 @@ doImport doDecrypt db (fname,subspec,ms,_) = do SHA1 (fingerprint wkun) flip (maybe $ warn "Failed to make signature" >> return uids) - (listToMaybe $ signatures_over sig_ov) + (sig_ov >>= listToMaybe . signatures_over) $ \sig -> do let om = Map.singleton fname (origin sig (-1)) trust = Map.empty @@ -1449,7 +1449,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do let grip = fingerprint wk addOrigin new_sig = do flip (maybe $ error "Failed to make signature.") - (listToMaybe $ signatures_over new_sig) + (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1))) return (mp', Map.empty) @@ -1481,8 +1481,9 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do [IssuerPacket subgrip])) SHA1 subgrip - let unhashed0 = ( IssuerPacket (fingerprint wk) - : map EmbeddedSignaturePacket (signatures_over back_sig)) + 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 @@ -1927,6 +1928,7 @@ main = do . keykey)) vs additional new_sig = do + new_sig <- maybeToList new_sig guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs) , " for mainkey = "++fingerprint mainpubkey] ) -} -- cgit v1.2.3 From 782519d3d132add4356699eb1429fd9d06969b08 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 18 Dec 2013 03:38:09 -0500 Subject: No private key data on command line. Conflicts: kiki.hs --- kiki.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/kiki.hs b/kiki.hs index 7c77f64..196d080 100644 --- a/kiki.hs +++ b/kiki.hs @@ -1636,9 +1636,13 @@ main = do , ("--show-wk",0) , ("--show-all",0) , ("--show-pem",1) + , ("--show-wip",1) , ("--help",0) ] argspec = map fst sargspec ++ ["--keyrings","--keypairs"] + -- "--bitcoin-keypairs" + -- Disabled. We shouldn't accept private key + -- data on the command line. args' = if map (take 1) (take 1 vargs) == ["-"] then vargs else "--keyrings":vargs -- cgit v1.2.3