Relax aff to m
This commit is contained in:
parent
f928e1b988
commit
01cf6ca842
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user