Factored out Network.ACME library

3 files changed, 216 insertions, 158 deletions

diff --git a/acme-encrypt.cabal b/acme-encrypt.cabal
index 55b94ff..9d9e980 100644
--- a/acme-encrypt.cabal
+++ b/acme-encrypt.cabal
@@ -2,30 +2,32 @@ name:                acme-encrypt
 version:             0.1.0.0
 synopsis:            Get a certificate using Let's Encrypt ACME protocol
 description:         Please see README.md
-homepage:            https://github.com/noteed/acme
-author:              Vo Minh Thu
+homepage:            https://github.com/afcady/acme
+author:              Vo Minh Thu, Andrew Cady
 maintainer:          noteed@gmail.com
-copyright:           2016 Vo Minh Thu
+copyright:           2016 Vo Minh Thu, Andrew Cady
 category:            Web
 build-type:          Simple
 -- extra-source-files:
 cabal-version:       >=1.10
 
--- library
---   hs-source-dirs:      src
---   exposed-modules:     Lib
---   build-depends:       base >= 4.7 && < 5
---   default-language:    Haskell2010
+library
+  hs-source-dirs:      src
+  exposed-modules:     Network.ACME
+  build-depends:       base >= 4.7 && < 5,
+                       cryptonite, aeson, bytestring, base64-bytestring, SHA,
+                       text, HsOpenSSL, wreq, lens, lens-aeson,
+                       mtl, time
+  default-language:    Haskell2010
 
-executable acme-encrypt-exe
+executable letsencrypt
   -- hs-source-dirs:      app
   main-is:             acme.hs
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
-  build-depends:       base,
+  build-depends:       base, acme-encrypt,
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
                        text, HsOpenSSL, wreq, lens, lens-aeson,
                        optparse-applicative, directory, mtl, time
-                     -- , acme-encrypt
   default-language:    Haskell2010
 
 -- test-suite acme-encrypt-test
@@ -37,6 +39,6 @@ executable acme-encrypt-exe
 --   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
 --   default-language:    Haskell2010
 
--- source-repository head
---   type:     git
---   location: https://github.com/githubuser/acme-encrypt
+source-repository head
+  type:     git
+  location: https://github.com/afcady/acme
diff --git a/acme.hs b/acme.hs
index 5ea5eeb..8257390 100644
--- a/acme.hs
+++ b/acme.hs
@@ -49,6 +49,8 @@ import           Options.Applicative        hiding (header)
 import qualified Options.Applicative        as Opt
 import           System.Directory
 
+import Network.ACME
+
 stagingDirectoryUrl, liveDirectoryUrl :: String
 liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory"
 stagingDirectoryUrl = "https://acme-staging.api.letsencrypt.org/directory"
@@ -118,7 +120,6 @@ genReq domainKeyFile domain = withOpenSSL $ do
   signX509Req req priv (Just dig)
   writeX509ReqDER req
 
-data Keys = Keys SomeKeyPair RSAPubKey
 readKeys :: String -> IO Keys
 readKeys privKeyFile = do
   priv <- readFile privKeyFile >>= flip readPrivateKey PwTTY
@@ -288,146 +289,3 @@ post url payload = do
     noStatusCheck = defaults & checkStatus .~ Just nullChecker
     nullChecker _ _ _ = Nothing
 
---------------------------------------------------------------------------------
--- | Sign return a payload with a nonce-protected header.
-signPayload :: Keys -> String -> ByteString -> IO LC.ByteString
-signPayload (Keys priv pub) nonce_ payload = withOpenSSL $ do
-  let protected = b64 (header pub nonce_)
-  Just dig <- getDigestByName "SHA256"
-  sig <- b64 <$> signBS dig priv (B.concat [protected, ".", payload])
-  return $ encode (Request (header' pub) protected payload sig)
-
---------------------------------------------------------------------------------
--- | Base64URL encoding of Integer with padding '=' removed.
-b64i :: Integer -> ByteString
-b64i = b64 . i2osp
-
-b64 :: ByteString -> ByteString
-b64 = B.takeWhile (/= 61) . Base64.encode
-
-toStrict :: LB.ByteString -> ByteString
-toStrict = B.concat . LB.toChunks
-
-header' :: RSAKey k => k -> Header
-header' key = Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) Nothing
-
-header :: RSAKey k => k -> String -> ByteString
-header key nonce = (toStrict . encode)
-                     (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce))
-
--- | Registration payload to sign with user key.
-registration :: String -> String -> ByteString
-registration emailAddr terms = (b64 . toStrict . encode) (Reg emailAddr terms)
-
--- | Challenge request payload to sign with user key.
-authz :: String -> ByteString
-authz = b64. toStrict . encode . Authz
-
--- | Challenge response payload to sign with user key.
-challenge :: ByteString -> ByteString
-challenge = b64 . toStrict . encode . Challenge . BC.unpack
-
--- | CSR request payload to sign with user key.
-csr :: ByteString -> ByteString
-csr = b64 . toStrict . encode . CSR . b64
-
-thumbprint :: JWK -> ByteString
-thumbprint = b64 . toStrict . bytestringDigest . sha256 . encodeOrdered
-
--- | There is an `encodePretty'` in `aeson-pretty`, but do it by hand here.
-encodeOrdered :: JWK -> LB.ByteString
-encodeOrdered JWK{..} = LC.pack $
-  "{\"e\":\"" ++ hE' ++ "\",\"kty\":\"" ++ hKty ++ "\",\"n\":\"" ++ hN' ++ "\"}"
-  where
-  hE' = BC.unpack (b64i hE)
-  hN' = BC.unpack (b64i hN)
-
-
---------------------------------------------------------------------------------
-data Header = Header
-  { hAlg   :: String
-  , hJwk   :: JWK
-  , hNonce :: Maybe String
-  }
-  deriving Show
-
-data JWK = JWK
-  { hE   :: Integer
-  , hKty :: String
-  , hN   :: Integer
-  }
-  deriving Show
-
-instance ToJSON Header where
-  toJSON Header{..} = object $
-    [ "alg" .= hAlg
-    , "jwk" .= toJSON hJwk
-    ] ++ maybeToList (("nonce" .=) <$> hNonce)
-
-instance ToJSON JWK where
-  toJSON JWK{..} = object
-    [ "e" .= decodeUtf8 (b64i hE)
-    , "kty" .= hKty
-    , "n" .= decodeUtf8 (b64i hN)
-    ]
-
-data Reg = Reg
-  { rMail      :: String
-  , rAgreement :: String
-  }
-  deriving Show
-
-instance ToJSON Reg where
-  toJSON Reg{..} = object
-    [ "resource" .= ("new-reg" :: String)
-    , "contact" .= ["mailto:" ++ rMail]
-    , "agreement" .= rAgreement
-    ]
-
-data Request = Request
-  { rHeader    :: Header
-  , rProtected :: ByteString
-  , rPayload   :: ByteString
-  , rSignature :: ByteString
-  }
-  deriving Show
-
-instance ToJSON Request where
-  toJSON Request{..} = object
-    [ "header" .= toJSON rHeader
-    , "protected" .= decodeUtf8 rProtected
-    , "payload" .= decodeUtf8 rPayload
-    , "signature" .= decodeUtf8 rSignature
-    ]
-
-data Authz = Authz
-  { aDomain :: String
-  }
-
-instance ToJSON Authz where
-  toJSON Authz{..} = object
-    [ "resource" .= ("new-authz" :: String)
-    , "identifier" .= object
-      [ "type" .= ("dns" :: String)
-      , "value" .= aDomain
-      ]
-    ]
-
-data Challenge = Challenge
-  { cKeyAuth :: String
-  }
-
-instance ToJSON Challenge where
-  toJSON Challenge{..} = object
-    [ "resource" .= ("challenge" :: String)
-    , "keyAuthorization" .= cKeyAuth
-    ]
-
-data CSR = CSR ByteString
-  deriving Show
-
-instance ToJSON CSR where
-  toJSON (CSR s) = object
-    [ "resource" .= ("new-cert" :: String)
-    , "csr" .= decodeUtf8 s
-    ]
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
new file mode 100644
index 0000000..f8135e6
--- /dev/null
+++ b/src/Network/ACME.hs
@@ -0,0 +1,198 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
+module Network.ACME (
+    Keys(..),
+    thumbprint,
+    JWK(..),
+    toStrict,
+    csr,
+    challenge,
+    registration,
+    authz,
+    signPayload,
+    ) where
+
+import           Control.Lens               hiding ((.=))
+import           Control.Monad
+import           Control.Monad.RWS.Strict
+import           Crypto.Number.Serialize    (i2osp)
+import           Data.Aeson                 (ToJSON (..), Value, encode, object,
+                                             (.=))
+import           Data.Aeson.Lens            hiding (key)
+import qualified Data.Aeson.Lens            as JSON
+import           Data.ByteString            (ByteString)
+import qualified Data.ByteString            as B
+import qualified Data.ByteString.Base64.URL as Base64
+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.Digest.Pure.SHA       (bytestringDigest, sha256)
+import           Data.Maybe
+import           Data.String                (fromString)
+import qualified Data.Text                  as T
+import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)
+import           Data.Time.Clock.POSIX      (getPOSIXTime)
+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
+import           OpenSSL.PEM
+import           OpenSSL.RSA
+import           OpenSSL.X509.Request
+
+data Keys = Keys SomeKeyPair RSAPubKey
+
+--------------------------------------------------------------------------------
+-- | Sign return a payload with a nonce-protected header.
+signPayload :: Keys -> String -> ByteString -> IO LC.ByteString
+signPayload (Keys priv pub) nonce_ payload = withOpenSSL $ do
+  let protected = b64 (header pub nonce_)
+  Just dig <- getDigestByName "SHA256"
+  sig <- b64 <$> signBS dig priv (B.concat [protected, ".", payload])
+  return $ encode (Request (header' pub) protected payload sig)
+
+--------------------------------------------------------------------------------
+-- | Base64URL encoding of Integer with padding '=' removed.
+b64i :: Integer -> ByteString
+b64i = b64 . i2osp
+
+b64 :: ByteString -> ByteString
+b64 = B.takeWhile (/= 61) . Base64.encode
+
+toStrict :: LB.ByteString -> ByteString
+toStrict = B.concat . LB.toChunks
+
+header' :: RSAKey k => k -> Header
+header' key = Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) Nothing
+
+header :: RSAKey k => k -> String -> ByteString
+header key nonce = (toStrict . encode)
+                     (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce))
+
+-- | Registration payload to sign with user key.
+registration :: String -> String -> ByteString
+registration emailAddr terms = (b64 . toStrict . encode) (Reg emailAddr terms)
+
+-- | Challenge request payload to sign with user key.
+authz :: String -> ByteString
+authz = b64. toStrict . encode . Authz
+
+-- | Challenge response payload to sign with user key.
+challenge :: ByteString -> ByteString
+challenge = b64 . toStrict . encode . Challenge . BC.unpack
+
+-- | CSR request payload to sign with user key.
+csr :: ByteString -> ByteString
+csr = b64 . toStrict . encode . CSR . b64
+
+thumbprint :: JWK -> ByteString
+thumbprint = b64 . toStrict . bytestringDigest . sha256 . encodeOrdered
+
+-- | There is an `encodePretty'` in `aeson-pretty`, but do it by hand here.
+encodeOrdered :: JWK -> LB.ByteString
+encodeOrdered JWK{..} = LC.pack $
+  "{\"e\":\"" ++ hE' ++ "\",\"kty\":\"" ++ hKty ++ "\",\"n\":\"" ++ hN' ++ "\"}"
+  where
+  hE' = BC.unpack (b64i hE)
+  hN' = BC.unpack (b64i hN)
+
+
+--------------------------------------------------------------------------------
+data Header = Header
+  { hAlg   :: String
+  , hJwk   :: JWK
+  , hNonce :: Maybe String
+  }
+  deriving Show
+
+data JWK = JWK
+  { hE   :: Integer
+  , hKty :: String
+  , hN   :: Integer
+  }
+  deriving Show
+
+instance ToJSON Header where
+  toJSON Header{..} = object $
+    [ "alg" .= hAlg
+    , "jwk" .= toJSON hJwk
+    ] ++ maybeToList (("nonce" .=) <$> hNonce)
+
+instance ToJSON JWK where
+  toJSON JWK{..} = object
+    [ "e" .= decodeUtf8 (b64i hE)
+    , "kty" .= hKty
+    , "n" .= decodeUtf8 (b64i hN)
+    ]
+
+data Reg = Reg
+  { rMail      :: String
+  , rAgreement :: String
+  }
+  deriving Show
+
+instance ToJSON Reg where
+  toJSON Reg{..} = object
+    [ "resource" .= ("new-reg" :: String)
+    , "contact" .= ["mailto:" ++ rMail]
+    , "agreement" .= rAgreement
+    ]
+
+data Request = Request
+  { rHeader    :: Header
+  , rProtected :: ByteString
+  , rPayload   :: ByteString
+  , rSignature :: ByteString
+  }
+  deriving Show
+
+instance ToJSON Request where
+  toJSON Request{..} = object
+    [ "header" .= toJSON rHeader
+    , "protected" .= decodeUtf8 rProtected
+    , "payload" .= decodeUtf8 rPayload
+    , "signature" .= decodeUtf8 rSignature
+    ]
+
+data Authz = Authz
+  { aDomain :: String
+  }
+
+instance ToJSON Authz where
+  toJSON Authz{..} = object
+    [ "resource" .= ("new-authz" :: String)
+    , "identifier" .= object
+      [ "type" .= ("dns" :: String)
+      , "value" .= aDomain
+      ]
+    ]
+
+data Challenge = Challenge
+  { cKeyAuth :: String
+  }
+
+instance ToJSON Challenge where
+  toJSON Challenge{..} = object
+    [ "resource" .= ("challenge" :: String)
+    , "keyAuthorization" .= cKeyAuth
+    ]
+
+data CSR = CSR ByteString
+  deriving Show
+
+instance ToJSON CSR where
+  toJSON (CSR s) = object
+    [ "resource" .= ("new-cert" :: String)
+    , "csr" .= decodeUtf8 s
+    ]