Define RequestState and ResponseState kinds and integrates them into repo; code cleanup

.gitignore

@@ -6,3 +6,4 @@
 /src/.webpack.js
 /.psc-ide-port
 /.spago
+/generated-docs/

docs/src/topic-guides/FormSerialization.purs

@@ -1,22 +1,23 @@
 module FormSerialization where
 
 import Prelude
-import Data.Int as Int
-import Control.Monad.Indexed ((:>>=), (:*>))
-import Effect (Effect)
+
 import Control.Monad.Error.Class (throwError)
+import Control.Monad.Indexed ((:>>=), (:*>))
 import Data.Either (Either(..))
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Eq (genericEq)
 import Data.Generic.Rep.Show (genericShow)
 import Data.HTTP.Method (Method(..))
+import Data.Int as Int
 import Data.Maybe (maybe)
-import Hyper.Conn (Conn)
+import Effect (Effect)
+import Hyper.Conn (BodyRead, BodyUnread, Conn, ResponseEnded, StatusLineOpen)
 import Hyper.Form (class FromForm, parseFromForm, required)
 import Hyper.Middleware (Middleware)
 import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
-import Hyper.Request (class ReadableBody, class Request, getRequestData)
-import Hyper.Response (class Response, class ResponseWritable, ResponseEnded, StatusLineOpen, closeHeaders, respond, writeStatus)
+import Hyper.Request (class ReadableBody, class Request, getRequestData, ignoreBody)
+import Hyper.Response (class Response, class ResponseWritable, closeHeaders, respond, writeStatus)
 import Hyper.Status (statusBadRequest, statusMethodNotAllowed)
 
 -- start snippet datatypes
@@ -61,8 +62,8 @@ onPost
   => FromForm Order
   => Middleware
      m
-     (Conn req (res StatusLineOpen) c)
-     (Conn req (res ResponseEnded) c)
+     (Conn req BodyUnread res StatusLineOpen c)
+     (Conn req BodyRead res ResponseEnded c)
      Unit
 -- start snippet onPost
 onPost =
@@ -92,11 +93,13 @@ main =
       case _ of
         Left POST -> onPost
         Left method ->
-          writeStatus statusMethodNotAllowed
+          ignoreBody
+          :*> writeStatus statusMethodNotAllowed
           :*> closeHeaders
           :*> respond ("Method not supported: " <> show method)
         Right customMethod ->
-          writeStatus statusMethodNotAllowed
+          ignoreBody
+          :*> writeStatus statusMethodNotAllowed
           :*> closeHeaders
           :*> respond ("Custom method not supported: " <> show customMethod)
 

docs/src/topic-guides/ReadBody.purs

@@ -1,15 +1,16 @@
 module ReadBody where
 
 import Prelude
+
 import Control.Monad.Indexed ((:>>=), (:*>))
-import Effect (Effect)
 import Data.Either (Either(..))
 import Data.HTTP.Method (Method(..))
-import Hyper.Conn (Conn)
+import Effect (Effect)
+import Hyper.Conn (BodyRead, BodyUnread, Conn, ResponseEnded, StatusLineOpen)
 import Hyper.Middleware (Middleware)
 import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
-import Hyper.Request (class ReadableBody, getRequestData, readBody)
-import Hyper.Response (class Response, class ResponseWritable, ResponseEnded, StatusLineOpen, closeHeaders, respond, writeStatus)
+import Hyper.Request (class ReadableBody, getRequestData, ignoreBody, readBody)
+import Hyper.Response (class Response, class ResponseWritable, closeHeaders, respond, writeStatus)
 import Hyper.Status (statusBadRequest, statusMethodNotAllowed)
 
 onPost
@@ -20,8 +21,8 @@ onPost
   => ResponseWritable b m String
   => Middleware
      m
-     (Conn req (res StatusLineOpen) c)
-     (Conn req (res ResponseEnded) c)
+     (Conn req BodyUnread res StatusLineOpen c)
+     (Conn req BodyRead res ResponseEnded c)
      Unit
 -- start snippet onPost
 onPost =
@@ -45,11 +46,13 @@ main =
       case _ of
         Left POST -> onPost
         Left method ->
-          writeStatus statusMethodNotAllowed
+          ignoreBody
+          :*> writeStatus statusMethodNotAllowed
           :*> closeHeaders
           :*> respond ("Method not supported: " <> show method)
         Right customMethod ->
-          writeStatus statusMethodNotAllowed
+          ignoreBody
+          :*> writeStatus statusMethodNotAllowed
           :*> closeHeaders
           :*> respond ("Custom method not supported: " <> show customMethod)
 

examples/AuthenticationAndAuthorization.purs

@@ -10,41 +10,38 @@ module Examples.AuthenticationAndAuthorization where
 import Prelude
 
 import Control.Monad.Indexed ((:>>=), (:*>))
-import Effect.Aff.Class (class MonadAff)
-import Effect (Effect)
 import Data.Either (Either(..))
 import Data.HTTP.Method (Method(GET))
 import Data.Maybe (Maybe(Nothing, Just))
 import Data.MediaType.Common (textHTML)
 import Data.Tuple (Tuple(Tuple))
-import Hyper.Authorization (authorized)
-import Hyper.Conn (Conn)
-import Hyper.Middleware (Middleware)
+import Effect (Effect)
+import Effect.Aff.Class (class MonadAff)
+import Hyper.Authentication (AUTHENTICATION_ROWS)
+import Hyper.Authorization (AUTHORIZATION_ROWS, authorized)
+import Hyper.Conn (Conn, ResponseEnded, ResponseTransition, StatusLineOpen, ResponseTransition', kind ResponseState)
 import Hyper.Middleware.Class (getConn)
 import Hyper.Node.BasicAuth as BasicAuth
 import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
 import Hyper.Request (class Request, getRequestData)
-import Hyper.Response (class Response, class ResponseWritable, ResponseEnded, StatusLineOpen, closeHeaders, contentType, respond, writeStatus)
+import Hyper.Response (class Response, class ResponseWritable, closeHeaders, contentType, respond, writeStatus)
 import Hyper.Status (Status, statusNotFound, statusOK)
 import Text.Smolder.HTML (a, h1, li, p, section, ul)
 import Text.Smolder.HTML.Attributes as A
 import Text.Smolder.Markup (Markup, text, (!))
 import Text.Smolder.Renderer.String (render)
+import Type.Row (type (+))
 
 
 -- Helper for responding with HTML.
 htmlWithStatus
-  :: forall m req res b c
+  :: forall m req reqState res b c
   .  Monad m
   => Response res m b
   => ResponseWritable b m String
   => Status
   -> Markup Unit
-  -> Middleware
-     m
-     (Conn req (res StatusLineOpen) c)
-     (Conn req (res ResponseEnded) c)
-     Unit
+  -> ResponseTransition m req reqState res StatusLineOpen ResponseEnded c Unit
 htmlWithStatus status x =
   writeStatus status
   :*> contentType textHTML
@@ -67,15 +64,14 @@ data Admin = Admin
 -- A handler that does not require an authenticated user, but displays the
 -- name if the user _is_ authenticated.
 profileHandler
-  :: forall m req res b c
+  :: forall m req reqState res b c
   .  Monad m
   => Response res m b
   => ResponseWritable b m String
-  => Middleware
-     m
-     (Conn req (res StatusLineOpen) { authentication :: Maybe User | c })
-     (Conn req (res ResponseEnded) { authentication :: Maybe User | c })
-     Unit
+  => ResponseTransition m req reqState res
+      StatusLineOpen ResponseEnded
+      { | AUTHENTICATION_ROWS (Maybe User) c }
+      Unit
 profileHandler =
   getConn :>>= \conn →
   htmlWithStatus
@@ -101,15 +97,14 @@ profileHandler =
 -- place . You simply mark the requirement in the type signature,
 -- as seen below.
 adminHandler
-  :: forall m req res b c
+  :: forall m req reqState res b c
   .  Monad m
   => Response res m b
   => ResponseWritable b m String
-  => Middleware
-     m
-     (Conn req (res StatusLineOpen) { authorization :: Admin, authentication :: User | c })
-     (Conn req (res ResponseEnded) { authorization :: Admin, authentication :: User | c })
-     Unit
+  => ResponseTransition m req reqState res
+      StatusLineOpen ResponseEnded
+      { | AUTHORIZATION_ROWS Admin + AUTHENTICATION_ROWS User c }
+      Unit
 adminHandler =
   getConn :>>= \conn →
   htmlWithStatus
@@ -137,38 +132,28 @@ userFromBasicAuth =
 
 -- This could be a function checking a database, or some session store, if the
 -- authenticated user has role `Admin`.
-getAdminRole :: forall m req res c.
+getAdminRole :: forall m req reqState res c (resState :: ResponseState).
                 Monad m =>
-                Conn
-                req
-                res
-                { authentication :: User , authorization :: Unit | c }
+                Conn req reqState res resState { | AUTHORIZATION_ROWS Unit
+                                                + AUTHENTICATION_ROWS User c
+                                               }
              -> m (Maybe Admin)
 getAdminRole conn =
   case conn.components.authentication of
     User { name: "admin" } -> pure (Just Admin)
     _ -> pure Nothing
 
 
-app :: forall m req res b c
+app :: forall m req reqState res b c
     .  MonadAff m
     => Request req m
     => Response res m b
     => ResponseWritable b m String
-    => Middleware
-       m
-       (Conn req
-             (res StatusLineOpen)
-             { authentication :: Unit
-             , authorization :: Unit
-             | c
-             })
-       (Conn req
-             (res ResponseEnded)
-             { authentication :: Maybe User
-             , authorization :: Unit
-             | c
-             })
+    => ResponseTransition' m req reqState res
+        StatusLineOpen
+        ResponseEnded
+        { | AUTHORIZATION_ROWS Unit + AUTHENTICATION_ROWS Unit c }
+        { | AUTHORIZATION_ROWS Unit + AUTHENTICATION_ROWS (Maybe User) c }
        Unit
 app = BasicAuth.withAuthentication userFromBasicAuth :>>= \_ → router
     where

examples/FormParser.purs

@@ -1,23 +1,27 @@
 module Examples.FormParser where
 
 import Prelude
-import Text.Smolder.HTML.Attributes as A
+
+import Control.Bind.Indexed (ibind)
 import Control.Monad.Indexed ((:>>=), (:*>))
-import Effect (Effect)
-import Effect.Class (liftEffect)
-import Effect.Console (log)
 import Data.Either (Either(Right, Left))
 import Data.HTTP.Method (Method(..))
 import Data.Maybe (Maybe(Nothing, Just))
 import Data.MediaType.Common (textHTML)
 import Data.String (length)
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Console (log)
+import Hyper.Conn (BodyRead, BodyUnread, ConnTransition, ResponseEnded, ResponseTransition, StatusLineOpen)
 import Hyper.Form (parseForm, required)
-import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
-import Hyper.Request (getRequestData)
+import Hyper.Node.Server (HttpRequest, HttpResponse, defaultOptionsWithLogging, runServer)
+import Hyper.Request (getRequestData, ignoreBody)
 import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
-import Hyper.Status (statusBadRequest, statusMethodNotAllowed, statusOK)
+import Hyper.Status (Status, statusBadRequest, statusMethodNotAllowed, statusOK)
 import Text.Smolder.HTML (button, form, input, label, p)
-import Text.Smolder.Markup (text, (!))
+import Text.Smolder.HTML.Attributes as A
+import Text.Smolder.Markup (Markup, text, (!))
 import Text.Smolder.Renderer.String (render)
 
 main :: Effect Unit
@@ -39,50 +43,64 @@ main =
             Just s -> p ! A.style "color: red;" $ text s
             Nothing -> pure unit
 
+    htmlWithStatus :: forall reqState comp
+                    . Status
+                   -> Markup _
+                   -> ResponseTransition Aff HttpRequest reqState
+                        HttpResponse StatusLineOpen ResponseEnded
+                        comp
+                        Unit
     htmlWithStatus status x =
       writeStatus status
       :*> contentType textHTML
       :*> closeHeaders
       :*> respond (render x)
 
+    handlePost :: forall comp
+                . ConnTransition
+                    Aff
+                    HttpRequest BodyUnread BodyRead
+                    HttpResponse StatusLineOpen ResponseEnded
+                    comp
+                    Unit
     handlePost =
       parseForm :>>=
       case _ of
         Left err -> do
           liftEffect (log err)
-          :*> htmlWithStatus
-              statusBadRequest
-              (p (text "Bad request, invalid form."))
+          :*> htmlWithStatus statusBadRequest
+                (p (text "Bad request, invalid form."))
         Right form ->
           case required "firstName" form of
             Right name
               | length name > 0 ->
-                htmlWithStatus
-                statusOK
-                (p (text ("Hi " <> name <> "!")))
+                htmlWithStatus statusOK (p (text ("Hi " <> name <> "!")))
               | otherwise ->
-                htmlWithStatus
-                statusBadRequest
-                (renderNameForm (Just "Name cannot be empty."))
+                htmlWithStatus statusBadRequest
+                  (renderNameForm (Just "Name cannot be empty."))
             Left err ->
-              htmlWithStatus
-              statusBadRequest
-              (renderNameForm (Just err))
+              htmlWithStatus statusBadRequest (renderNameForm (Just err))
 
     -- Our (rather primitive) router.
-    router =
-      _.method <$> getRequestData :>>=
-      case _ of
-        Left GET ->
-          htmlWithStatus
-          statusOK
-          (renderNameForm Nothing)
-        Left POST ->
+    router :: forall comp
+                . ConnTransition
+                    Aff
+                    HttpRequest BodyUnread BodyRead
+                    HttpResponse StatusLineOpen ResponseEnded
+                    comp
+                    Unit
+    router = let bind = ibind in do
+      reqData <- getRequestData
+      case reqData.method of
+        Left GET -> do
+          _ <- ignoreBody
+          htmlWithStatus statusOK (renderNameForm Nothing)
+        Left POST -> do
           handlePost
-        method ->
-          htmlWithStatus
-          statusMethodNotAllowed
-          (text ("Method not supported: " <> show method))
+        method -> do
+          _ <- ignoreBody
+          htmlWithStatus statusMethodNotAllowed
+            (text ("Method not supported: " <> show method))
 
   -- Let's run it.
   in runServer defaultOptionsWithLogging {} router