diff options
| -rw-r--r-- | Crypto.hs | 72 | ||||
| -rw-r--r-- | Gpg.hs | 83 | ||||
| -rw-r--r-- | Role/Developer.hs | 1 | ||||
| -rw-r--r-- | Role/User.hs | 1 | ||||
| -rw-r--r-- | debug-me.cabal | 1 |
5 files changed, 86 insertions, 72 deletions
@@ -11,12 +11,6 @@ import Crypto.Error import Crypto.Random.Entropy import Data.ByteArray (convert) import qualified Data.ByteString as B -import System.IO -import System.Process -import System.Exit -import Data.List -import Control.Exception -import System.Directory dummySignature :: Signature dummySignature = OtherSignature (Val mempty) @@ -86,69 +80,3 @@ genMySessionKey = do rand32 <- getEntropy 32 :: IO B.ByteString sk <- throwCryptoErrorIO $ Ed25519.secretKey rand32 return $ MySessionKey sk (Ed25519.toPublic sk) - -newtype GpgSign = GpgSign Bool - -myPublicKey :: MySessionKey -> GpgSign -> IO (PerhapsSigned PublicKey) -myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do - let pk = PublicKey (Val $ convert epk) - if gpgsign - then gpgSign pk - else return (UnSigned pk) - -gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey) -gpgSign pk = do - putStrLn "Using gpg to sign the debug-me session key." - -- Write it to a temp file because gpg sometimes is unhappy - -- about password prompting when stdin is not connected to - -- the console. - tmpdir <- getTemporaryDirectory - (tmpfile, tmph) <- openTempFile tmpdir "debug-me.tmp" - B.hPut tmph $ val $ hashValue $ hash pk - hClose tmph - (_, Just hout, _, pid) <- createProcess $ - (proc "gpg" ["--output", "-", "--clearsign", "-a", tmpfile]) - { std_out = CreatePipe - } - hSetBinaryMode hout True - sig <- GpgSig . Val <$> B.hGetContents hout - st <- waitForProcess pid - _ <- try (removeFile tmpfile) :: IO (Either IOException ()) - case st of - ExitSuccess -> return $ GpgSigned pk sig - ExitFailure _ -> error "gpg failed" - --- | Verify the gpg signature. The key will be retrieved from a keyserver --- if possible. Gpg outputs to stderr information about who signed the --- data, so that will be visible to the user when eg, prompting --- them if they want to accept a connection from that person. -gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO Bool -gpgVerify _ (UnSigned _) = return False -gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do - -- This relies on gpgSign using --clearsign, so on successful - -- verification, the JSON encoded PublicKey is output to gpg's - -- stdout. - (Just hin, Just hout, _, pid) <- createProcess $ - (proc "gpg" (extraopts ++ ["--verify", "--output", "-"])) - { std_in = CreatePipe - , std_out = CreatePipe - } - B.hPut hin sig - hClose hin - hSetBinaryMode hout True - signeddata <- B.hGetContents hout - st <- waitForProcess pid - return $ case st of - ExitFailure _ -> False - ExitSuccess -> val (hashValue (hash pk)) == signeddata - where - extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts - then gpgopts - else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts - --- | Default keyservers to use. -defaultKeyServers :: [String] -defaultKeyServers = - [ "pool.sks-keyservers.net" - , "pgpkeys.mit.edu" - ] @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-} + +module Gpg where + +import Val +import Hash +import Types +import Crypto + +import Data.ByteArray (convert) +import qualified Data.ByteString as B +import System.IO +import System.Process +import System.Exit +import Data.List +import Control.Exception +import System.Directory + +newtype GpgSign = GpgSign Bool + +myPublicKey :: MySessionKey -> GpgSign -> IO (PerhapsSigned PublicKey) +myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do + let pk = PublicKey (Val $ convert epk) + if gpgsign + then gpgSign pk + else return (UnSigned pk) + +gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey) +gpgSign pk = do + putStrLn "Using gpg to sign the debug-me session key." + -- Write it to a temp file because gpg sometimes is unhappy + -- about password prompting when stdin is not connected to + -- the console. + tmpdir <- getTemporaryDirectory + (tmpfile, tmph) <- openTempFile tmpdir "debug-me.tmp" + B.hPut tmph $ val $ hashValue $ hash pk + hClose tmph + (_, Just hout, _, pid) <- createProcess $ + (proc "gpg" ["--output", "-", "--clearsign", "-a", tmpfile]) + { std_out = CreatePipe + } + hSetBinaryMode hout True + sig <- GpgSig . Val <$> B.hGetContents hout + st <- waitForProcess pid + _ <- try (removeFile tmpfile) :: IO (Either IOException ()) + case st of + ExitSuccess -> return $ GpgSigned pk sig + ExitFailure _ -> error "gpg failed" + +-- | Verify the gpg signature. The key will be retrieved from a keyserver +-- if possible. Gpg outputs to stderr information about who signed the +-- data, so that will be visible to the user when eg, prompting +-- them if they want to accept a connection from that person. +gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO Bool +gpgVerify _ (UnSigned _) = return False +gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do + -- This relies on gpgSign using --clearsign, so on successful + -- verification, the JSON encoded PublicKey is output to gpg's + -- stdout. + (Just hin, Just hout, _, pid) <- createProcess $ + (proc "gpg" (extraopts ++ ["--verify", "--output", "-"])) + { std_in = CreatePipe + , std_out = CreatePipe + } + B.hPut hin sig + hClose hin + hSetBinaryMode hout True + signeddata <- B.hGetContents hout + st <- waitForProcess pid + return $ case st of + ExitFailure _ -> False + ExitSuccess -> val (hashValue (hash pk)) == signeddata + where + extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts + then gpgopts + else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts + +-- | Default keyservers to use. +defaultKeyServers :: [String] +defaultKeyServers = + [ "pool.sks-keyservers.net" + , "pgpkeys.mit.edu" + ] diff --git a/Role/Developer.hs b/Role/Developer.hs index 9450e57..ca3baea 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -14,6 +14,7 @@ import Types import Hash import Log import Crypto +import Gpg import CmdLine import WebSockets import SessionID diff --git a/Role/User.hs b/Role/User.hs index d1e4975..bbf563c 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -8,6 +8,7 @@ import Memory import Log import Session import Crypto +import Gpg import CmdLine import WebSockets import SessionID diff --git a/debug-me.cabal b/debug-me.cabal index 7faf2ae..5ffb183 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -81,6 +81,7 @@ Executable debug-me Crypto DotDir Graphviz + Gpg Hash JSON Log |