remove Keys type from Network.ACME.Encoding

3 files changed, 58 insertions, 54 deletions

diff --git a/acme-certify.hs b/acme-certify.hs
index 98f6711..352be21 100644
--- a/acme-certify.hs
+++ b/acme-certify.hs
@@ -12,22 +12,21 @@
 module Main where
 
 import           BasePrelude
-import           Network.ACME          (canProvision, certify,
-                                        ensureWritableDir, fileProvisioner,
-                                        genReq, (</>))
-import           Network.ACME.Encoding (Keys (..), readKeys)
-import           Network.ACME.Issuer   (letsEncryptX1CrossSigned)
+import           Network.ACME         (Keys (..), canProvision, certify,
+                                       ensureWritableDir, fileProvisioner,
+                                       genReq, readKeys, (</>))
+import           Network.ACME.Issuer  (letsEncryptX1CrossSigned)
 import           Network.URI
 import           OpenSSL
 import           OpenSSL.DH
 import           OpenSSL.PEM
 import           OpenSSL.RSA
-import           OpenSSL.X509          (X509)
-import           Options.Applicative   hiding (header)
-import qualified Options.Applicative   as Opt
+import           OpenSSL.X509         (X509)
+import           Options.Applicative  hiding (header)
+import qualified Options.Applicative  as Opt
 import           System.Directory
 import           System.IO
-import           Text.Domain.Validate  hiding (validate)
+import           Text.Domain.Validate hiding (validate)
 import           Text.Email.Validate
 
 stagingDirectoryUrl, liveDirectoryUrl, defaultTerms :: URI
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
index 85a27e4..2734132 100644
--- a/src/Network/ACME.hs
+++ b/src/Network/ACME.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 
@@ -9,41 +10,44 @@
 
 module Network.ACME where
 
-import           Control.Lens               hiding (each, (.=))
+import           Control.Arrow
+import           Control.Error
+import           Control.Lens                 hiding (each, (.=))
 import           Control.Monad
 import           Control.Monad.RWS.Strict
-import           Data.Aeson                 (Value)
-import           Data.Aeson.Lens            hiding (key)
-import qualified Data.Aeson.Lens            as JSON
-import           Data.ByteString            (ByteString)
-import qualified Data.ByteString.Char8      as BC
-import qualified Data.ByteString.Lazy       as LB
-import qualified Data.ByteString.Lazy.Char8 as LC
+import           Control.Monad.Trans.Resource hiding (register)
+import           Data.Aeson                   (Value)
+import           Data.Aeson.Lens              hiding (key)
+import qualified Data.Aeson.Lens              as JSON
+import           Data.ByteString              (ByteString)
+import qualified Data.ByteString.Char8        as BC
+import qualified Data.ByteString.Lazy         as LB
+import qualified Data.ByteString.Lazy.Char8   as LC
 import           Data.Coerce
-import           Data.String                (fromString)
-import qualified Data.Text                  as T
-import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)
-import           Data.Time.Clock.POSIX      (getPOSIXTime)
+import           Data.List
+import           Data.String                  (fromString)
+import qualified Data.Text                    as T
+import           Data.Text.Encoding           (decodeUtf8, encodeUtf8)
+import           Data.Time.Clock.POSIX        (getPOSIXTime)
 import           Network.ACME.Encoding
-import           Network.Wreq               (Response, checkStatus, defaults,
-                                             responseBody, responseHeader,
-                                             responseStatus, statusCode,
-                                             statusMessage)
-import qualified Network.Wreq               as W
-import qualified Network.Wreq.Session       as WS
-import           System.Directory
-import           Text.Email.Validate
-import           Text.Domain.Validate hiding (validate)
 import           Network.URI
+import           Network.Wreq                 (Response, checkStatus, defaults,
+                                               responseBody, responseHeader,
+                                               responseStatus, statusCode,
+                                               statusMessage)
+import qualified Network.Wreq                 as W
+import qualified Network.Wreq.Session         as WS
 import           OpenSSL
 import           OpenSSL.EVP.Digest
+import           OpenSSL.EVP.PKey
+import           OpenSSL.EVP.Sign             hiding (sign)
+import           OpenSSL.PEM
 import           OpenSSL.RSA
+import           OpenSSL.X509                 (X509, readDerX509)
 import           OpenSSL.X509.Request
-import           OpenSSL.X509 (readDerX509, X509)
-import Data.List
-import Control.Error
-import Control.Arrow
-import Control.Monad.Trans.Resource hiding (register)
+import           System.Directory
+import           Text.Domain.Validate         hiding (validate)
+import           Text.Email.Validate
 
 genReq :: Keys -> [DomainName] -> IO CSR
 genReq _ [] = error "genReq called with zero domains"
@@ -59,6 +63,21 @@ genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do
   where
     nidSubjectAltName = 85
 
+data Keys = Keys RSAKeyPair RSAPubKey
+readKeys :: String -> IO (Maybe Keys)
+readKeys privKeyData = do
+  keypair :: SomeKeyPair <- readPrivateKey privKeyData PwTTY
+  let (priv :: Maybe RSAKeyPair) = toKeyPair keypair
+  pub <- maybe (return Nothing) (fmap Just . rsaCopyPublic) priv
+  return $ Keys <$> priv <*> pub
+
+signPayload :: Keys -> String -> ByteString -> IO LC.ByteString
+signPayload (Keys priv pub) = signPayload' sign pub
+  where
+    sign x = do
+      Just dig <- getDigestByName "SHA256"
+      signBS dig priv x
+
 type HttpProvisioner = URI -> ByteString -> ResIO ()
 fileProvisioner :: WritableDir -> HttpProvisioner
 fileProvisioner challengeDir uri thumbtoken = do
diff --git a/src/Network/ACME/Encoding.hs b/src/Network/ACME/Encoding.hs
index dc2c963..315ff49 100644
--- a/src/Network/ACME/Encoding.hs
+++ b/src/Network/ACME/Encoding.hs
@@ -3,8 +3,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Network.ACME.Encoding (
-    Keys(..),
-    readKeys,
     thumbprint,
     JWK(..),
     toStrict,
@@ -12,7 +10,7 @@ module Network.ACME.Encoding (
     challenge,
     registration,
     authz,
-    signPayload,
+    signPayload',
     ) where
 
 import           Crypto.Number.Serialize    (i2osp)
@@ -27,29 +25,17 @@ import           Data.Digest.Pure.SHA       (bytestringDigest, sha256)
 import           Data.Maybe
 import           Data.Text.Encoding         (decodeUtf8)
 import           OpenSSL
-import           OpenSSL.EVP.Digest
-import           OpenSSL.EVP.PKey
-import           OpenSSL.EVP.Sign
-import           OpenSSL.PEM
 import           OpenSSL.RSA
 import           Text.Email.Validate
 import qualified Data.Text                  as T
 
-data Keys = Keys RSAKeyPair RSAPubKey
-readKeys :: String -> IO (Maybe Keys)
-readKeys privKeyData = do
-  keypair :: SomeKeyPair <- readPrivateKey privKeyData PwTTY
-  let (priv :: Maybe RSAKeyPair) = toKeyPair keypair
-  pub <- maybe (return Nothing) (fmap Just . rsaCopyPublic) priv
-  return $ Keys <$> priv <*> pub
-
 --------------------------------------------------------------------------------
 -- | Sign return a payload with a nonce-protected header.
-signPayload :: Keys -> String -> ByteString -> IO LC.ByteString
-signPayload (Keys priv pub) nonce_ payload = withOpenSSL $ do
+
+signPayload' :: (ByteString -> IO ByteString) -> RSAPubKey -> String -> ByteString -> IO LC.ByteString
+signPayload' sign pub nonce_ payload = withOpenSSL $ do
   let protected = b64 (header pub nonce_)
-  Just dig <- getDigestByName "SHA256"
-  sig <- b64 <$> signBS dig priv (B.concat [protected, ".", payload])
+  sig <- b64 <$> sign (B.concat [protected, ".", payload])
   return $ encode (Request (header' pub) protected payload sig)
 
 --------------------------------------------------------------------------------