Michael Beidler @ Metal Toad & Typechecked
A full-stack Haskell web application template/example.
https://github.com/mbeidler/cation
cation-server
cation-client
cation-common
GHC
GHCJS
Define your API in types.
type API = "echo" :> Capture "message" :> Get '[JSON] String
From the type, you can:
Write servers
For the above type, you only need to provide a handler function:
echo :: String -> Handler String
echo = return
req (Proxy :: Proxy API) "test"
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
module Cation.Common.Api.Combinators where
import Cation.Common.Conventions (Key)
import GHC.TypeLits (Symbol)
import Servant.API
type GetR (path :: Symbol) resource
= path :> Get '[JSON] [resource]
type PostR (path :: Symbol) createType resource
= path :> ReqBody '[JSON] createType :> Post '[JSON] resource
type PutR (path :: Symbol) resource
= path :> ReqBody '[JSON] resource :> Put '[JSON] resource
type GetByIdR (path :: Symbol) (capture :: Symbol) resource
= path :> Capture capture Key :> Get '[JSON] resource
type DeleteR (path :: Symbol) (capture :: Symbol)
= path :> Capture capture Key :> Delete '[JSON] Key
data CreateContact = CreateContact
{ cContactFirstName :: Text
, cContactLastName :: Text
, cContactEmail :: Text
, cContactPhone :: Maybe Text
} deriving (Generic, NFData)
$(deriveJSON (jsonOpts 8) ''CreateContact)
data Contact = Contact
{ contactId :: Key
, contactFirstName :: Text
, contactLastName :: Text
, contactEmail :: Text
, contactPhone :: Maybe Text
} deriving (Generic, NFData)
$(deriveJSON (jsonOpts 7) ''Contact)
type Contacts = "contacts"
type GetContacts = GetR Contacts Contact
type PostContact = PostR Contacts CreateContact Contact
type PutContact = PutR Contacts Contact
type GetContact = GetByIdR Contacts "id" Contact
type DeleteContact = DeleteR Contacts "id"
type ContactsAPI = GetContacts
:<|> PostContact
:<|> PutContact
:<|> GetContact
:<|> DeleteContact
Thanks Luite Stegeman!
Excellent Documentation
Uses stack
Good Performance
Easy to integrate with 3rd party React components
Lucid-like template DSL
Views are pure. IO lives only in the store
react-flux-servant
class FlavorForm extends React.Component {
constructor(props) {
super(props);
this.state = {value: 'coconut'};
this.handleChange = this.handleChange.bind(this);
this.handleSubmit = this.handleSubmit.bind(this);
}
handleChange(event) {
this.setState({value: event.target.value});
}
handleSubmit(event) {
alert('Your favorite flavor is: ' + this.state.value);
event.preventDefault();
}
render() {
return (
<form onSubmit={this.handleSubmit}>
<label>
Pick your favorite La Croix flavor:
<select value={this.state.value}
onChange={this.handleChange}>
<option value="grapefruit">Grapefruit</option>
<option value="lime">Lime</option>
<option value="coconut">Coconut</option>
<option value="mango">Mango</option>
</select>
</label>
<input type="submit" value="Submit" />
</form>
);
}
}
flavorForm :: ReactView ()
flavorForm = defineStatefulView "flavorForm" "coconut" $
\state args ->
form_ [] $ do
label_ [] $ do
"Pick your favorite La Croix flavor: "
select_ [ "value" $= state
, onChange $ \e _ ->
([], Just (target e "value")) ] $ do
option_ [ "value" $= "grapefruit" ] "Grapefruit"
option_ [ "value" $= "lime" ] "Lime"
option_ [ "value" $= "coconut" ] "Coconut"
option_ [ "value" $= "mango" ] "Mango"
input_ [ "type" $= "submit"
, "value" $= "Submit" ]
JavaScript (ES6)
Haskell
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Cation.Client.Components.Contacts.Store where
import Cation.Client.Api (Response, cfg, onResp, req)
import Cation.Common.Api.Contacts
import Control.DeepSeq (NFData)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic)
import React.Flux
import React.Flux.Addons.Servant (request)
data ContactsStore
= ContactsInit
| ContactsState { contacts :: [Contact] }
deriving (Generic, NFData)
data ContactsAction
= LoadContacts
| LoadContactsComplete (Response [Contact])
deriving (Generic, NFData)
instance StoreData ContactsStore where
type StoreAction ContactsStore = ContactsAction
transform action state =
case action of
LoadContacts -> do
req (Proxy :: Proxy GetContacts) (dispatch . LoadContactsComplete)
return state
LoadContactsComplete response ->
onResp (pure . ContactsState) response state
dispatch :: ContactsAction -> IO [SomeStoreAction]
dispatch action = pure [SomeStoreAction contactsStore action]
contactsStore :: ReactStore ContactsStore
contactsStore = mkStore ContactsInit
Example Flux Store
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Cation.Client.Components.Contacts.View where
import Cation.Client.Components.Contacts.Store
import Cation.Client.Components.Table
import Cation.Common.Api.Contacts
import Data.Default
import Data.Maybe (fromMaybe)
import React.Flux hiding (table_)
contactsApp :: ReactView ()
contactsApp = defineControllerView "contactsApp" contactsStore render
where
render :: ContactsStore -> () -> ReactElementM handler ()
render state () =
div_ [ "className" $= "panel panel-default" ] $ do
div_ [ "className" $= "panel-heading" ] $
div_ [ "className" $= "container-fluid" ] $
div_ [ "className" $= "row" ] $ do
h3_ [ "className" $= "mt-md col flex-first" ] "Contacts"
div_ [ "className" $= "panel-body" ] $
case state of
ContactsInit ->
div_ [ "className" $= "text-center" ] $
i_ [ "className" $= "fa fa-cog fa-spin fa-2x fa-fw" ] mempty
ContactsState{..} ->
div_ (contactTable_ contacts)
contactTableCfg :: TableCfg Contact handler
contactTableCfg =
def { tblColumns =
[ defCol "First Name" (elemText . contactFirstName)
, defCol "Last Name" (elemText . contactLastName)
, defCol "Email" (elemText . contactEmail)
, defCol "Phone" (elemText . fromMaybe "" . contactPhone) ] }
contactTable_ :: [Contact] -> ReactElementM handler ()
contactTable_ = table_ contactTableCfg
Example View
main = syncCallback' go >>= runHsReactApp
where
go = reactRender "app" app ()
foreign import javascript "runHsReactApp = $1"
runHsReactApp :: Callback a -> IO ()
-- Then from JavaScript:
runHsReactApp()