1 files changed, 45 insertions, 26 deletions

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