PureScript + Hyper + Mongo - basic auth

Main.purs

module Main where

import Prelude
import Control.IxMonad ((:>>=), (:*>))
import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Argonaut (class DecodeJson, (.?), decodeJson)
import Data.Either (hush)
import Data.Maybe (Maybe)
import Data.MediaType.Common (textPlain)
import Data.Tuple (Tuple(Tuple))
import Database.Mongo.Bson.BsonValue ((:=))
import Database.Mongo.Mongo (DB, Database, collection, connect, findOne)
import Hyper.Middleware.Class (getConn)
import Hyper.Node.BasicAuth as BasicAuth
import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Status (statusOK)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Text.Smolder.HTML (p)
import Text.Smolder.Markup (text)
import Text.Smolder.Renderer.String (render)

type Context = { db :: Database }

context :: forall e. Aff (db :: DB | e) Context
context = do
    db <- connect "mongodb://localhost:27017/hypertest"
    pure { db }

data Account = Account String String

instance decodeAccount :: DecodeJson Account where
  decodeJson json = do
    document <- decodeJson json
    id <- document .? "_id"
    password <- document .? "password"
    pure $ Account id password

instance showAccount :: Show Account where
  show (Account id password) = "Account { id = " <> id <> ", password = " <> password <> " }"

findAccount :: forall e. String -> String -> Database -> Aff (db :: DB | e) Account
findAccount id password db = do
  accounts <- collection "accounts" db
  account <- findOne [ "_id" := id, "password" := password ] [] accounts
  pure account

accountFromBasicAuth :: forall e. Tuple String String -> Aff (db :: DB | e) (Maybe Account)
accountFromBasicAuth (Tuple id password) = do
  ctx <- context
  accountFinding <- attempt $ findAccount id password ctx.db
  pure $ hush accountFinding

main :: forall e. Eff (console :: CONSOLE, db :: DB, http ∷ HTTP, buffer :: BUFFER | e) Unit
main =
  let
    myProfilePage =
      getConn :>>= \conn ->
      case conn.components.authentication of
        Account id _ → do
          writeStatus statusOK
          :*> contentType textPlain
          :*> closeHeaders
          :*> respond (render (p (text ("You are authenticated as " <> id <> "."))))

    app = do
      BasicAuth.withAuthentication accountFromBasicAuth
      :*> BasicAuth.authenticated "Authentication Example" myProfilePage
    components = { authentication: unit }
  in runServer defaultOptionsWithLogging components app