How do you get rid of monad in monad EDITED

Hello everibady,

(please scroll here)

I have function that in context of one monad return function in monad, but want to get rid of monad in between, is that possible ?

This in handler there is pool variable that I would like to pass to withConnection, but getPool is returning pool in Aff monad

getPool :: forall m. MonadAsk Env m => m Pool
getPool = asks _.pool
fruitCreateHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
fruitCreateHandler = Ix.do
  eitherBodyParams <- parseForm
  pool <- getPool


  result <- do
    params <- eitherBodyParams
    conn <- withConnection pool
    name <- required "name" params
    delicious <- required "delicious" params
    price <- required "price" params
    
    pure $ execute conn (Query """
      INSERT INTO fruits (name, delicious, price)
      VALUE ($1, $2, $3)
    """ (Row3 name (castBoolean delicious) (Number.fromString price)))

  pure $ case result of 
    Right _ -> badRequestHandler "Success"
    Left _ -> badRequestHandler "Fail"

EDIT:
I managed to solve aff

fruitCreateHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
fruitCreateHandler = Ix.do
  eitherBodyParams <- parseForm
  result <- getPool >>= \pool -> withConnection pool \eitherConn -> do
    conn <- eitherConn
    params <- eitherBodyParams
    name <- required "name" params
    delicious <- required "delicious" params
    price <- required "price" params
    pure $ execute conn (Query "INSERT INTO fruits (name, delicious, price) VALUE ($1, $2, $3)") (Row3 name (castBoolean delicious) (Number.fromString price))

  badRequestHandler "Head"

Now I have problem that first either donā€™t match at line conn <- eitherConn

Could not match type
          
    String
          
  with type
           
    PGError
           

while trying to match type Either String

I tried to transform Either PGError String to Either String String by wrapping eitherConn to case like

case eitherConn of
    Left e -> Left (show e)
    Right a -> Right a

whole code:

fruitCreateHandler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
fruitCreateHandler = Ix.do
  eitherBodyParams <- parseForm
  result <- getPool >>= \pool -> withConnection pool \eitherConn -> 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 $ execute conn (Query "INSERT INTO fruits (name, delicious, price) VALUE ($1, $2, $3)") (Row3 name (castBoolean delicious) (Number.fromString price))

  badRequestHandler "Head"

but I get:

Could not match type
                 
    Either String
                 
  with type
       
    Aff
       

while trying to match type Either String t1

Is there way how to update either without compiler changing monad from either to aff ?

1 Like

A quick hint from my side (Iā€™m not able to write more at the moment) If you want to ā€œchangeā€ error in an Either you can use lmap from Bifunctor:

eitherConn :: Either PGError a -> Either String a
eitherConn = lmap (\_ -> "It was some pg error") eitherConn

When you want to mix Aff (or any monad) with Either you can use ExceptT + runExceptT but then for mapping over error you have to use withExceptT.

It seems that a part of the do block is a pure Either computation (we could even use ado ... in here because or <$> and <*> directly). So without introducing ExceptT the direct fix could be:

\eitherConn -> do
 let
   eitherCtx = do
     conn <- lmap show eitherConn
     params <- eitherBodyParams
     name <- required "name" params
     delicious <- required "delicious" params
     price <- required "price" params
     pure { conn, params, name, delicious, price }
 case eitherCtx of
   Right { conn, params, name, delicious, price } -> execute conn ...
   Left _ -> ...

Another points:

  • The main block is indexed monad so you have to wrap the whole subcomputation in lift'.

  • withConnection is a plain Aff so when you want to combine getPool with it you have to do some lifting tooā€¦

Could you please provide an info about your AppM so maybe we can use it here too? :slight_smile:

1 Like

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

I managed to isolate ReaderT problem, I need somehow transform Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) (AppM Aff String) to Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) String but donā€™t know how:

module Example.HyperReaderT 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 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.Status (statusOK)
import Hyper.Conn (Conn)

import Text.Smolder.HTML (Html, html, p)
import Text.Smolder.Markup (text)
import Text.Smolder.Renderer.String (render)

type ComponentsType = Record ()
type ConnHttp resp = Conn HttpRequest (HttpResponse resp) ComponentsType

type Env = 
  { message :: String
  }

type AppM m = ReaderT Env m

getMessage :: forall m. MonadAsk Env m => m String
getMessage = asks _.message

runAppM āˆ· forall a. Env -> (AppM Aff a) -> Aff a
runAppM = flip runReaderT

template :: String -> String
template greet = render (html (p (text $ greet <> ", Hyper!!")))

handler :: Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) Unit
handler = Ix.do
  response <- pure $ createTemplate
  writeStatus statusOK
  closeHeaders
  respond response

createTemplate :: AppM Aff String
createTemplate = do
  msg <- getMessage
  pure $ template msg

main :: Effect Unit
main = runServer' defaultOptionsWithLogging {} (runAppM {message: "Ahoj"}) handler

Where I get

No type class instance was found for
                                                             
    Hyper.Response.ResponseWritable (NodeResponse            
                                       (ReaderT              
                                          { message :: String
                                          }                  
                                          Aff                
                                       )                     
                                    )                        
                                    (ReaderT                 
                                       { message :: String   
                                       }                     
                                       Aff                   
                                    )                        
                                    (ReaderT                 
                                       { message :: String   
                                       }                     
                                       Aff                   
                                       String                
                                    )                        
                                                             

while applying a function respond
  of type Monad t6 => ResponseWritable t7 t6 t8 => Response t9 t6 t7 => t8                                 
                                                                        -> Middleware t6                   
                                                                             { components :: t11           
                                                                             , request :: t10              
                                                                             , response :: t9 BodyOpen     
                                                                             }                             
                                                                             { components :: t11           
                                                                             , request :: t10              
                                                                             , response :: t9 ResponseEnded
                                                                             }                             
                                                                             Unit                          
  to argument response
while checking that expression respond response
  has type Middleware t0              
             { components :: t3       
             , request :: t1          
             , response :: t2 BodyOpen
             }                        
             t4                       
             t5                       
in value declaration handler

Which means, if I understand it right, that on line response <- pure $ createTemplate I get Middleware (AppM Aff) (ConnHttp StatusLineOpen) (ConnHttp ResponseEnded) (AppM Aff String) and that blows at line respond response because it is not instance of ResponseWritableā€¦