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 --- src/Network/ACME.hs | 198 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 198 insertions(+) create mode 100644 src/Network/ACME.hs (limited to 'src') 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