From 15d6572b9fa0ff6b0105eaa26583f496b18f78b4 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Fri, 22 Jan 2016 11:36:37 -0500 Subject: Factored out Network.ACME library --- acme-encrypt.cabal | 30 ++++---- acme.hs | 146 +------------------------------------- src/Network/ACME.hs | 198 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 216 insertions(+), 158 deletions(-) create mode 100644 src/Network/ACME.hs 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 + ] -- cgit v1.2.3