Commit 6a90ea84 authored by Sophie Herold's avatar Sophie Herold 🏳🌈

Nicer helper function to do everything

parent 78aea561
Pipeline #879 passed with stage
in 8 minutes and 1 second
......@@ -7,12 +7,13 @@ module Network.ACME
import Control.Concurrent (threadDelay)
import Control.Exception.Lifted (throw, try)
import Control.Monad (msum, void)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (asks)
import Crypto.JOSE (KeyMaterialGenParam(RSAGenParam), genJWK)
import qualified Data.ByteString.Char8 as B
import Data.Default.Class (def)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.PEM (PEM(PEM), pemWriteBS)
import qualified Data.X509 as X509
import Network.HTTP.Client (Manager)
......@@ -27,6 +28,37 @@ import Network.ACME.Object
import Network.ACME.Type
-- * Perform Requests
-- **
http01 :: String
http01 = "http-01"
dns01 :: String
dns01 = "dns-01"
tlsSni02 :: String
tlsSni02 = "tls-sni-02"
obtainCertificate ::
CertificateForm a
=> [String] -- ^ domains
-> Base64Octets -- ^ CSR
-> [(String, ChallengeReaction)] -- Challenge reactions
-> CragT [a]
obtainCertificate domains cert reactions = do
(orderURL, orderObj) <- acmePerformNewOrder (acmeNewObjOrder domains)
_ <-
acmePerformGetAuthorizations orderObj >>=
acmePerformChallengeReaction reactions
-- wait until server has validated
mapM_ acmePerformWaitUntilAuthorizationValid $
acmeObjOrderAuthorizations orderObj
-- finalize: submit CSR
_ <- acmePerformFinalizeOrder orderObj cert
-- wait until certificate issued
finalOrder <- acmePerformWaitUntilOrderValid orderURL
-- download certificate
retrieveCertificate finalOrder
-- ** Directory
acmePerformRunner :: CragConfig -> IO (CragReader, CragState)
acmePerformRunner cfg = do
......@@ -144,30 +176,37 @@ acmePerformGetAuthorizations =
acmePerformGetAuthorization :: URL -> CragT AcmeObjAuthorization
acmePerformGetAuthorization url = resBody <$> acmeHttpGet url
type ChallengeResponder a
= HostName -> AcmeKeyAuthorization -> (IO () -> CragT AcmeObjChallenge) -- ^ Perform challenge response, first argument is rollback
-> CragT a
acmePerformChallengeResponses ::
[(String, ChallengeResponder a)]
-> [AcmeObjAuthorization]
-> CragT [a] -- ^
acmePerformChallengeResponses fs as = do
let actions =
map getF (filter ((== "pending") . acmeObjAuthorizationStatus) as)
mapM apply actions
data ChallengeReaction = ChallengeReaction
{ fulfill :: AcmeObjIdentifier -> AcmeKeyAuthorization -> IO ()
, rollback :: AcmeObjIdentifier -> AcmeKeyAuthorization -> IO ()
}
acmePerformChallengeReaction ::
[(String, ChallengeReaction)] -> [AcmeObjAuthorization] -> CragT ()
acmePerformChallengeReaction reactions authzs = do
ops <- mapM reaction authzs'
sequence_
[ do keyAuthz <- acmeKeyAuthorization challenge
let identifier = acmeObjAuthorizationIdentifier authz
liftIO $ fulfill reaction identifier keyAuthz
acmeChallengeRespond challenge (rollback reaction identifier)
| (authz, challenge, reaction) <- ops
]
where
cs :: AcmeObjAuthorization -> [(String, AcmeObjChallenge)]
cs a =
map (\x -> (acmeObjChallengeType x, x)) $ acmeObjAuthorizationChallenges a
g a = msum [(,) f . (,) a <$> lookup chType (cs a) | (chType, f) <- fs]
getF a =
fromMaybe (throw $ AcmeErrNoFullfillableChallenge (map fst fs) a) (g a)
apply (f, (a, ch)) = do
argKey <- acmeKeyAuthorization ch
let argId = acmeObjIdentifierValue (acmeObjAuthorizationIdentifier a)
authz = acmeChallengeRespond (acmeObjChallengeUrl ch) argKey
f argId argKey authz
authzs' = filter ((== "pending") . acmeObjAuthorizationStatus) authzs
reaction ::
AcmeObjAuthorization
-> CragT (AcmeObjAuthorization, AcmeObjChallenge, ChallengeReaction)
reaction authz =
case listToMaybe
[ (authz, challenge, reaction)
| challenge <- acmeObjAuthorizationChallenges authz
, (t, reaction) <- reactions
, t == acmeObjChallengeType challenge
] of
Just x -> return x
Nothing ->
throwError $ AcmeErrNoFullfillableChallenge (map fst reactions) authz
acmePerformFinalizeOrder :: AcmeObjOrder -> Base64Octets -> CragT AcmeObjOrder
acmePerformFinalizeOrder order =
......@@ -179,18 +218,23 @@ acmePerformFinalizeOrder' url csr =
-- | Respond to challenge
acmeChallengeRespond ::
URL -> AcmeKeyAuthorization -> IO () -> CragT AcmeObjChallenge
acmeChallengeRespond req k cleanup = do
res <- try $ resBody <$> acmeHttpJwsPostUrl req (AcmeObjChallengeResponse k)
AcmeObjChallenge
-> (AcmeKeyAuthorization -> IO ())
-> CragT AcmeObjChallenge
acmeChallengeRespond challenge cleanup = do
k <- acmeKeyAuthorization challenge
res <-
try $
resBody <$>
acmeHttpJwsPostUrl
(acmeObjChallengeUrl challenge)
(AcmeObjChallengeResponse k)
case res of
Right r -> return r
Left e -> do
_ <- liftIO cleanup
_ <- liftIO $ cleanup k
throw (e :: AcmeErr)
acmeChallengeRespond' :: URL -> AcmeKeyAuthorization -> CragT AcmeObjChallenge
acmeChallengeRespond' req k = acmeChallengeRespond req k (return ())
-- | Revoke
acmePerformRevokeCertificate :: AcmeObjRevokeCertificate -> CragT ()
acmePerformRevokeCertificate obj =
......
module Network.ACME.Type where
import Control.Monad.Except
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State (StateT, runStateT)
import Crypto.JOSE (JWK)
import Network.HTTP.Client (Manager)
import Network.ACME.Errors
import Network.ACME.Object
-- ** Monad Transformer
type CragT = StateT CragState (ReaderT CragReader IO)
type CragT = ExceptT AcmeErr (StateT CragState (ReaderT CragReader IO))
runCragT :: CragT a -> (CragReader, CragState) -> IO (a, CragState)
runCragT x (r, s) = (`runReaderT` r) $ (`runStateT` s) x
runCragT ::
CragT a -> (CragReader, CragState) -> IO (Either AcmeErr a, CragState)
runCragT x (r, s) = (`runReaderT` r) $ (`runStateT` s) $ runExceptT x
evalCragT :: CragT a -> (CragReader, CragState) -> IO a
evalCragT :: CragT a -> (CragReader, CragState) -> IO (Either AcmeErr a)
evalCragT x v = do
(o, _) <- runCragT x v
return o
......
......@@ -8,6 +8,7 @@ import Crypto.Hash (SHA512(SHA512))
import Crypto.PubKey.RSA (generate)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Either (isRight)
import Data.IORef
import Data.Maybe (fromJust, fromMaybe)
import Data.PEM (pemWriteBS)
......@@ -67,22 +68,17 @@ testOrderNew =
_ <- forkIO $ myHttpServer httpServerLiveConf
manager <- newUnsafeTestManager
state <- acmePerformRunner' manager (config jwk)
flip evalCragT state $ do
let domains = ["localhost"] --, "ip6-localhost", "ip6-loopback"]
csr <- liftIO $ newCrt domains
let cert = Base64Octets csr
_ <- acmePerformCreateAccount accStub
(orderURL, orderObj) <- acmePerformNewOrder (acmeNewObjOrder domains)
_ <-
acmePerformGetAuthorizations orderObj >>=
acmePerformChallengeResponses (challengeResponders httpServerLiveConf)
mapM_ acmePerformWaitUntilAuthorizationValid $
acmeObjOrderAuthorizations orderObj
_ <- acmePerformFinalizeOrder orderObj cert
finalOrder <- acmePerformWaitUntilOrderValid orderURL
crt <- retrieveCertificate finalOrder
liftIO $ putStrLn (concat crt :: String)
return ()
res <-
flip evalCragT state $ do
let domains = ["localhost"] --, "ip6-localhost", "ip6-loopback"]
csr <- liftIO $ newCrt domains
let cert = Base64Octets csr
_ <- acmePerformCreateAccount accStub
crt <-
obtainCertificate domains cert (challengeReactions httpServerLiveConf)
liftIO $ putStrLn (concat crt :: String)
return ()
isRight res @?= True
pebbleResource :: TestTree -> TestTree
pebbleResource = withResource pebbleProcess terminateProcess . const
......@@ -124,18 +120,25 @@ newUnsafeTestManager =
(mkManagerSettings (TLSSettingsSimple True False False) Nothing)
{managerResponseTimeout = responseTimeoutMicro 3000000}
challengeResponders :: HTTPServerLiveConf -> [(String, ChallengeResponder ())]
challengeResponders httpServerLiveConf =
[ ( "http-01"
, \host keyauth c -> do
let requestId = (host, keyAuthorizationHttpPath keyauth)
liftIO $
addResponse (requestId, keyAuthorization keyauth) httpServerLiveConf
liftIO $ putStrLn "responded"
-- submit challenge without rollback thing
_ <- c $ removeResponse requestId httpServerLiveConf
liftIO $ putStrLn "submitted")
challengeReactions :: HTTPServerLiveConf -> [(String, ChallengeReaction)]
challengeReactions httpServerLiveConf =
[ ( http01
, ChallengeReaction
{ fulfill =
\identifier keyAuthz -> do
addResponse
(requestId identifier keyAuthz, keyAuthorization keyAuthz)
httpServerLiveConf
putStrLn "responded"
, rollback =
\identifier keyAuthz -> do
removeResponse (requestId identifier keyAuthz) httpServerLiveConf
putStrLn "removed"
})
]
where
requestId identifier keyAuthz =
(acmeObjIdentifierValue identifier, keyAuthorizationHttpPath keyAuthz)
newCrt :: [String] -> IO B.ByteString
newCrt domains = do
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment