Commit 8fefd752 authored by Sophie Herold's avatar Sophie Herold 🏳🌈

Removes use of exceptions

parent 6a90ea84
Pipeline #880 passed with stage
in 8 minutes and 14 seconds
......@@ -20,7 +20,7 @@ library
TemplateHaskell
exposed-modules:
Network.ACME
Network.ACME.Errors
Network.ACME.Error
Network.ACME.HTTPS
Network.ACME.HTTPS.Internal
Network.ACME.Internal
......@@ -38,13 +38,12 @@ library
http-types,
jose >= 0.6,
lens,
lifted-base,
mtl,
network,
network-uri,
time,
pem,
mtl,
template-haskell,
time,
x509
hs-source-dirs: src
default-language: Haskell2010
......
......@@ -5,9 +5,8 @@ module Network.ACME
) where
import Control.Concurrent (threadDelay)
import Control.Exception.Lifted (throw, try)
import Control.Monad (msum, void)
import Control.Monad.Except (throwError)
import Control.Monad (void)
import Control.Monad.Except (ExceptT, catchError, throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (asks)
import Crypto.JOSE (KeyMaterialGenParam(RSAGenParam), genJWK)
......@@ -18,9 +17,8 @@ import Data.PEM (PEM(PEM), pemWriteBS)
import qualified Data.X509 as X509
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (newTlsManager)
import Network.Socket (HostName)
import Network.ACME.Errors
import Network.ACME.Error
import Network.ACME.HTTPS
import Network.ACME.Internal (secondsToMicroseconds)
import Network.ACME.JWS
......@@ -60,21 +58,21 @@ obtainCertificate domains cert reactions = do
retrieveCertificate finalOrder
-- ** Directory
acmePerformRunner :: CragConfig -> IO (CragReader, CragState)
acmePerformRunner :: CragConfig -> ExceptT AcmeErr IO (CragReader, CragState)
acmePerformRunner cfg = do
manager <- newTlsManager
acmePerformRunner' manager cfg
acmePerformRunner' :: Manager -> CragConfig -> IO (CragReader, CragState)
acmePerformRunner' ::
Manager -> CragConfig -> ExceptT AcmeErr IO (CragReader, CragState)
acmePerformRunner' manager cfg = do
res <- acmePerformDirectory (cragConfigDirectoryURL cfg) manager
publicKey <- either throwError return $ jwkPublic (cragConfigJwk cfg)
return
( CragReader
cfg
CragSetup
{ cragSetupJwkPublic = jwkPublic (cragConfigJwk cfg)
, cragSetupHttpManager = manager
}
{cragSetupJwkPublic = publicKey, cragSetupHttpManager = manager}
, CragState
{ cragStateDirectory = res
, cragStateNonce = Nothing
......@@ -85,13 +83,13 @@ acmePerformRunner' manager cfg = do
-- | Account Creation (Registration)
acmePerformCreateAccount :: AcmeObjStubAccount -> CragT AcmeObjAccount
acmePerformCreateAccount stubAcc =
resBody <$> acmeHttpJwsPostNewAccount AcmeDirectoryRequestNewAccount stubAcc
resBody =<< acmeHttpJwsPostNewAccount AcmeDirectoryRequestNewAccount stubAcc
-- | Account Update
acmePerformUpdateAccount :: AcmeObjAccount -> CragT AcmeObjAccount
acmePerformUpdateAccount newAcc = do
url <- acmePerformFindAccountURL
resBody <$> acmeHttpJwsPostUrl url newAcc
resBody =<< acmeHttpJwsPostUrl url newAcc
-- | Key Roll-over
acmePerformAccountKeyRollover ::
......@@ -100,7 +98,7 @@ acmePerformAccountKeyRollover ::
acmePerformAccountKeyRollover newJWK = do
accURL <- acmePerformFindAccountURL
let obj = AcmeObjAccountKeyRollover accURL newJWK
resBody <$> acmeHttpJwsPost AcmeDirectoryRequestKeyChange obj
resBody =<< acmeHttpJwsPost AcmeDirectoryRequestKeyChange obj
-- ** Certificate
-- | Create new application (handing in a certificate request)
......@@ -108,11 +106,11 @@ acmePerformNewOrder :: AcmeObjNewOrder -> CragT (URL, AcmeObjOrder)
acmePerformNewOrder ord = do
res <- acmeHttpJwsPost AcmeDirectoryRequestNewOrder ord
loc <- resHeaderAsURL "Location" res
return (loc, resBody res)
-- :: X509.SignedCertificate
newOrd <- resBody res
return (loc, newOrd)
acmePerformGetOrder :: URL -> CragT AcmeObjOrder
acmePerformGetOrder url = resBody <$> acmeHttpGet url
acmePerformGetOrder url = resBody =<< acmeHttpGet url
acmePerformWaitUntilOrderValid :: URL -> CragT AcmeObjOrder
acmePerformWaitUntilOrderValid url = poll
......@@ -174,7 +172,7 @@ acmePerformGetAuthorizations =
mapM acmePerformGetAuthorization . acmeObjOrderAuthorizations
acmePerformGetAuthorization :: URL -> CragT AcmeObjAuthorization
acmePerformGetAuthorization url = resBody <$> acmeHttpGet url
acmePerformGetAuthorization url = resBody =<< acmeHttpGet url
data ChallengeReaction = ChallengeReaction
{ fulfill :: AcmeObjIdentifier -> AcmeKeyAuthorization -> IO ()
......@@ -184,7 +182,7 @@ data ChallengeReaction = ChallengeReaction
acmePerformChallengeReaction ::
[(String, ChallengeReaction)] -> [AcmeObjAuthorization] -> CragT ()
acmePerformChallengeReaction reactions authzs = do
ops <- mapM reaction authzs'
ops <- mapM findReaction authzs'
sequence_
[ do keyAuthz <- acmeKeyAuthorization challenge
let identifier = acmeObjAuthorizationIdentifier authz
......@@ -194,10 +192,10 @@ acmePerformChallengeReaction reactions authzs = do
]
where
authzs' = filter ((== "pending") . acmeObjAuthorizationStatus) authzs
reaction ::
findReaction ::
AcmeObjAuthorization
-> CragT (AcmeObjAuthorization, AcmeObjChallenge, ChallengeReaction)
reaction authz =
findReaction authz =
case listToMaybe
[ (authz, challenge, reaction)
| challenge <- acmeObjAuthorizationChallenges authz
......@@ -214,7 +212,7 @@ acmePerformFinalizeOrder order =
acmePerformFinalizeOrder' :: URL -> Base64Octets -> CragT AcmeObjOrder
acmePerformFinalizeOrder' url csr =
resBody <$> acmeHttpJwsPostUrl url (AcmeObjFinalizeOrder csr)
resBody =<< acmeHttpJwsPostUrl url (AcmeObjFinalizeOrder csr)
-- | Respond to challenge
acmeChallengeRespond ::
......@@ -224,16 +222,15 @@ acmeChallengeRespond ::
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
catchError res (handler k)
where
handler k e = do
_ <- liftIO $ cleanup k
throw (e :: AcmeErr)
throwError e
-- | Revoke
acmePerformRevokeCertificate :: AcmeObjRevokeCertificate -> CragT ()
......
module Network.ACME.Errors where
module Network.ACME.Error where
import Crypto.JOSE
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Exception
import Network.ACME.Object
import Network.HTTP.Client
import Network.HTTP.Types
......@@ -57,8 +56,6 @@ data AcmeErr
| AcmeErrHeaderNotFound HeaderName
deriving (Show)
instance Exception AcmeErr
data AcmeDirectoryRequest
= AcmeDirectoryRequestRevokeCert
| AcmeDirectoryRequestNewOrder
......
module Network.ACME.HTTPS.Internal where
import Control.Exception.Lifted (handle, throw)
import Control.Monad.Except (ExceptT, catchError, lift, throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (asks)
import Control.Monad.State (gets, modify)
......@@ -9,7 +9,6 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.CaseInsensitive (CI, mk)
import Data.Default.Class (def)
import Data.Maybe (fromMaybe)
import Data.PEM (pemContent, pemParseLBS)
import Data.Time
( UTCTime
......@@ -39,7 +38,7 @@ import Network.HTTP.Types
)
import Text.Read (readMaybe)
import Network.ACME.Errors
import Network.ACME.Error
import Network.ACME.JWS
import Network.ACME.Object
import Network.ACME.Type
......@@ -50,8 +49,9 @@ maxRetries = 20
-- * Operations
-- | Get all supported resources from server
acmePerformDirectory :: URL -> Manager -> IO AcmeObjDirectory
acmePerformDirectory acmeReq manager = resBody <$> acmeHttpGet' acmeReq manager
acmePerformDirectory :: URL -> Manager -> ExceptT AcmeErr IO AcmeObjDirectory
acmePerformDirectory acmeReq manager =
resBody' =<< liftIO (acmeHttpGet' acmeReq manager)
-- | Get new nonce
acmePerformNonce :: CragT AcmeJwsNonce
......@@ -90,7 +90,7 @@ resHeaderAsURL x ys = do
case parseURL h of
Just u -> return u
Nothing ->
throw
throwError
AcmeErrDecodingHeader
{acmeErrHeaderName = show x, acmeErrHeaderValue = h}
......@@ -107,12 +107,16 @@ resRetryAfter r = do
parseHttpTime :: String -> Maybe UTCTime
parseHttpTime = parseTimeM True defaultTimeLocale "%a, %d %b %0Y %T GMT"
resBody :: FromJSON a => AcmeResponse -> a
resBody res =
resBody :: FromJSON a => AcmeResponse -> CragT a
resBody res = lift . lift $ resBody' res
resBody' :: FromJSON a => AcmeResponse -> ExceptT AcmeErr IO a
resBody' res =
case eitherDecode (responseBody res) of
Right x -> x
Right x -> return x
Left msg ->
throw AcmeErrDecodingBody {acmeErrMessage = msg, acmeErrBody = show res}
throwError
AcmeErrDecodingBody {acmeErrMessage = msg, acmeErrBody = show res}
parsePEMBody :: AcmeResponse -> [B.ByteString]
parsePEMBody res =
......@@ -140,7 +144,7 @@ acmeTGetNonce = do
acmeDictionaryUrl :: AcmeDirectoryRequest -> CragT URL
acmeDictionaryUrl req = do
url <- gets (acmeRequestUrl req . cragStateDirectory)
return $ fromMaybe (throw $ AcmeErrRequestNotSupported req) url
maybe (throwError $ AcmeErrRequestNotSupported req) return url
-- * Perform HTTPS
acmeHttpJwsPostNewAccount ::
......@@ -164,8 +168,8 @@ acmeHttpJwsPost' retried withKid url bod = do
nonce <- acmeTGetNonce
vJwkPublic <- asks (cragSetupJwkPublic . cragSetup)
vJwkPrivate <- asks (cragConfigJwk . cragConfig)
req <- liftIO $ acmeNewJwsBody bod url vJwkPrivate vJwkPublic nonce vKid
res <- handle handler $ acmeHttpPost url req
req <- lift . lift $ acmeNewJwsBody bod url vJwkPrivate vJwkPublic nonce vKid
res <- catchError (acmeHttpPost url req) handler
acmeTAddNonce res
return res
where
......@@ -174,8 +178,8 @@ acmeHttpJwsPost' retried withKid url bod = do
| errBadNonce e || retried >= maxRetries = do
acmeTSetNonce Nothing
acmeHttpJwsPost' (retried + 1) withKid url bod
| otherwise = throw e
handler e = throw e
| otherwise = throwError e
handler e = throwError e
accURL :: CragT (Maybe URL)
accURL
| withKid = Just <$> acmePerformFindAccountURL
......@@ -236,7 +240,7 @@ parseResult req bod resIO = do
then return res
else case eitherDecode (responseBody res) of
Right e ->
throw
throwError
AcmeErrDetail
{ acmeErrRequest = req
, acmeErrHttpStatus = responseStatus res
......@@ -244,7 +248,7 @@ parseResult req bod resIO = do
, acmeErrRequestBody = bod
}
Left msg ->
throw
throwError
AcmeErrDecodingProblemDetail
{ acmeErrHttpStatus = responseStatus res
, acmeErrMessage = msg
......
......@@ -5,7 +5,6 @@ import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Char
import Data.List
import GHC.Generics
import Language.Haskell.TH.Syntax (Dec, Name, Q, nameBase)
import Network.URI (URI, uriScheme)
......
{-|
<https://datatracker.ietf.org/doc/draft-ietf-acme-acme/ ACME>
and
<https://github.com/letsencrypt/boulder/blob/release/docs/acme-divergences.md Boulder>
are both devitating from the JWS Standard.
This module provides the necessary tweaks to the JOSE library.
* Boulder only supports the
<https://tools.ietf.org/html/rfc7515#page-21 "Flattened JWS JSON Serialization Syntax">.
See also the
<https://github.com/letsencrypt/boulder/issues/2532 issue against boulder>.
Therefore this module provides 'AcmeJws' that serializes to flattened jws.
* ACME uses an currently unregisterd header parameter "nonce".
The 'AcmeJwsHeader' supports the required header parameters.
JWS
-}
module Network.ACME.JWS
( module Network.ACME.JWS
......@@ -20,22 +7,16 @@ module Network.ACME.JWS
, Base64Octets(..)
) where
import Control.Exception (throw)
--import Control.Lens (Identity(..), Lens', view, review, set, (&), (?~), at)
import Control.Lens (Identity(..), review, set, view)
import Control.Lens.TH (makeLenses)
import Control.Monad.Except
import Crypto.JOSE
import Crypto.JOSE.Types (Base64Octets(..))
import Data.Aeson
import Control.Lens.TH (makeLenses)
--import Data.Aeson.Lens
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy (toStrict)
import Network.ACME.Errors
import Network.ACME.Error
import Network.ACME.Object (AcmeJwsNonce, URL, urlToString)
type AcmeJws = FlattenedJWS AcmeJwsHeader
......@@ -68,33 +49,32 @@ newAcmeJwsHeader ::
-> JWK -- ^ Public key
-> AcmeJwsNonce -- ^ Nonce
-> Maybe URL -- ^ Kid
-> AcmeJwsHeader Protection
-> Either AcmeErr (AcmeJwsHeader Protection)
newAcmeJwsHeader vUrl vJwkPrivate vJwkPublic vNonce vKid
-- Boulder sais
-- 'detail: signature type 'PS512' in JWS header is not supported'
=
AcmeJwsHeader
{ _acmeJwsHeader = setAuth $ newJWSHeader (Protected, bestAlg)
, _acmeJwsHeaderNonce = vNonce
, _acmeJwsHeaderUrl = vUrl
}
= do
vBestAlg <- bestAlg
return
AcmeJwsHeader
{ _acmeJwsHeader = setAuth $ newJWSHeader (Protected, vBestAlg)
, _acmeJwsHeaderNonce = vNonce
, _acmeJwsHeaderUrl = vUrl
}
where
bestAlg =
case bestJWSAlg vJwkPrivate of
Right PS512 -> RS256
Right x -> x
Left e -> throw $ AcmeErrJws e
Right PS512 -> return RS256
Right x -> return x
Left e -> throwError $ AcmeErrJws e
setAuth =
case vKid of
Just k -> set kid (Just $ HeaderParam Protected (urlToString k))
Nothing -> set jwk (Just $ HeaderParam Protected vJwkPublic)
-- | Removes private key
jwkPublic :: AsPublicKey a => a -> a
jwkPublic vJwk =
case view asPublicKey vJwk of
Nothing -> throw AcmeErrJwkNoPubkey
Just k -> k
jwkPublic :: AsPublicKey a => a -> Either AcmeErr a
jwkPublic = maybe (Left AcmeErrJwkNoPubkey) return . view asPublicKey
{-|
Creates a signed JWS object in ACME format. This implies interaction with the
......@@ -108,12 +88,10 @@ acmeNewJwsBody ::
-> JWK
-> AcmeJwsNonce
-> Maybe URL
-> IO AcmeJws
-> ExceptT AcmeErr IO AcmeJws
acmeNewJwsBody vObj vUrl vJwkPrivate vJwkPublic vNonce vKid = do
res <- runExceptT $ signJWS payload (Identity (vHeader, vJwkPrivate))
case res of
Left e -> throw $ AcmeErrJws e
Right r -> return r
xh <- either throwError return vHeader
withExceptT AcmeErrJws $ signJWS payload (Identity (xh, vJwkPrivate))
where
vHeader = newAcmeJwsHeader vUrl vJwkPrivate vJwkPublic vNonce vKid
payload = toStrict $ encode vObj
......
......@@ -6,20 +6,20 @@ import Control.Monad.State (StateT, runStateT)
import Crypto.JOSE (JWK)
import Network.HTTP.Client (Manager)
import Network.ACME.Errors
import Network.ACME.Error
import Network.ACME.Object
-- ** Monad Transformer
type CragT = ExceptT AcmeErr (StateT CragState (ReaderT CragReader IO))
type CragT = StateT CragState (ReaderT CragReader (ExceptT AcmeErr IO))
runCragT ::
CragT a -> (CragReader, CragState) -> IO (Either AcmeErr a, CragState)
runCragT x (r, s) = (`runReaderT` r) $ (`runStateT` s) $ runExceptT x
CragT a -> (CragReader, CragState) -> IO (Either AcmeErr (a, CragState))
runCragT x (r, s) = runExceptT $ (`runReaderT` r) $ (`runStateT` s) x
evalCragT :: CragT a -> (CragReader, CragState) -> IO (Either AcmeErr a)
evalCragT x v = do
(o, _) <- runCragT x v
return o
o <- runCragT x v
return (fst <$> o)
-- ** Client Configuration
data CragConfig = CragConfig
......
......@@ -3,6 +3,7 @@ module TestIntegration
) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
import Crypto.Hash (SHA512(SHA512))
import Crypto.PubKey.RSA (generate)
......@@ -52,7 +53,7 @@ testNewAccount =
testCase "Account operations" $ do
(acc, jwk) <- acmeNewObjAccountStub "email1@example.org"
manager <- newUnsafeTestManager
state <- acmePerformRunner' manager (config jwk)
(Right state) <- runExceptT $ acmePerformRunner' manager (config jwk)
flip evalCragT state $ do
_ <- acmePerformCreateAccount acc
url <- acmePerformFindAccountURL
......@@ -67,7 +68,7 @@ testOrderNew =
httpServerLiveConf <- newIORef []
_ <- forkIO $ myHttpServer httpServerLiveConf
manager <- newUnsafeTestManager
state <- acmePerformRunner' manager (config jwk)
(Right state) <- runExceptT $ acmePerformRunner' manager (config jwk)
res <-
flip evalCragT state $ do
let domains = ["localhost"] --, "ip6-localhost", "ip6-loopback"]
......
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