Skip to content

Instantly share code, notes, and snippets.

@owickstrom
Created February 28, 2017 19:06
Show Gist options
  • Save owickstrom/2281f69c1ec979803415177120e8f666 to your computer and use it in GitHub Desktop.
Save owickstrom/2281f69c1ec979803415177120e8f666 to your computer and use it in GitHub Desktop.
Type-safe forms draft
module Examples.SafeForm where
import Control.IxMonad ((:*>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Except (ExceptT)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..), maybe)
import Data.MediaType.Common (textHTML)
import Data.Monoid (mempty)
import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Routing (type (:/), type (:<|>), type (:>), Capture, ReqBody, (:<|>))
import Hyper.Routing.ContentType.HTML (class EncodeHTML, HTML, linkTo)
import Hyper.Routing.Form (type (:<>), (:<>), FormUrlEncoded, InputHidden, InputNumber, InputText, toForms)
import Hyper.Routing.Links (linksTo)
import Hyper.Routing.Method (Get, Post)
import Hyper.Routing.Router (RoutingError, router)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Text.Smolder.HTML (button, h1, label, p, table, tbody, td, th, thead, tr)
import Text.Smolder.HTML.Attributes (placeholder, type')
import Text.Smolder.Markup (text, (!))
import Type.Proxy (Proxy(..))
import Prelude hiding (div)
type Site =
Get HTML Persons
:<|> "new" :/ Get HTML NewPerson
:<|> ReqBody FormUrlEncoded PersonForm :> Post HTML PersonSaved
:<|> Capture "id" Int :> Get HTML EditPerson
newtype Person = Person { id :: Int, name ∷ String, age ∷ Int }
data Persons = Persons (Array Person)
data NewPerson = NewPerson
data EditPerson = EditPerson Person
data PersonSaved = PersonSaved
type PersonForm =
InputHidden "id" Int
:<> InputText "name"
:<> InputNumber "age"
instance encodeHTMLPersons :: EncodeHTML Persons where
encodeHTML (Persons ps) =
table do
thead do
tr do
th (text "Name")
th (text "Age")
th (text "Actions")
tbody (traverse_ encodePerson ps)
where
encodePerson (Person person) =
case linksTo site of
_ :<|> _ :<|> getPerson' →
tr do
td (text person.name)
td (text (show person.age))
td (linkTo (getPerson' person.id) (text "Edit"))
instance encodeHTMLNewPerson :: EncodeHTML NewPerson where
encodeHTML _ =
case toForms site of
_ :<|> _ :<|> savePersonForm :<|> _ → savePersonForm renderForm
where
renderForm (idField :<> nameField :<> ageField) = do
h1 (text "New Person")
idField 0
p $ label do
text "Name: "
nameField Nothing ! placeholder "Your name..."
p $ label do
text "Age: "
ageField Nothing ! placeholder "Your age..."
button ! type' "submit" $ text "Save"
instance encodeHTMLPerson :: EncodeHTML EditPerson where
encodeHTML (EditPerson (Person person)) = do
h1 (text "Edit Person")
p (text "TODO")
instance encodeHTMLPersonSaved :: EncodeHTML PersonSaved where
encodeHTML _ = mempty
allPersons ∷ ∀ m. Monad m ⇒ ExceptT RoutingError m Persons
allPersons =
[Person { id: 1, name: "Alice", age: 41 }]
# Persons
# pure
newPerson ∷ ∀ m. Monad m ⇒ ExceptT RoutingError m NewPerson
newPerson = pure NewPerson
editPerson ∷ ∀ m. Monad m ⇒ Int → ExceptT RoutingError m EditPerson
editPerson i =
Person { id: 0, name: "John", age: 41 }
# EditPerson
# pure
savePerson ∷ ∀ m. Monad m ⇒ PersonForm -> ExceptT RoutingError m PersonSaved
savePerson _ = pure PersonSaved
site :: Proxy Site
site = Proxy
main :: forall e. Eff (http :: HTTP, console :: CONSOLE, buffer :: BUFFER | e) Unit
main =
let onRoutingError status msg =
writeStatus status
:*> contentType textHTML
:*> closeHeaders
:*> respond (maybe "" id msg)
handlers =
allPersons
:<|> newPerson
:<|> savePerson
:<|> editPerson
appRouter = router site handlers onRoutingError
in runServer defaultOptionsWithLogging {} appRouter
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment