FormSerialization.purs

module FormSerialization where

import Prelude

import Control.IxMonad ((:>>=), (:*>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
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 Hyper.Form (Form(..), parseForm, required)
import Hyper.Form.Urlencoded (defaultOptions)
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.Status (statusBadRequest, statusMethodNotAllowed)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

-- start snippet datatypes
data MealType = Vegan | Vegetarian | Omnivore | Carnivore

derive instance genericMealType :: Generic MealType _
instance eqMealType :: Eq MealType where eq = genericEq
instance showMealType :: Show MealType where show = genericShow

newtype Order = Order { beers :: Int, meal :: MealType }
-- end snippet datatypes

-- start snippet parsing
parseOrder :: Form -> Either String Order
parseOrder form = do
  beers <- required "beers" form >>= parseBeers
  meal <- required "meal" form >>= parseMealType
  pure (Order { beers: beers, meal: meal })
  where
    parseBeers s =
      maybe
      (throwError ("Invalid number: " <> s))
      pure
      (Int.fromString s)

    parseMealType =
      case _ of
        "Vegan" -> pure Vegan
        "Vegetarian" -> pure Vegetarian
        "Omnivore" -> pure Omnivore
        "Carnivore" -> pure Carnivore
        s -> throwError ("Invalid meal type: " <> s)
-- end snippet parsing

onPost
  :: forall m b req res c
  .  Monad m
  => Request req m
  => ReadableBody req m String
  => Response res m b
  => ResponseWritable b m String
  => Middleware
     m
     (Conn req (res StatusLineOpen) c)
     (Conn req (res ResponseEnded) c)
     Unit
-- start snippet onPost
onPost =
  parseForm defaultOptions :>>=
  (_ >>= parseOrder) >>> case _ of
    Left err ->
      writeStatus statusBadRequest
      :*> closeHeaders
      :*> respond (err <> "\n")
    Right (Order { beers, meal })
      | meal == Omnivore || meal == Carnivore ->
        writeStatus statusBadRequest
        :*> closeHeaders
        :*> respond "Sorry, we do not serve meat here.\n"
      | otherwise ->
        writeStatus statusBadRequest
        :*> closeHeaders
        :*> respond ("One " <> show meal <> " meal and "
                     <> show beers <> " beers coming up!\n")
-- end snippet onPost

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, exception :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main =
  let
    router =
      _.method <$> getRequestData :>>=
      case _ of
        Left POST -> onPost
        Left method ->
          writeStatus statusMethodNotAllowed
          :*> closeHeaders
          :*> respond ("Method not supported: " <> show method)
        Right customMethod ->
          writeStatus statusMethodNotAllowed
          :*> closeHeaders
          :*> respond ("Custom method not supported: " <> show customMethod)

  -- Let's run it.
  in runServer defaultOptionsWithLogging {} router