Since then I did some iterations and actualy end up with similar solution, but as you rightly pointed out, there is something wrong with AppM to by more specific, I’m trying to implement ReaderT pattern… Here is whole code:
module Main where
import Prelude
import Control.Monad.Indexed.Qualified as Ix
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Reader.Class (class MonadAsk)
import Data.Number as Number
import Data.Maybe (Maybe(Just, Nothing))
import Data.Either (Either(Right, Left))
import Data.HTTP.Method (Method(GET, POST))
import Data.DateTime (DateTime)
import Effect (Effect)
import Effect.Aff (Aff)
import Hyper.Middleware (Middleware)
import Hyper.Node.Server (defaultOptionsWithLogging, runServer', HttpRequest, HttpResponse)
import Hyper.Response (closeHeaders, respond, writeStatus, StatusLineOpen, ResponseEnded)
import Hyper.Request (getRequestData)
import Hyper.Status (Status, statusOK, statusBadRequest)
import Hyper.Form (Form, parseForm, required)
import Hyper.Conn (Conn)
import Text.Smolder.HTML (Html, html, p, form, label, input, button, div)
import Text.Smolder.HTML.Attributes (method, for, id, name, type')
import Text.Smolder.Markup (text, (!))
import Text.Smolder.Renderer.String (render)
import Database.PostgreSQL (Pool, PoolConfiguration, newPool, withConnection, execute, defaultPoolConfiguration, PGError, Connection, Row0 (Row0), Row3(Row3), Query(Query))
type ComponentsType = Record ()
type ConnHttp resp = Conn HttpRequest (HttpResponse resp) ComponentsType
type Env =
{ pool :: Pool
}
type AppM m = ReaderT Env m
getPool :: forall m. MonadAsk Env m => m Pool
getPool = asks _.pool
runAppM ∷ forall a. Env -> (AppM Aff a) -> Aff a
runAppM = flip runReaderT
config :: PoolConfiguration
config =
let default = defaultPoolConfiguration "purescript"
in default
{ host = Just "localhost"
, password = Just "postgres"
, user = Just "postgres"
}
send :: Status -> Html Unit -> Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
send status body = Ix.do
writeStatus status
closeHeaders
respond (render body)
greetTemplate :: String -> Html Unit
greetTemplate name = html (p (text $ "Hello " <> name))
formTemplate :: Html Unit
formTemplate =
html do
form ! method "post" $ do
label ! for "name" $ text "Name"
input ! id "name" ! name "name"
button $ text "Greet"
fruitForm :: Html Unit
fruitForm =
html do
form ! method "post" $ do
div do
label ! for "name" $ text "Name"
input ! id "name" ! name "name"
div do
label ! for "delicious" $ text "Delicious"
input ! id "delicious" ! name "delicious" ! type' "checkbox"
div do
label ! for "price" $ text "Price"
input ! id "price" ! name "price" ! type' "number"
button $ text "Save"
errorTemplate :: String -> Html Unit
errorTemplate error = html do
p (text error)
formHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
formHandler = send statusOK formTemplate
fruitNewHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
fruitNewHandler = send statusOK fruitForm
fruitCreateHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
fruitCreateHandler = Ix.do
eitherBodyParams <- parseForm
result <- pure $ getPool >>= \pool -> withConnection pool \eitherConn -> do
input <- pure $ do
conn <- case eitherConn of
Left e -> Left (show e)
Right a -> Right a
params <- eitherBodyParams
name <- required "name" params
delicious <- required "delicious" params
price <- required "price" params
pure $ {conn, params, name, delicious, price}
case input of
Right {conn, name, delicious, price} ->
execute conn (Query "INSERT INTO fruits (name, delicious, price) VALUE ($1, $2, $3)") (Row3 name (castBoolean delicious) (Number.fromString price))
Left e ->
pure $ mempty
badRequestHandler "Head"
castBoolean :: String -> Boolean
castBoolean value = value == "on"
badRequestHandler :: String -> Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
badRequestHandler message = send statusBadRequest (errorTemplate message)
postHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
postHandler = Ix.do
bodyData <- parseForm
case bodyData of
Right params -> case required "name" params of
Right name -> send statusOK (greetTemplate name)
_ -> badRequestHandler "Missing name"
_ -> badRequestHandler "Invalid Body"
handler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
handler = Ix.do
requestData <- getRequestData
case requestData.url of
"/fruits" ->
case requestData.method of
Left GET -> fruitNewHandler
_ -> badRequestHandler "Unsupported method"
_ ->
case requestData.method of
Left GET -> formHandler
Left POST -> postHandler
_ -> badRequestHandler "Unsupported method"
main :: Effect Unit
main = do
pool <- newPool config
runServer' defaultOptionsWithLogging {} (runAppM { pool: pool }) handler
Here is packages and spago dhall (in case anybody would like to try run it localy)
packages.dhall
let upstream =
https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20201007/packages.dhall sha256:35633f6f591b94d216392c9e0500207bb1fec42dd355f4fecdfd186956567b6b
in upstream
with purescript-postgres-client =
{ name = "postgresql-client"
, version = "v3.0.0"
, dependencies =
[ "aff"
, "argonaut"
, "arrays"
, "assert"
, "bifunctors"
, "bytestrings"
, "console"
, "datetime"
, "decimals"
, "effect"
, "either"
, "exceptions"
, "foldable-traversable"
, "foreign"
, "foreign-generic"
, "foreign-object"
, "js-date"
, "lists"
, "maybe"
, "newtype"
, "nullable"
, "prelude"
, "psci-support"
, "string-parsers"
, "test-unit"
, "transformers"
, "tuples"
]
, repo = "https://github.com/rightfold/purescript-postgresql-client.git"
}
spago.dhall
{ name = "my-project"
, dependencies =
[ "console"
, "effect"
, "hyper"
, "hypertrout"
, "node-buffer"
, "node-http"
, "nodetrout"
, "numbers"
, "psci-support"
, "purescript-postgres-client"
, "smolder"
]
, packages = ./packages.dhall
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
}
Thank you for your effort so far I’m quite new to purescript
