packages feed

acme-not-a-joke (empty) → 0.1.0.0

raw patch · 20 files changed

+1354/−0 lines, 20 filesdep +aesondep +basedep +base16-bytestring

Dependencies added: aeson, base, base16-bytestring, bytestring, cryptohash-sha256, filepath, jose, lens, text, time, wreq

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for microdns++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ acme-not-a-joke.cabal view
@@ -0,0 +1,59 @@+cabal-version:      2.4+name:               acme-not-a-joke+version:            0.1.0.0++-- A short (one-line) description of the package.+synopsis: implements ACME clients (rfc-8555)++-- A longer description of the package.+description: a library to get TLS certificate by communicating to a ACME-provider such as Lets'Encrypt. Hence: no, the acme prefix is not a marker for a joke.++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license: BSD-3-Clause+author:             Lucas DiCioccio+maintainer:         lucas@dicioccio.fr++-- A copyright notice.+copyright: Lucas DiCioccio 2023+category: Security+extra-source-files: CHANGELOG.md++library+    hs-source-dirs: src+    ghc-options: -Wall -Wwarn=missing-home-modules+    default-language: Haskell2010+    default-extensions: OverloadedStrings DataKinds TypeFamilies TypeOperators FlexibleInstances OverloadedRecordDot+    exposed-modules:+      Acme.NotAJoke.Api.Account+      Acme.NotAJoke.Api.Authorization+      Acme.NotAJoke.Api.Certificate+      Acme.NotAJoke.Api.Challenge+      Acme.NotAJoke.Api.CSR+      Acme.NotAJoke.Api.Directory+      Acme.NotAJoke.Api.Endpoint+      Acme.NotAJoke.Api.Field+      Acme.NotAJoke.Api.JWS+      Acme.NotAJoke.Api.Meta+      Acme.NotAJoke.Api.Nonce+      Acme.NotAJoke.Api.Order+      Acme.NotAJoke.Api.Validation+      Acme.NotAJoke.Client+      Acme.NotAJoke.Dancer+      Acme.NotAJoke.LetsEncrypt+      Acme.NotAJoke.KeyManagement+      Acme.NotAJoke.CertManagement+    build-depends:+      aeson >= 2.2.1 && < 2.3,+      base >= 4.19.1 && < 4.20,+      bytestring >= 0.12.1 && < 0.13,+      filepath >= 1.4.200 && < 1.5,+      text >= 2.1.1 && < 2.2,+      time >= 1.12.2 && < 1.13,+      base16-bytestring >= 1.0.2 && < 1.1,+      cryptohash-sha256 >= 0.11.102 && < 0.12,+      jose >= 0.11 && < 0.12,+      lens >= 5.2.3 && < 5.3,+      wreq >= 0.5.4 && < 0.6,
+ src/Acme/NotAJoke/Api/Account.hs view
@@ -0,0 +1,112 @@+module Acme.NotAJoke.Api.Account where++import Control.Lens hiding ((.=))+import Data.Aeson (encode, object, (.=))+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import qualified Data.Text.Encoding as Encoding+import qualified Network.Wreq as Wreq++import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Field+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++-- | The contact-field of an account (something like `mailto:certmaster@example.com`)+type Contact = Text++-- | An RFC-defined account status.+data AccountStatus+    = AccountValid+    | AccountDeactivated+    | AccountRevoked+    deriving (Show, Eq)++-- | A structure holding various Account field.+data Account a+    = Account+    { status :: Field a "status" AccountStatus+    , orders :: Field a "orders" (Endpoint "orders")+    , agreement :: Field a "agreement" (Url "TOS")+    , termsOfServiceAgreed :: Field a "termsOfServiceAgreed" Bool+    , contact :: Field a "contact" [Contact]+    , onlyReturnExisting :: Field a "onlyReturnExisting" Bool+    }++type instance Field "account-create" "termsOfServiceAgreed" x = x+type instance Field "account-create" "contact" x = x+type instance Field "account-create" "status" x = ()+type instance Field "account-create" "orders" x = ()+type instance Field "account-create" "agreement" x = ()+type instance Field "account-create" "onlyReturnExisting" x = ()++type instance Field "account-fetch" "termsOfServiceAgreed" x = x+type instance Field "account-fetch" "contact" x = x+type instance Field "account-fetch" "status" x = ()+type instance Field "account-fetch" "orders" x = ()+type instance Field "account-fetch" "agreement" x = ()+type instance Field "account-fetch" "onlyReturnExisting" x = x++newtype AccountCreated = AccountCreated (Wreq.Response ByteString)+    deriving (Show)++-- | Initializes an account structure, assuming we have read the terms-of-service.+createAccount :: [Contact] -> Account "account-create"+createAccount = createAccount1 True++type HasReadTermsOfService = Bool++-- | Initializes an account structure.+createAccount1 :: HasReadTermsOfService -> [Contact] -> Account "account-create"+createAccount1 tos contacts = Account () () () tos contacts ()++fetchAccount :: [Contact] -> Account "account-fetch"+fetchAccount = fetchAccount1 True True++fetchAccount1 :: Bool -> Bool -> [Contact] -> Account "account-fetch"+fetchAccount1 tos onlyfetch contacts = Account () () () tos contacts onlyfetch++-- | Lookup a Key Identifier for the account.+readKID :: AccountCreated -> Maybe KID+readKID (AccountCreated rsp) = rsp ^? Wreq.responseHeader "location" . to (KID . Encoding.decodeUtf8)++-- | Fetches or create an account (a single API call).+postCreateAccount :: JWS.JWK -> Endpoint "newAccount" -> Nonce -> Account "account-create" -> IO (Maybe AccountCreated)+postCreateAccount jwk ep nonce acc = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (jwkSign jwk ep nonce $ encode $ serialized)+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ AccountCreated e+        Left err -> do+            print err+            pure Nothing+  where+    serialized =+        object+            [ "termsOfServiceAgreed" .= acc.termsOfServiceAgreed+            , "contact" .= acc.contact+            ]++-- | Only fetches an account (i.e., does not create the account if missing).+postFetchAccount :: JWS.JWK -> Endpoint "newAccount" -> Nonce -> Account "account-fetch" -> IO (Maybe AccountCreated)+postFetchAccount jwk ep nonce acc = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (jwkSign jwk ep nonce $ encode $ serialized)+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ AccountCreated e+        Left err -> do+            print err+            pure Nothing+  where+    serialized =+        object+            [ "termsOfServiceAgreed" .= acc.termsOfServiceAgreed+            , "contact" .= acc.contact+            , "onlyReturnExisting" .= acc.onlyReturnExisting+            ]
+ src/Acme/NotAJoke/Api/Authorization.hs view
@@ -0,0 +1,117 @@+module Acme.NotAJoke.Api.Authorization where++import Control.Lens hiding ((.=))+import Data.Aeson (FromJSON (..), ToJSON (..), decode, encode, object, pairs, withObject, withText, (.:), (.:?), (.=))+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import qualified Network.Wreq as Wreq++import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Challenge+import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Field+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++-- RFC-defined authorization statuses.+data AuthorizationStatus+    = AuthorizationPending+    | AuthorizationValid+    | AuthorizationInvalid+    | AuthorizationDeactivated+    | AuthorizationExpired+    | AuthorizationRevoked+    deriving (Show, Eq, Ord)++instance FromJSON AuthorizationStatus where+    parseJSON = withText "AuthorizationStatus" $ \txt ->+        case txt of+            "pending" -> pure AuthorizationPending+            "valid" -> pure AuthorizationValid+            "invalid" -> pure AuthorizationInvalid+            "deactivated" -> pure AuthorizationDeactivated+            "expired" -> pure AuthorizationExpired+            "revoked" -> pure AuthorizationRevoked+            _ -> fail $ "invalid authorization status:" <> show txt++-- RFC-defined authorization types (only the subset supported in this library).+data AuthorizationType+    = DNSAuthorization+    deriving (Show, Eq, Ord)++instance ToJSON AuthorizationType where+    toEncoding DNSAuthorization = toEncoding ("dns" :: Text)+    toJSON DNSAuthorization = toJSON ("dns" :: Text)+instance FromJSON AuthorizationType where+    parseJSON = withText "Authorizationtype" $ \txt ->+        case txt of+            "dns" -> pure DNSAuthorization+            _ -> fail $ "invalid ordertype:" <> show txt++-- | RFC-defined authorization identifiers.+data AuthorizationIdentifier+    = AuthorizationIdentifier+    { type_ :: AuthorizationType+    , value :: Text+    }+    deriving (Show, Eq, Ord)++instance ToJSON AuthorizationIdentifier where+    toEncoding o = pairs ("type" .= o.type_ <> "value" .= o.value)+    toJSON o = object ["type" .= o.type_, "value" .= o.value]+instance FromJSON AuthorizationIdentifier where+    parseJSON = withObject "AuthorizationIdentifier" $ \o ->+        AuthorizationIdentifier+            <$> o .: "type"+            <*> o .: "value"++-- | RFC-defined authorization resource.+data Authorization a+    = Authorization+    { status :: Field a "status" AuthorizationStatus+    , identifier :: Field a "status" AuthorizationIdentifier+    , expires :: Field a "expires" (Maybe UTCTime)+    , challenges :: Field a "challenges" [Challenge "challenge-unspecified"]+    , wildcard :: Field a "wildcard" (Maybe Bool)+    }++newtype AuthorizationInspected = AuthorizationInspected (Wreq.Response ByteString)+    deriving (Show)++type instance Field "authorization-inspected" "status" x = x+type instance Field "authorization-inspected" "identifier" x = x+type instance Field "authorization-inspected" "expires" x = x+type instance Field "authorization-inspected" "challenges" x = x+type instance Field "authorization-inspected" "wildcard" x = x++instance FromJSON (Authorization "authorization-inspected") where+    parseJSON = withObject "Authorization(inspected)" $ \v ->+        Authorization+            <$> v .: "status"+            <*> v .: "identifier"+            <*> v .: "expires"+            <*> v .: "challenges"+            <*> v .:? "wildcard"++-- | Lookup an Authorization.+readAuthorization :: AuthorizationInspected -> Maybe (Authorization "authorization-inspected")+readAuthorization (AuthorizationInspected rsp) = decode $ rsp ^. Wreq.responseBody++-- | Inspects an authorization from its URL.+postGetAuthorization :: JWS.JWK -> KID -> Url "authorization" -> Nonce -> IO (Maybe AuthorizationInspected)+postGetAuthorization jwk kid authUrl nonce = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (kidSign jwk ep kid nonce "")+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ AuthorizationInspected e+        Left err -> do+            print err+            pure Nothing+  where+    ep :: Endpoint "authorization"+    ep = coerce authUrl
+ src/Acme/NotAJoke/Api/CSR.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Acme.NotAJoke.Api.CSR where++import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Text (Text)++newtype Base64DER = Base64DER Text+    deriving (Show, FromJSON, ToJSON)++newtype CSR = CSR Base64DER+    deriving (Show, FromJSON, ToJSON)
+ src/Acme/NotAJoke/Api/Certificate.hs view
@@ -0,0 +1,51 @@+module Acme.NotAJoke.Api.Certificate where++import Control.Lens hiding ((.=))+import Data.Aeson (encode)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString+import Data.Coerce (coerce)+import qualified Network.Wreq as Wreq++import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++{- | The goal of the whole ACME dance is to retrieve such Certificate.++You should be able to figure out most of the ACME flow by looking how you+build a Certificate and pulling all the dependencies.+-}+newtype Certificate = Certificate (Wreq.Response ByteString)+    deriving (Show)++-- | A PEM-file representation of a certificate.+newtype PEM = PEM ByteString++storeCert :: FilePath -> Certificate -> IO ()+storeCert path cert = ByteString.writeFile path (coerce $ readPEM cert)++-- | Lookup a PEM from a certificate.+readPEM :: Certificate -> PEM+readPEM (Certificate rsp) = PEM $ rsp ^. Wreq.responseBody++-- | Retrieves a certificate from an URL.+postGetCertificate :: JWS.JWK -> KID -> Url "certificate" -> Nonce -> IO (Maybe Certificate)+postGetCertificate jwk kid certificateUrl nonce = do+    let opts =+            Wreq.defaults+                & Wreq.header "Content-Type" .~ ["application/jose+json"]+                & Wreq.header "Accept" .~ ["application/pem-certificate-chain"]+    ebody <- (kidSign jwk ep kid nonce "")+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ Certificate e+        Left err -> do+            print err+            pure Nothing+  where+    ep :: Endpoint "certificate"+    ep = coerce certificateUrl
+ src/Acme/NotAJoke/Api/Challenge.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Acme.NotAJoke.Api.Challenge where++import Control.Lens hiding ((.=))+import Data.Aeson (FromJSON (..), Value (..), encode, withObject, withText, (.:), (.:?))+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import qualified Network.Wreq as Wreq++import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Field+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++-- | RFC-defined Challenge types.+data ChallengeType+    = ChallengeDNS01+    | ChallengeHTTP01+    | ChallengeTLSALPN01+    | ChallengeUnspec Text+    deriving (Show, Eq, Ord)++instance FromJSON ChallengeType where+    parseJSON = withText "ChallengeType" $ \txt ->+        case txt of+            "dns-01" -> pure ChallengeDNS01+            "http-01" -> pure ChallengeHTTP01+            "tls-alpn-01" -> pure ChallengeTLSALPN01+            _ -> pure $ ChallengeUnspec txt++-- | RFC-defined Challenge statuses.+data ChallengeStatus+    = -- | challenge is pending (the client should take action)+      ChallengePending+    | -- | challenge is processing (the server should take action)+      ChallengeProcessing+    | -- | challenge has succeeded+      ChallengeValid+    | -- | challenge has failed, timed out etc.+      ChallengeInvalid+    deriving (Show, Eq, Ord)++instance FromJSON ChallengeStatus where+    parseJSON = withText "ChallengeStatus" $ \txt ->+        case txt of+            "pending" -> pure ChallengePending+            "processing" -> pure ChallengeProcessing+            "valid" -> pure ChallengeValid+            "invalid" -> pure ChallengeInvalid+            _ -> fail $ "invalid challenge status:" <> show txt++-- | RFC-defined Challenge resources.+data Challenge a+    = Challenge+    { type_ :: ChallengeType+    , url :: Url "challenge"+    , status :: ChallengeStatus+    , validated :: Maybe UTCTime+    , error :: Maybe Problem+    , --+      token :: Field a "token" Token+    , --+      _sourceObject :: Value -- for extensibility+    }++type instance Field "challenge-unspecified" "token" x = x++{- | Predicate useful to locate DNS-01 challenges when multiple challenges can+validate an Authorization.+-}+isDNS01 :: Challenge "challenge-unspecified" -> Bool+isDNS01 challenge = challenge.type_ == ChallengeDNS01++instance FromJSON (Challenge "challenge-unspecified") where+    parseJSON = withObject "Challenge(unspecified)" $ \v ->+        Challenge+            <$> v .: "type"+            <*> v .: "url"+            <*> v .: "status"+            <*> v .:? "validated"+            <*> v .:? "error"+            <*> v .: "token"+            <*> (pure $ Object v)++{- | An opaque Token that is required in ACME challenges to prove that you+control a given resource.+-}+newtype Token = Token Text+    deriving (Eq, Ord, FromJSON)++newtype ChallengeAttempted = ChallengeAttempted (Wreq.Response ByteString)+    deriving (Show)++{- | Notify the ACME server that you are ready to reply a challenge.++For instance, after installing the required DNS-records.+-}+postReplyChallenge :: JWS.JWK -> KID -> Challenge a -> Nonce -> IO (Maybe ChallengeAttempted)+postReplyChallenge jwk kid challenge nonce = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (kidSign jwk ep kid nonce $ encode emptyObject)+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ ChallengeAttempted e+        Left err -> do+            print err+            pure Nothing+  where+    ep :: Endpoint "authorization"+    ep = coerce (challenge.url)++-- | Query the ACME server about the status of a given challenge.+postGetChallenge :: JWS.JWK -> KID -> Challenge a -> Nonce -> IO (Maybe ChallengeAttempted)+postGetChallenge jwk kid challenge nonce = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (kidSign jwk ep kid nonce "")+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ ChallengeAttempted e+        Left err -> do+            print err+            pure Nothing+  where+    ep :: Endpoint "authorization"+    ep = coerce (challenge.url)
+ src/Acme/NotAJoke/Api/Directory.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}++module Acme.NotAJoke.Api.Directory where++import Control.Lens hiding ((.=))+import Data.Aeson (FromJSON (..))+import Data.Coerce (coerce)+import GHC.Generics (Generic)+import qualified Network.Wreq as Wreq++import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Meta++{- | RFC-defined directory structure.++Mainly contains a series of endpoints.+-}+data Directory+    = Directory+    { meta :: Meta+    , newNonce :: Endpoint "newNonce"+    , newAccount :: Endpoint "newAccount"+    , newOrder :: Endpoint "newOrder"+    , keyChange :: Endpoint "keyChange"+    , renewalInfo :: Endpoint "renewalInfo"+    , revokeCert :: Endpoint "revokeCert"+    }+    deriving (Show, Generic)++instance FromJSON Directory++directory :: BaseUrl -> Endpoint "directory"+directory baseUrl = coerce $ baseUrl <> "directory"++-- | Fetches the server's directory.+fetchDirectory :: Endpoint "directory" -> IO Directory+fetchDirectory ep = do+    r <- Wreq.asJSON =<< get ep+    pure $ r ^. Wreq.responseBody
+ src/Acme/NotAJoke/Api/Endpoint.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Acme.NotAJoke.Api.Endpoint where++import Data.Aeson (FromJSON (..), ToJSON (..), Value)+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.TypeLits+import qualified Network.Wreq as Wreq++{- | A newtype helper to introduce unambiguous URL.+This newtype helps following the logical flow of ACME's dance.+-}+newtype Endpoint (purpose :: Symbol) = Endpoint Text+    deriving (Show, FromJSON)++-- | An undtyped URL.+type RawEndpoint = Text++{- | Same ad Endpoint but for full URLs (e.g., certificates have URLs but the+ACME server has normalized endpoints).+-}+newtype Url (purpose :: Symbol) = Url Text+    deriving (Show, FromJSON, ToJSON)++type BaseUrl = Text++get :: Endpoint a -> IO (Wreq.Response ByteString)+get ep = Wreq.get (wrequrl ep)++raw :: Endpoint a -> RawEndpoint+raw = coerce++wrequrl :: Endpoint a -> String+wrequrl = Text.unpack . coerce++{- | Problem object for rich errors.+The ACME RFCs uses the Problem RFC https://datatracker.ietf.org/doc/html/rfc7807 however we keep the object as an opaque Value as this library treat any error as an opaque error.+-}+type Problem = Value
+ src/Acme/NotAJoke/Api/Field.hs view
@@ -0,0 +1,11 @@+module Acme.NotAJoke.Api.Field where++import GHC.TypeLits (Symbol)++{- | A type-family to help with REST-APIs where representation of a "same"+object depends heavily on a state.++Allows to define a large product type of all possible fields of a REST+resource on one hand. And specialize the structure based on the state.+-}+type family Field (state :: Symbol) (key :: Symbol) valuetype
+ src/Acme/NotAJoke/Api/JWS.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--- | Helpers to work with JSON Web Signatures for ACME.+-- Indeed, almost all ACME API calls are signed with a KID or a JWK and+-- transferred using the JWS format. Thus, some internal helpers are welcome.+module Acme.NotAJoke.Api.JWS where++import Control.Applicative ((<|>))+import Control.Exception (Exception, throwIO)+import Control.Lens hiding ((.=))+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.=))+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Text (Text)++import qualified Crypto.JOSE.JWK as JWK+import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Nonce++newtype PublicJWK = PublicJWK JWK.JWK+    deriving (Show, FromJSON, ToJSON)++publicJWK :: JWK.JWK -> Maybe PublicJWK+publicJWK = coerce . view JWK.asPublicKey++newtype KID = KID Text+    deriving (Show, FromJSON, ToJSON)++data AcmeHeader p+    = AcmeHeader+    { _jwsHeader :: JWS.JWSHeader p+    , _acmeURL :: RawEndpoint+    , _acmeNonce :: Nonce+    , _acmeAuthBit :: Either PublicJWK KID+    }++acmeJwsHeader :: Lens' (AcmeHeader p) (JWS.JWSHeader p)+acmeJwsHeader f s@(AcmeHeader{_jwsHeader = a}) =+    fmap (\a' -> s{_jwsHeader = a'}) (f a)++acmeNonce :: Lens' (AcmeHeader p) Nonce+acmeNonce f s@(AcmeHeader{_acmeNonce = a}) =+    fmap (\a' -> s{_acmeNonce = a'}) (f a)++acmeURL :: Lens' (AcmeHeader p) RawEndpoint+acmeURL f s@(AcmeHeader{_acmeURL = a}) =+    fmap (\a' -> s{_acmeURL = a'}) (f a)++acmeAuthBit :: Lens' (AcmeHeader p) (Either PublicJWK KID)+acmeAuthBit f s@(AcmeHeader{_acmeAuthBit = a}) =+    fmap (\a' -> s{_acmeAuthBit = a'}) (f a)++instance JWS.HasJWSHeader AcmeHeader where+    jwsHeader = acmeJwsHeader++instance JWS.HasParams AcmeHeader where+    parseParamsFor proxy hp hu =+        AcmeHeader+            <$> JWS.parseParamsFor proxy hp hu+            <*> JWS.headerRequiredProtected "url" hp hu+            <*> JWS.headerRequiredProtected "nonce" hp hu+            <*> jwkOrKid+      where+        jwkOrKid = (JWS.headerRequiredProtected "jwk" hp hu) <|> (JWS.headerRequiredProtected "kid" hp hu)+    params h =+        [ (True, "nonce" .= view acmeNonce h)+        , (True, "url" .= view acmeURL h)+        ]+            <> JWS.params (view acmeJwsHeader h)+            <> view (acmeAuthBit . _Left . to (\jwk -> [(True, "jwk" .= jwk)])) h+            <> view (acmeAuthBit . _Right . to (\kid -> [(True, "kid" .= kid)])) h+    extensions = const ["nonce", "url", "jwk", "kid"]++data NoPublicKeyInJWK = NoPublicKeyInJWK+    deriving (Show)+instance Exception NoPublicKeyInJWK++jwkSign :: JWS.JWK -> Endpoint a -> Nonce -> ByteString -> IO (Either JWS.Error (JWS.FlattenedJWS AcmeHeader))+jwkSign jwk ep nonce payload = do+    jwk2 <- maybe (throwIO NoPublicKeyInJWK) pure $ publicJWK jwk+    JWS.runJOSE $ do+        -- alg <- JWS.bestJWSAlg jwk+        let alg = JWS.RS256+        let header = AcmeHeader (JWS.newJWSHeader (JWS.Protected, alg)) (raw ep) nonce (Left jwk2)+        JWS.signJWS payload (pure (header, jwk))++kidSign :: JWS.JWK -> Endpoint a -> KID -> Nonce -> ByteString -> IO (Either JWS.Error (JWS.FlattenedJWS AcmeHeader))+kidSign jwk ep kid nonce payload = JWS.runJOSE $ do+    -- alg <- JWS.bestJWSAlg jwk+    let alg = JWS.RS256+    let header = AcmeHeader (JWS.newJWSHeader (JWS.Protected, alg)) (raw ep) nonce (Right kid)+    JWS.signJWS payload (pure (header, jwk))++newtype EmptyObject = EmptyObject Value+    deriving (Show, FromJSON, ToJSON)++emptyObject :: EmptyObject+emptyObject = EmptyObject (Object mempty)++newtype EmptyText = EmptyText Value+    deriving (Show, FromJSON, ToJSON)++emptyText :: EmptyText+emptyText = EmptyText (String mempty)
+ src/Acme/NotAJoke/Api/Meta.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric #-}++module Acme.NotAJoke.Api.Meta where++import Data.Aeson (FromJSON (..))+import Data.Text (Text)+import GHC.Generics (Generic)++import Acme.NotAJoke.Api.Endpoint (Url)++type CAAIdentity = Text++-- | RFC-defined ACME server metadata.+data Meta+    = Meta+    { caaIdentities :: [CAAIdentity]+    , termsOfService :: Url "TOS"+    , website :: Url "website"+    }+    deriving (Show, Generic)++instance FromJSON Meta
+ src/Acme/NotAJoke/Api/Nonce.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- | Almost all ACME API Calls require a Nonce to prevent replayability of+requests.+Most API Calls return a Nonce for the next request.+Client should re-use these Nonce to avoid overloading the server.+This module provide helpers to deal with this requirement.+-}+module Acme.NotAJoke.Api.Nonce where++import Control.Lens hiding ((.=))+import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (Coercible, coerce)+import Data.IORef (atomicModifyIORef, newIORef, writeIORef)+import Data.Text (Text)+import qualified Data.Text.Encoding as Encoding+import qualified Network.Wreq as Wreq++import Acme.NotAJoke.Api.Endpoint++newtype Nonce = Nonce Text+    deriving (Show, FromJSON, ToJSON)++getNonce :: Endpoint "newNonce" -> IO (Maybe Nonce)+getNonce ep = do+    r <- Wreq.head_ (wrequrl ep)+    pure $ responseNonceWreq r+  where++responseNonceWreq :: forall a. Wreq.Response a -> Maybe Nonce+responseNonceWreq r =+    r ^? Wreq.responseHeader "replay-nonce" . to Encoding.decodeUtf8 . to Nonce++responseNonceWreqBS :: Wreq.Response ByteString -> Maybe Nonce+responseNonceWreqBS = responseNonceWreq++responseNonce :: forall a. (Coercible a (Wreq.Response ByteString)) => a -> Maybe Nonce+responseNonce = responseNonceWreqBS . coerce++data Fetcher = Fetcher+    { produce :: IO (Maybe Nonce)+    , set :: Nonce -> IO ()+    , fetchNewNonce :: IO (Maybe Nonce)+    }++fetcher :: IO (Maybe Nonce) -> IO Fetcher+fetcher fetch = do+    ref <- newIORef Nothing+    pure $ Fetcher (go ref) (writeIORef ref . Just) fetch+  where+    go ref = do+        val <- atomicModifyIORef ref (\x -> (Nothing, x))+        case val of+            Nothing -> fetch+            (Just x) -> pure (Just x)++saveResponseNonce :: forall a. (Coercible a (Wreq.Response ByteString)) => Fetcher -> a -> IO ()+saveResponseNonce nonceFetcher rsp =+    maybe (pure ()) (nonceFetcher.set) (responseNonce rsp)++saveNonce :: forall a. (Coercible a (Wreq.Response ByteString)) => Fetcher -> IO (Maybe a) -> IO (Maybe a)+saveNonce nonceFetcher apiCall = do+    obj <- apiCall+    maybe (pure ()) (saveResponseNonce nonceFetcher) obj+    pure obj
+ src/Acme/NotAJoke/Api/Order.hs view
@@ -0,0 +1,236 @@+module Acme.NotAJoke.Api.Order where++import Control.Lens hiding ((.=))+import Data.Aeson (FromJSON (..), ToJSON (..), decode, encode, object, pairs, withObject, withText, (.:), (.:?), (.=))+import Data.ByteString.Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text.Encoding as Encoding+import Data.Time.Clock (UTCTime)+import qualified Network.Wreq as Wreq++import qualified Crypto.JOSE.JWS as JWS++import Acme.NotAJoke.Api.CSR+import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Field+import Acme.NotAJoke.Api.JWS+import Acme.NotAJoke.Api.Nonce++-- | RFC-defined order statuses.+data OrderStatus+    = OrderPending+    | OrderReady+    | OrderProcessing+    | OrderValid+    | OrderInvalid+    deriving (Show, Eq, Ord)++instance FromJSON OrderStatus where+    parseJSON = withText "OrderStatus" $ \txt ->+        case txt of+            "pending" -> pure OrderPending+            "ready" -> pure OrderReady+            "processing" -> pure OrderProcessing+            "valid" -> pure OrderValid+            "invalid" -> pure OrderInvalid+            _ -> fail $ "invalid order status:" <> show txt++-- | RFC-defined order types (for the subset supported in this library).+data OrderType+    = -- | Order is about requesting DNS certificates.+      DNSOrder+    deriving (Show, Eq, Ord)++instance ToJSON OrderType where+    toEncoding DNSOrder = toEncoding ("dns" :: Text)+    toJSON DNSOrder = toJSON ("dns" :: Text)+instance FromJSON OrderType where+    parseJSON = withText "Ordertype" $ \txt ->+        case txt of+            "dns" -> pure DNSOrder+            _ -> fail $ "invalid ordertype:" <> show txt++-- | RFC-defined order identifier.+data OrderIdentifier+    = OrderIdentifier+    { type_ :: OrderType+    , value :: Text+    }+    deriving (Show, Eq, Ord)++instance ToJSON OrderIdentifier where+    toEncoding o = pairs ("type" .= o.type_ <> "value" .= o.value)+    toJSON o = object ["type" .= o.type_, "value" .= o.value]+instance FromJSON OrderIdentifier where+    parseJSON = withObject "OrderIdentifier" $ \o ->+        OrderIdentifier+            <$> o .: "type"+            <*> o .: "value"++-- | RFC-defined order structure.+data Order a+    = Order+    { status :: Field a "status" OrderStatus+    , expires :: Field a "expires" UTCTime+    , identifiers :: Field a "identifiers" [OrderIdentifier]+    , notBefore :: Field a "notBefore" (Maybe UTCTime)+    , notAfter :: Field a "notAfter" (Maybe UTCTime)+    , error :: Field a "error" (Maybe Problem)+    , authorizations :: Field a "authorizations" [Url "authorization"]+    , finalize :: Field a "finalize" (Url "finalize-order")+    , certificate :: Field a "certificate" (Url "certificate")+    }++type instance Field "order-create" "status" x = ()+type instance Field "order-create" "expires" x = ()+type instance Field "order-create" "identifiers" x = x+type instance Field "order-create" "notBefore" x = x+type instance Field "order-create" "notAfter" x = x+type instance Field "order-create" "error" x = ()+type instance Field "order-create" "authorizations" x = ()+type instance Field "order-create" "finalize" x = ()+type instance Field "order-create" "certificate" x = ()++newtype OrderCreated = OrderCreated (Wreq.Response ByteString)+    deriving (Show)++type instance Field "order-created" "status" x = x+type instance Field "order-created" "expires" x = x+type instance Field "order-created" "identifiers" x = x+type instance Field "order-created" "notBefore" x = x+type instance Field "order-created" "notAfter" x = x+type instance Field "order-created" "error" x = x+type instance Field "order-created" "authorizations" x = x+type instance Field "order-created" "finalize" x = x+type instance Field "order-created" "certificate" x = ()++instance FromJSON (Order "order-created") where+    parseJSON = withObject "Order(created)" $ \v ->+        Order+            <$> v .: "status"+            <*> v .: "expires"+            <*> v .: "identifiers"+            <*> v .:? "notBefore"+            <*> v .:? "notAfter"+            <*> v .:? "error"+            <*> v .: "authorizations"+            <*> v .: "finalize"+            <*> pure ()++-- | Prepare a new order.+createOrder :: (Maybe UTCTime, Maybe UTCTime) -> [OrderIdentifier] -> Order "order-create"+createOrder (nbefore, nafter) ois =+    Order () () ois nbefore nafter () () () ()++readOrderUrl :: OrderCreated -> Maybe (Url "order")+readOrderUrl (OrderCreated rsp) = rsp ^? Wreq.responseHeader "location" . to (Url . Encoding.decodeUtf8)++readOrderCreated :: OrderCreated -> Maybe (Order "order-created")+readOrderCreated (OrderCreated rsp) = decode $ rsp ^. Wreq.responseBody++-- | Requests a new order to the server.+postNewOrder :: JWS.JWK -> Endpoint "newOrder" -> KID -> Nonce -> Order "order-create" -> IO (Maybe OrderCreated)+postNewOrder jwk ep kid nonce ord = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (kidSign jwk ep kid nonce $ encode $ serialized)+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ OrderCreated e+        Left err -> do+            print err+            pure Nothing+  where+    serialized =+        object $+            catMaybes+                [ (\x -> "notBefore" .= x) <$> ord.notBefore+                , (\x -> "notAfter" .= x) <$> ord.notAfter+                , Just $ "identifiers" .= ord.identifiers+                ]++newtype OrderInspected = OrderInspected (Wreq.Response ByteString)+    deriving (Show)++type instance Field "order-inspected" "status" x = x+type instance Field "order-inspected" "expires" x = x+type instance Field "order-inspected" "identifiers" x = x+type instance Field "order-inspected" "notBefore" x = ()+type instance Field "order-inspected" "notAfter" x = ()+type instance Field "order-inspected" "error" x = x+type instance Field "order-inspected" "authorizations" x = x+type instance Field "order-inspected" "finalize" x = x+type instance Field "order-inspected" "certificate" x = Maybe x++instance FromJSON (Order "order-inspected") where+    parseJSON = withObject "Order(inspected)" $ \v ->+        Order+            <$> v .: "status"+            <*> v .: "expires"+            <*> v .: "identifiers"+            <*> pure ()+            <*> pure ()+            <*> v .:? "error"+            <*> v .: "authorizations"+            <*> v .: "finalize"+            <*> v .:? "certificate"++readOrderInspected :: OrderInspected -> Maybe (Order "order-inspected")+readOrderInspected (OrderInspected rsp) = decode $ rsp ^. Wreq.responseBody++readCertificateUrl :: OrderInspected -> Maybe (Url "certificate")+readCertificateUrl order =+    certificate =<< readOrderInspected order++-- | Fetches a known order to inspect its status.+postGetOrder :: JWS.JWK -> Url "order" -> KID -> Nonce -> IO (Maybe OrderInspected)+postGetOrder jwk orderurl kid nonce = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (kidSign jwk ep kid nonce "")+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ OrderInspected e+        Left err -> do+            print err+            pure Nothing+  where+    ep :: Endpoint "order"+    ep = coerce orderurl++{- | RFC-defined finalization request.+Consists of a CSR.+-}+data Finalize+    = Finalize+    { csr :: CSR+    }++newtype OrderFinalized = OrderFinalized (Wreq.Response ByteString)+    deriving (Show)++-- todo: specialize status of a finalized order+readOrderFinalized :: OrderFinalized -> Maybe (Order "order-created")+readOrderFinalized (OrderFinalized rsp) = decode $ rsp ^. Wreq.responseBody++-- | Finalize an order after completing a challenge.+postFinalizeOrder :: JWS.JWK -> KID -> Url "finalize-order" -> Finalize -> Nonce -> IO (Maybe OrderFinalized)+postFinalizeOrder jwk kid finalizeurl finalizeobj nonce = do+    let opts = Wreq.defaults & Wreq.header "Content-Type" .~ ["application/jose+json"]+    ebody <- (kidSign jwk ep kid nonce $ encode $ serialized)+    case ebody of+        Right body -> do+            e <- Wreq.postWith opts (wrequrl ep) $ encode body+            pure $ Just $ OrderFinalized e+        Left err -> do+            print err+            pure Nothing+  where+    ep :: Endpoint "finalize-order"+    ep = coerce finalizeurl+    serialized =+        object $+            [ "csr" .= finalizeobj.csr+            ]
+ src/Acme/NotAJoke/Api/Validation.hs view
@@ -0,0 +1,41 @@+-- | Helper to build a ValidationProof out of some token+module Acme.NotAJoke.Api.Validation where++import Control.Lens hiding ((.=))+import Data.Coerce (coerce)+import Data.Text (Text)+import qualified Data.Text.Encoding as Encoding++import qualified Crypto.JOSE.JWK as JWK++import Acme.NotAJoke.Api.Challenge++-- | RFC-defined key authorizations.+newtype KeyAuthorization = KeyAuthorization Text+    deriving (Eq, Ord)++keyAuthorization :: Token -> JWK.JWK -> KeyAuthorization+keyAuthorization tok jwk =+    KeyAuthorization txt+  where+    txt, tok', b64thumbprint :: Text+    txt = tok' <> "." <> b64thumbprint+    tok' = coerce tok+    b64thumbprint = Encoding.decodeUtf8 $ review (JWK.base64url . JWK.digest) tprint++    tprint :: JWK.Digest JWK.SHA256+    tprint = view JWK.thumbprint jwk++newtype ValidationProof = ValidationProof Text+    deriving (Eq)++sha256digest :: KeyAuthorization -> ValidationProof+sha256digest (KeyAuthorization kauth) =+    ValidationProof $+        Encoding.decodeUtf8 $+            review+                (JWK.base64url . JWK.digest)+                hash+  where+    hash :: JWK.Digest JWK.SHA256+    hash = JWK.hash $ Encoding.encodeUtf8 kauth
+ src/Acme/NotAJoke/CertManagement.hs view
@@ -0,0 +1,16 @@+{- | A series of helper to work with Certificate Signing Requests.++See the `openssl req` command to build CSR and DER files.+-}+module Acme.NotAJoke.CertManagement where++import Acme.NotAJoke.Api.CSR+import Control.Lens hiding ((.=))+import qualified Crypto.JOSE.JWK as JWK+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.Encoding as Encoding++-- | Loads a DER file in base64 format.+loadDER :: FilePath -> IO Base64DER+loadDER =+    fmap (Base64DER . Encoding.decodeUtf8 . review JWK.base64url) . LBS.readFile
+ src/Acme/NotAJoke/Client.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++module Acme.NotAJoke.Client where++import qualified Data.List as List+import Data.Maybe (fromJust)++import qualified Crypto.JOSE.JWK as JWK++import Acme.NotAJoke.Api.Account+import Acme.NotAJoke.Api.Authorization+import Acme.NotAJoke.Api.CSR+import Acme.NotAJoke.Api.Certificate+import Acme.NotAJoke.Api.Challenge+import Acme.NotAJoke.Api.Directory+import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Nonce as Nonce+import Acme.NotAJoke.Api.Order+import Acme.NotAJoke.Api.Validation++{- | An IO-type for ACME primitives.+As we iterate on this lib, this type may change to become a monad-stack/mtl-mashup.+-}+type AcmePrim a = IO (Maybe a)++{- | An object carrying all functions to generate a single authorization from a+single order with a DNS challenge.+-}+data AcmeSingle = AcmeSingle+    { dir :: Directory+    -- ^ directory for the Server+    , nonces :: Nonce.Fetcher+    -- ^ an object to generate new nonces for this ACME server, saving found nonces opportunistically+    , pollOrder :: AcmePrim OrderInspected+    -- ^ fetches the status of an order+    , fetchAuthorization :: AcmePrim AuthorizationInspected+    -- ^ fetches the authorization, this function is called by prepareAcmeOrder so you may not need to inspect authorization yourself+    , proof :: (Token, KeyAuthorization, ValidationProof)+    -- ^ the validation proof (i.e., the value to set in DNS records and so on)+    , replyChallenge :: AcmePrim ChallengeAttempted+    -- ^ tells the server it can validates the challenge (i.e., after writing the proof in some DNS record)+    , pollChallenge :: AcmePrim ChallengeAttempted+    -- ^ fetches the status of a challenge (mainly to know if the server has validated the challenge)+    , finalizeOrder :: AcmePrim OrderFinalized+    -- ^ finalize the order (i.e, effectively sends the CSR to the server)+    , fetchCertificate :: Url "certificate" -> AcmePrim Certificate+    -- ^ fetch the signed certificate, the URL comes from a OrderInspected (see readOrderInspected)+    }++data PrepareStep+    = Starting+    | GotDirectory Directory+    | GettingNonce+    | GotAccount AccountCreated+    | GotOrder OrderCreated+    | GotAuthorization AuthorizationInspected++type MatchChallenge = Challenge "challenge-unspecified" -> Bool++-- TODO:++-- * step for errors++-- * return shortcuts in handleStep function+prepareAcmeOrder ::+    BaseUrl ->+    JWK.JWK ->+    Account "account-fetch" ->+    CSR ->+    Order "order-create" ->+    MatchChallenge ->+    (PrepareStep -> IO ()) ->+    IO AcmeSingle+prepareAcmeOrder baseurl jwk account csr1 order matchChallenge handleStep = do+    handleStep $ Starting++    -- unauthenticated info+    acmeDir <- fetchDirectory (directory baseurl)+    nf <- fetcher (handleStep GettingNonce >> getNonce acmeDir.newNonce)+    let mknonce = nf.produce+    let nonceify = fromJust <$> mknonce+    handleStep $ GotDirectory acmeDir++    -- fetch account+    nonce1 <- nonceify+    Just accountCreated <- saveNonce nf (postFetchAccount jwk acmeDir.newAccount nonce1 account)+    let (Just kid) = readKID accountCreated+    handleStep $ GotAccount accountCreated++    -- prepare new order+    nonce2 <- nonceify+    Just orderCreated <- saveNonce nf (postNewOrder jwk acmeDir.newOrder kid nonce2 order)+    let Just authUrl = safeHead . authorizations =<< readOrderCreated orderCreated+    handleStep $ GotOrder orderCreated++    -- poller for order+    let Just orderUrl = readOrderUrl orderCreated+    let fpollOrder = saveNonce nf (postGetOrder jwk orderUrl kid =<< nonceify)++    -- read authorization's dns challenge+    let ffetchAuthorization = saveNonce nf (postGetAuthorization jwk kid authUrl =<< nonceify)+    Just authorizationInspected <- ffetchAuthorization+    handleStep $ GotAuthorization authorizationInspected+    let Just challenge = List.find matchChallenge . challenges =<< readAuthorization authorizationInspected++    -- challenge validation proof+    let tok = challenge.token+    let keyAuth = keyAuthorization tok jwk+    let proofVal = sha256digest keyAuth++    -- read authorization's dns challenge+    let freplyChallenge = saveNonce nf (postReplyChallenge jwk kid challenge =<< nonceify)+    let fpollChallenge = saveNonce nf (postGetChallenge jwk kid challenge =<< nonceify)++    -- finalize order+    let Just finalizeOrderUrl = fmap finalize $ readOrderCreated orderCreated+    let ffinalizeOrder = saveNonce nf (postFinalizeOrder jwk kid finalizeOrderUrl (Finalize csr1) =<< nonceify)++    -- fetch certificate (at last)+    let ffetchCertificate certificateUrl = saveNonce nf (postGetCertificate jwk kid certificateUrl =<< nonceify)++    pure $ AcmeSingle acmeDir nf fpollOrder ffetchAuthorization (tok, keyAuth, proofVal) freplyChallenge fpollChallenge ffinalizeOrder ffetchCertificate+  where+    safeHead :: [x] -> Maybe x+    safeHead [] = Nothing+    safeHead (x : _) = Just x
+ src/Acme/NotAJoke/Dancer.hs view
@@ -0,0 +1,127 @@+module Acme.NotAJoke.Dancer where++import Control.Concurrent (threadDelay)+import Control.Monad (void)+import qualified Crypto.JOSE.JWK as JWK+import Data.Maybe (fromJust)+import Data.Text (Text)++import Acme.NotAJoke.Api.Account+import Acme.NotAJoke.Api.CSR+import Acme.NotAJoke.Api.Certificate+import Acme.NotAJoke.Api.Challenge (Token (..), isDNS01)+import Acme.NotAJoke.Api.Endpoint+import Acme.NotAJoke.Api.Order+import Acme.NotAJoke.Api.Validation+import Acme.NotAJoke.Client++data AcmeDancer+    = AcmeDancer+    { baseUrl :: BaseUrl+    , accountJwk :: JWK.JWK+    , account :: Account "account-fetch"+    , csr :: CSR+    , order :: Order "order-create"+    , handleStep :: DanceStep -> IO ()+    }++data DanceStep+    = Validation (Token, KeyAuthorization, ValidationProof)+    | WaitingForValidation Int+    | OrderIsFinalized OrderFinalized+    | ValidOrder OrderInspected+    | InvalidOrder OrderInspected+    | OtherError Text+    | Done AcmeSingle Certificate+    | Prepare PrepareStep++runAcmeDance_dns01 :: AcmeDancer -> IO ()+runAcmeDance_dns01 = runAcmeDance isDNS01++runAcmeDance :: MatchChallenge -> AcmeDancer -> IO ()+runAcmeDance matchChallenge dancer = do+    acme <-+        prepareAcmeOrder+            dancer.baseUrl+            dancer.accountJwk+            dancer.account+            dancer.csr+            dancer.order+            matchChallenge+            handleAcmeSingleStep+    go acme+  where+    go acme = do+        dancer.handleStep $ Validation acme.proof+        _ <- acme.replyChallenge+        waitForValidOrder 0 acme++    handleAcmeSingleStep = dancer.handleStep . Prepare++    waitForValidOrder n acme = do+        dancer.handleStep (WaitingForValidation n)+        recentOrder <- fromJust <$> acme.pollOrder+        case Acme.NotAJoke.Api.Order.status <$> readOrderInspected recentOrder of+            Just OrderPending -> waitForValidOrder (succ n) acme+            Just OrderProcessing -> waitForValidOrder (succ n) acme+            Just OrderReady -> do+                x <- fromJust <$> acme.finalizeOrder+                dancer.handleStep $ OrderIsFinalized x+                waitForValidOrder (succ n) acme+            Just OrderValid -> handleValid acme recentOrder+            Just OrderInvalid -> dancer.handleStep $ InvalidOrder recentOrder+            _ -> dancer.handleStep $ OtherError "could not inspect order"++    handleValid acme o = do+        dancer.handleStep $ ValidOrder o+        let certUrl = certificate =<< (readOrderInspected o)+        certif <- acme.fetchCertificate (fromJust certUrl)+        dancer.handleStep $ Done acme (fromJust certif)++{- | A dance for running from within GHCI (i.e., printing and expecting you to+press ENTER to continue).+-}+ghciDance :: FilePath -> DanceStep -> IO ()+ghciDance certPath x =+    case x of+        Validation (tok, keyAuth, sha) -> do+            print ("token (http01) is" :: Text, showToken tok)+            print ("key authorization (http01) is" :: Text, showKeyAuth keyAuth)+            print ("sha256 (dns01) is" :: Text, showProof sha)+            print ("press enter to continue" :: Text)+            void getLine+        OrderIsFinalized o -> do+            print ("finalized" :: Text, o)+        ValidOrder o -> do+            print ("order valid" :: Text, o)+        WaitingForValidation n -> do+            print ("waiting" :: Text, n)+            threadDelay $ n * 1000000+        Done _ cert -> do+            storeCert certPath cert+            print cert+        InvalidOrder o -> do+            print ("order invalid" :: Text, o)+        OtherError txt -> do+            print ("order invalid" :: Text, txt)+        Prepare Starting -> do+            print ("starting" :: Text)+        Prepare GettingNonce -> do+            print ("getting-nonce" :: Text)+        Prepare (GotDirectory d) -> do+            print ("listed directory" :: Text, d)+        Prepare (GotAccount a) -> do+            print ("got account" :: Text, a)+        Prepare (GotOrder o) -> do+            print ("got order" :: Text, o)+        Prepare (GotAuthorization a) -> do+            print ("got authorization" :: Text, a)++showToken :: Token -> Text+showToken (Token x1) = x1++showKeyAuth :: KeyAuthorization -> Text+showKeyAuth (KeyAuthorization x1) = x1++showProof :: ValidationProof -> Text+showProof (ValidationProof x1) = x1
+ src/Acme/NotAJoke/KeyManagement.hs view
@@ -0,0 +1,18 @@+module Acme.NotAJoke.KeyManagement where++import Data.Aeson (decode, encode)+import qualified Data.ByteString.Lazy as LBS++import qualified Crypto.JOSE.JWK as JWK++-- | Generates and RSA-4096 bits key.+genJWKrsa4096 :: IO JWK.JWK+genJWKrsa4096 = JWK.genJWK (JWK.RSAGenParam (4096 `div` 8))++-- | Loads a JWK from a file.+loadJWKFile :: FilePath -> IO (Maybe JWK.JWK)+loadJWKFile = fmap decode . LBS.readFile++-- | Loads a JWK from a file.+writeJWKFile :: JWK.JWK -> FilePath -> IO ()+writeJWKFile jwk path = LBS.writeFile path (encode jwk)
+ src/Acme/NotAJoke/LetsEncrypt.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++module Acme.NotAJoke.LetsEncrypt where++import Acme.NotAJoke.Api.Endpoint++-- Base URL for Let'sEncrypt staging.+staging_letsencryptv2 :: BaseUrl+staging_letsencryptv2 = "https://acme-staging-v02.api.letsencrypt.org/"++-- Base URL for Let'sEncrypt production.+letsencryptv2 :: BaseUrl+letsencryptv2 = "https://acme-v02.api.letsencrypt.org/"