Relax aff to m

This commit is contained in:
sigma-andex 2022-06-05 20:31:13 +01:00
parent f928e1b988
commit 01cf6ca842
2 changed files with 16 additions and 15 deletions

View File

@ -15,6 +15,7 @@ import Data.Either (Either(Right))
import Data.Maybe (Maybe(Just, Nothing))
import Effect (Effect)
import Effect.Aff (Aff, makeAff, nonCanceler)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (liftEffect)
import Effect.Ref (Ref)
import Effect.Ref (modify, new, read, write) as Ref
@ -48,7 +49,7 @@ read request = do
-- |
-- | This drains the `Readable` stream in `RequestBody` for the first time
-- | and returns cached result from then on.
toString :: RequestBody -> Aff String
toString :: forall m. MonadAff m => RequestBody -> m String
toString requestBody = do
maybeString <-
liftEffect
@ -67,7 +68,7 @@ toString requestBody = do
-- |
-- | This drains the `Readable` stream in `RequestBody` for the first time
-- | and returns cached result from then on.
toBuffer :: RequestBody -> Aff Buffer
toBuffer :: forall m. MonadAff m => RequestBody -> m Buffer
toBuffer requestBody = do
maybeBuffer <-
liftEffect
@ -81,9 +82,9 @@ toBuffer requestBody = do
Just buffer -> pure buffer
where
-- | Slurp the entire `Readable` stream into a `Buffer`
streamToBuffer :: Readable () -> Aff Buffer
streamToBuffer :: MonadAff m => Readable () -> m Buffer
streamToBuffer stream =
makeAff \done -> do
liftAff $ makeAff \done -> do
bufs <- Ref.new []
onData stream \buf -> void $ Ref.modify (_ <> [ buf ]) bufs
onEnd stream do

View File

@ -12,11 +12,10 @@ import Control.Monad.Cont (ContT(..))
import Data.Either (Either, either)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..))
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import HTTPurple.Body (RequestBody, toString)
import HTTPurple.Headers (Headers, headers)
import HTTPurple.Response (Response, ResponseM, badRequest')
import HTTPurple.Response (Response, badRequest')
newtype JsonDecoder err json = JsonDecoder (String -> Either err json)
@ -29,33 +28,34 @@ jsonHeaders :: Headers
jsonHeaders = headers [ jsonHeader ]
fromJsonContinuation ::
forall err json.
forall err json m.
MonadAff m =>
JsonDecoder err json ->
(err -> ResponseM) ->
(err -> m Response) ->
RequestBody ->
(json -> ResponseM) ->
ResponseM
(json -> m Response) ->
m Response
fromJsonContinuation (JsonDecoder decode) errorHandler body handler = do
bodyStr <- toString body
let
parseJson :: Either err json
parseJson = decode $ bodyStr
toBadRequest err = errorHandler err
either toBadRequest handler parseJson
either errorHandler handler parseJson
defaultErrorHandler :: forall (t47 :: Type) (m :: Type -> Type). MonadAff m => t47 -> m Response
defaultErrorHandler :: forall (err :: Type) (m :: Type -> Type). MonadAff m => err -> m Response
defaultErrorHandler = const $ badRequest' jsonHeaders ""
-- | Parse the `RequestBody` as json using the provided `JsonDecoder`.
-- | If it fails, the error handler is called.
-- | Returns a continuation
fromJsonE :: forall (err :: Type) (json :: Type). JsonDecoder err json -> (err -> ResponseM) -> RequestBody -> ContT Response Aff json
fromJsonE :: forall (err :: Type) (json :: Type) (m :: Type -> Type).
MonadAff m => JsonDecoder err json -> (err -> m Response) -> RequestBody -> ContT Response m json
fromJsonE driver errorHandler body = ContT $ (fromJsonContinuation driver errorHandler body)
-- | Parse the `RequestBody` as json using the provided `JsonDecoder`.
-- | If it fails, an empty bad request is returned
-- | Returns a continuation
fromJson :: forall (err :: Type) (json :: Type). JsonDecoder err json -> RequestBody -> ContT Response Aff json
fromJson :: forall (err :: Type) (json :: Type) (m :: Type -> Type). MonadAff m => JsonDecoder err json -> RequestBody -> ContT Response m json
fromJson driver = fromJsonE driver defaultErrorHandler