Add json request parsing

- Use json drivers to support different json libraries like argonaut or
  yoga-json
- Use continuations to simplify parsing and short-circuit bad requests

CHANGELOG.md

@@ -0,0 +1,20 @@
+# Changelog
+
+## Unpublished
+
+- Add json request parsing simplifications
+
+## v1.1.0
+
+- Add routing exports to simplify usage
+
+## v1.0.0
+
+- Add HMR example
+- Add `justifill` to simplify startup options
+- Switch routing to `routing-duplex`
+- Initial fork from `httpure`. New project name is `httpurple`
+
+## v0.15.0
+
+- Update to purescript v0.15.0

Readme.md

@@ -100,6 +100,7 @@ HTTPurple 🪁 is a fork of [HTTPure](https://github.com/citizennet/purescript-h
 If you have used HTTPure before, you'll probably want to go through the following changes to get started using HTTPurple 🪁:
 * [routing-duplex](#routing-duplex)
 * [startup options](#startup-options)
+* [request parsing and validation](#request-parsing-and-validation)
 * [other improvements](#other-improvmenets)
 * [hot module reloading](#hot-module-reloading)
 
@@ -210,6 +211,26 @@ main =
   notFoundHandler = const $ ok "Nothing to see here"
 ```
 
+### Request parsing and validation
+
+HTTPurple 🪁 makes request parsing and validation super simple. My typical http service scenario looks like this: 
+1. Parse the request json and return a bad request if the request body doesn't contain the valid json format
+2. Validate the json input semanticall and transform it into some kind of internal model. Return bad request (with some error code) in case it is invalid.
+3. Do something with the request
+4. Return the output as a json
+
+HTTPurple 🪁 uses continuations to make this standard scenario straight-forward (see example below).
+
+Furthermore, HTTPurple 🪁 doesn't mandate a json parsing library. So you can use [`argonaut`](https://github.com/purescript-contrib/purescript-argonaut) using the [`argonaut-driver`](https://github.com/sigma-andex/purescript-httpurple-argonaut), use [`yoga-json`](https://github.com/rowtype-yoga/purescript-yoga-json) using the `yoga-json-driver` (coming soon...) or write your own json driver.
+
+Here is an example how that looks like:
+```purescript
+apiRouter { route: Home, method: Post, body } = usingCont do
+    req@{ name } :: RootPostRequest <- fromJson Argonaut.jsonDecoder body
+    ok $ "hello " <> name <> "!"
+```
+In case `fromJson` succeeds, the next step will be executed, otherwise a 400 bad request is returned. 
+
 ### Other improvmenets
 
 * Default closing handler - A default closing handler is provided so you can just stop your server using `ctrl+x` without having to worry about anything. You can deactivate it by setting `closingHandler: NoClosingHandler` in the listen options.

spago.dhall

@@ -28,6 +28,7 @@
   , "refs"
   , "routing-duplex"
   , "strings"
+  , "transformers"
   , "tuples"
   , "type-equality"
   , "typelevel-prelude"

src/HTTPure.purs

@@ -1,6 +1,8 @@
 module HTTPurple
   ( module HTTPurple.Body
+  , module HTTPurple.Cont
   , module HTTPurple.Headers
+  , module HTTPurple.Json
   , module HTTPurple.Lookup
   , module HTTPurple.Method
   , module HTTPurple.Path
@@ -18,7 +20,9 @@ module HTTPurple
 
 import Data.Generic.Rep (class Generic)
 import HTTPurple.Body (toBuffer, toStream, toString)
+import HTTPurple.Cont (usingCont)
 import HTTPurple.Headers (Headers, empty, header, headers)
+import HTTPurple.Json (JsonDecoder(..), fromJson, jsonHeader, jsonHeaders)
 import HTTPurple.Lookup (at, has, lookup, (!!), (!?), (!@))
 import HTTPurple.Method (Method(..))
 import HTTPurple.Path (Path)

src/HTTPurple/Body.purs

@@ -112,7 +112,7 @@ class Body b where
 -- | `Content-Length` header properly accounts for UTF-8 characters in the
 -- | string.  Writing is simply implemented by writing the string to the
 -- | response stream and closing the response stream.
-instance bodyString :: Body String where
+instance Body String where
   defaultHeaders body = do
     buf :: Buffer <- fromString body UTF8
     defaultHeaders buf
@@ -124,7 +124,7 @@ instance bodyString :: Body String where
 -- | The instance for `Buffer` is trivial--we add a `Content-Length` header
 -- | using `Buffer.size`, and to send the response, we just write the buffer to
 -- | the stream and end the stream.
-instance bodyBuffer :: Body Buffer where
+instance Body Buffer where
   defaultHeaders buf = header "Content-Length" <$> show <$> size buf
   write body response = makeAff \done -> do
     let stream = responseAsStream response
@@ -134,7 +134,7 @@ instance bodyBuffer :: Body Buffer where
 -- | This instance can be used to send chunked data.  Here, we add a
 -- | `Transfer-Encoding` header to indicate chunked data.  To write the data, we
 -- | simply pipe the newtype-wrapped `Stream` to the response.
-instance bodyChunked ::
+instance
   TypeEquals (Stream r) (Readable s) =>
   Body (Stream r) where
   defaultHeaders _ = pure $ header "Transfer-Encoding" "chunked"

src/HTTPurple/Cont.purs

@@ -0,0 +1,10 @@
+module HTTPurple.Cont
+  ( usingCont
+  ) where
+
+import Prelude
+
+import Control.Monad.Cont (ContT, runContT)
+
+usingCont :: forall output m. Applicative m => ContT output m output -> m output
+usingCont = flip runContT pure

src/HTTPurple/Json.purs

@@ -0,0 +1,55 @@
+module HTTPurple.Json
+  ( JsonDecoder(..)
+  , fromJson
+  , fromJsonE
+  , jsonHeader
+  , jsonHeaders
+  ) where
+
+import Prelude
+
+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')
+
+newtype JsonDecoder err json = JsonDecoder (String -> Either err json)
+
+instance Newtype (JsonDecoder err json) (String -> Either err json)
+
+jsonHeader :: Tuple String String
+jsonHeader = Tuple "Content-Type" "application/json"
+
+jsonHeaders :: Headers
+jsonHeaders = headers [ jsonHeader ]
+
+fromJsonContinuation ::
+  forall err json.
+  JsonDecoder err json ->
+  (err -> ResponseM) ->
+  RequestBody ->
+  (json -> ResponseM) ->
+  ResponseM
+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
+
+defaultErrorHandler :: forall (t47 :: Type) (m :: Type -> Type). MonadAff m => t47 -> m Response
+defaultErrorHandler = const $ badRequest' jsonHeaders ""
+
+fromJsonE :: forall (err :: Type) (json :: Type). JsonDecoder err json -> (err -> ResponseM) -> RequestBody -> ContT Response Aff json
+fromJsonE driver errorHandler body = ContT $ (fromJsonContinuation driver errorHandler body)
+
+fromJson :: forall (err :: Type) (json :: Type). JsonDecoder err json -> RequestBody -> ContT Response Aff json
+fromJson driver = fromJsonE driver defaultErrorHandler
+