In the pragmatic haskell series, we saw how to setup a simple webserver with database. But at some point you still need a frontend. If it were 2005 you may have been able to get away with just blaze. But we are in 2018+, and JavaScript is a problem. In this blog post we will explore how to deal with JavaScript trough reflex and GHCJS. An alternative to consider is miso, which uses the elm architecture (or redux if you’re from JS), here is a comparison. Obviously I chose reflex.

fancy db image

Preparation

First we need to setup the dev environment. This time we’ll double down on nix because reflex does that too and fighting build tools is no fun. This has the advantage that the resulting code on github is reproducible. All need to be done is setup the file watch for which I wrote a make command:

make file-watch

This rebuilds both the Haskell back end and JavaScript front end incrementally.

There are two separate environments now, one is for the native Haskell target (x86), and the other is the JavaScript target. We can enter the shell environment for the native target with make enter and the JavaScript target with make enter-js. This is convenient for doing one of commands.

The biggest issue I had when setting this up was figuring out how to add extra dependencies not in the nix repo. I found out by reading the nix code that this can be done with the overrides flag. Another issue was tools for shells, such as hpack which generates cabal files from the package.yaml file. I really wanted to use that as I didn’t want to learn cabal, besides, hpack’s is much more succinct, it doesn’t require explicit module exports. there is a shellOverrides attribute for that.

    overrides = self: super: rec {
      beam-core = self.callPackage ./packages/beam-core.nix { };
      ...
    };
    ...
    shellToolOverrides = ghc: super: {
        inherit (ghc) hpack;
        fswatcher = pkgs.inotify-tools;
        ...
    };

Back end

The backend is mostly the same as the result of the pragmatic haskell series. We moved the API endpoints that need to be accessed by client to the e common code, and added an additional endpoint for hosting the html. Normally we wouldn’t use Haskell to deliver static assets and use a specialized program such as nginx. Since this is for experimentation however we made an exception:

type Webservice = ServiceAPI 
      :<|> Raw -- JS entry point

webservice :: Proxy Webservice
webservice = Proxy

... 

server :: Connection -> Server Webservice
server conn=
  (pure users :<|> messages conn) :<|> serveDirectoryFileServer "dist-ghcjs/build/x86_64-linux/ghcjs-0.2.1/frontend-0.1.0.0/c/webservice/build/webservice/webservice.jsexe/"

The webservice type definition has the aditional Raw endpoint, which allows hosting of custom wai apps. The serveDirectoryFileServer is that custom wai app and just hosts the JavaScript output of the client.

Common code

This is where the shared code between client and server lives. We put the API definition in here. Since servant can create both servers and clients it’s a great library for this use case.

Any change in API will now cause the type checker to tell us where this is affected in both client and server. Type safety becomes amplified, making bugs more obvious and increasing developer productivity.

The actual content of this module isn’t that interesting, it’s just the API definition. Common code gets compiled within the JavaScript client. This means it’s public, one should not put any passwords or trade secrets in here.

Front end

I started with trying to get reflex to work with servant because it seemed the most uncertain. After this I intended to use servant-client for generating the client functions, here I ran into another hurdle as the latest servant wasn’t available. Apparently reflex is pinned to an old hackage repository, I attempted to upgrade but abandoned that endeavour as it required more nix modifications and I’d prefer to keep the same pin as upstream so I could get help when I needed it. Using the older servant, I hit a run time exception:

uncaught exception in Haskell main thread: ReferenceError: h$hsnet_getaddrinfo is not defined

This is because servant client uses a system call for networking which is unavailable in the browser sandbox. A bit of googling led me to servant reflex. Using this was hard because are no official haddocs since it hasn’t been released yet. Finding an example was of great help which led me to this client definition:

apiClients :: forall t m. (MonadWidget t m) => _
apiClients = client serviceAPI (Proxy @m) (Proxy @()) (constDyn url)
  where url :: BaseUrl
        url = BasePath "/"

This creates both functions for querying the serviceAPI from the common module. All this seems to do is getting that m in scope and applying it to the client with a proxy. The partial type signature was left from the example this way intentionally, because it’s formalized below anyway and it’s rather big.

getUsers :: MonadWidget t m
          => Event t ()
          -> m (Event t (ReqResult () [User]))
postMessage :: MonadWidget t m
            => Dynamic t (Either Text.Text Message)
            -> Event t ()
            -> m (Event t (ReqResult () [Message]))
(getUsers :<|> postMessage) = apiClients

This pulls out the functions from apiClients, we also get there final signature here. The entire file can be seen in the sources.

Reflex

After getting the API to function I started working on making an actual UI. Which is what this code does for the getUsers function:

reflex :: IO()
reflex =
  mainWidget $
    el "div" $ do
        -- babys steps, get users from memory
        intButton  <- button "Get Users"
        serverInts <- fmapMaybe reqSuccess <$> getUsers intButton
        display =<< holdDyn ([User "none" "none"]) serverInts

mainWidget is the root of reflex, we use el to specify HTML elements that surround other elements. the button functions creates a button (no surprise). This is within the monad widget, interaction between components is handled trough that monad.

On the next line we use the intButton immediately. If we look at the getUsers type signature we see that it requires an Event t () argument, this is satisfied by the button. In other words getUsers will triggered on the button event. The result is once more put in the monadwidget. Finally we map the result to assume success or Nothing, it will be just a list of users now. The holdDyn function is then used to give a default value to the resulting event in case of nothing, we always display either the default or the request result.

Markup with reflex

For the postMessage function I made a form with text inputs:

        -- Post a usermessage and display results
        input <- messageInput 
        sendMsg <- button "Send Message"
        messages <- fmapMaybe reqSuccess <$> postMessage (Right <$> input) sendMsg 
        resulting <- holdDyn
            ([Message (User "none" "none") "ddd"]) -- what to show if nothing
            messages -- source of messages (if any)
        _ <- el "div" $
            simpleList resulting fancyMsg

messageInput is a function that returns a “dynamic message” (see below), the button is for sending of messages. To display we use a similar pattern however this time we’ll mark it up in HTML with fancy messages. We traverse over the dynamic list with the simpleList function, here I expected traverse to work.

  where
    fancyMsg :: (MonadWidget t m) => Dynamic t Message -> m (Element EventResult GhcjsDomSpace t)
    fancyMsg msg = elClass "div" "message" $ do
        _ <- elDynHtml' "h1" $ Text.pack . name . from <$> msg
        elDynHtml' "span" $ Text.pack . content <$> msg

Every message is put in a div element, for displaying dynamic content however we need to use elDynhtml' function, there is no way of getting a value out of dynamic, we can only show it to the user. This is a strong safety guarantee.

Reflex “react component”

Input fields can be combined together into larger components, which is showcased in the Message form:

messageInput :: (MonadWidget t m) => m (Dynamic t Message)
messageInput = do
    user <- userInput
    message <- labeledInput "message"
    pure $ (Message <$> user) <*> (Text.unpack <$> _textInput_value message)

userInput :: (MonadWidget t m) => m (Dynamic t User)
userInput = do
        username <- labeledInput "username"
        emailInput <- labeledInput "email"
        pure $ User . Text.unpack <$> _textInput_value username <*> (Text.unpack <$> _textInput_value emailInput)

labeledInput :: (MonadWidget t m) => Text.Text -> m (TextInput t)
labeledInput label = elClass "div" "field" $ do
    elClass "label" "label" $ text label
    elClass "div" "control" $ textInput (def & textInputConfig_attributes .~ constDyn (Text.pack "class" =: Text.pack "input"))

This is done with applicative fmap <$> and spaceship <*>. That last line sets some extra confiugrations can be set withLenses for textInput, which is another rabithole. They can simply be thought of as getters and setters for haskell, although more powerfull.

Note that these functions are analogue to a react component, and see the difference! They compose perfectly and will function independently.

Feel the power.

My only complaint is that the resulting JavaScript binary is huge, 8MB, 2MB after using the closure compiler.

Conclusion

I’m very pleased with reflex, now I don’t have to deal with JavaScript, I can prototype my API rapidly and I’m not restricted to an architecture. It is better than I expected, the core seems really well designed. The only downside is the large binary. None the less I’m willing to use this for a larger project.

Links

For convenience here is a list of used resources:

Sources

The project has become too big to share all files, as always there is the github link. I will however put all discussed code in complete form in here.

backend/src/Lib.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -Wno-missing-monadfail-instances #-}


module Lib
    ( webAppEntry
    ) where

import Servant
import Common
import Control.Monad.IO.Class(liftIO)
import Network.Wai(Application)
import Network.Wai.Handler.Warp(run)
import           Database.PostgreSQL.Simple   (Connection)
import qualified DB as DB
import           Database.Beam.Backend.SQL.BeamExtensions (runInsertReturningList)

import qualified Database.Beam                            as Beam
import qualified Database.Beam.Postgres                            as PgBeam
import Data.Text(pack, unpack)

type Webservice = ServiceAPI 
      :<|> Raw -- JS entry point

webservice :: Proxy Webservice
webservice = Proxy

users :: [User]
users =
  [ User "Isaac Newton"    "isaac@newton.co.uk"
  , User "Albert Einstein" "ae@mc2.org"
  ]

messages :: Connection -> Message -> Handler [Message]
messages conn message = do 
  fromDb <- liftIO $ 
    PgBeam.runBeamPostgres conn $ do
      let user = from message
      [foundUser] <- runInsertReturningList (DB._ausers DB.awesomeDB) $ 
          Beam.insertExpressions [DB.User 
            Beam.default_
            (Beam.val_ (pack $ name $ user ))
            (Beam.val_ (pack $ email $ user ))
        ]
      _ <- runInsertReturningList (DB._messages DB.awesomeDB) $ 
          Beam.insertExpressions 
            [DB.Message 
              Beam.default_ 
              (Beam.val_ (Beam.pk foundUser))
              (Beam.val_ (pack $ content message))
            ]
      Beam.runSelectReturningList $ Beam.select $ do 
        usr <- (Beam.all_ (DB._ausers DB.awesomeDB))
        msg <- Beam.oneToMany_ (DB._messages DB.awesomeDB) DB._from usr
        pure (msg, usr)
  pure $
    fmap (
      \(msg, usr) -> Message
        (User
          (unpack $ DB._name usr)
          (unpack $ DB._email usr))
        (unpack $ DB._content msg)
    ) fromDb


server :: Connection -> Server Webservice
server conn=
  (pure users :<|> messages conn) :<|> serveDirectoryFileServer "dist-ghcjs/build/x86_64-linux/ghcjs-0.2.1/frontend-0.1.0.0/c/webservice/build/webservice/webservice.jsexe/"

app :: Connection -> Application
app conn = serve webservice (server conn)

webAppEntry :: Connection -> IO ()
webAppEntry conn = run 6868 (app conn)

common/src/Common.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}

module Common where

import GHC.Generics(Generic)
import Servant.API
import Data.Proxy
import Data.Aeson(ToJSON, FromJSON)

type ServiceAPI = "api" :> "1.0" :> "users" :> Get '[JSON] [User]
      :<|> "api" :> "1.0" :> "message" :> ReqBody '[JSON] Message :> Post '[JSON] [Message]

data Message = Message {
  from :: User,
  content :: String
} deriving (Eq, Show, Generic)

instance ToJSON Message
instance FromJSON Message

data User = User
  { name :: String
  , email :: String
  } deriving (Eq, Show, Generic)

instance ToJSON User
instance FromJSON User

serviceAPI :: Proxy ServiceAPI
serviceAPI = Proxy

frontend/src/Lib.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fprint-explicit-kinds -Wpartial-type-signatures #-}


module Lib
  ( reflex
  ) where
import Reflex
import Reflex.Dom
import qualified Data.Text as Text
import Control.Applicative ((<*>), (<$>))
import Common
import Servant.Reflex
import ServantClient

reflex :: IO()
reflex =
  mainWidget $
    el "div" $ do
        -- babys steps, get users from memory
        intButton  <- button "Get Users"
        serverInts <- fmapMaybe reqSuccess <$> getUsers intButton
        display =<< holdDyn ([User "none" "none"]) serverInts

        -- Post a usermessage and display results
        input <- messageInput 
        sendMsg <- button "Send Message"
        messages <- fmapMaybe reqSuccess <$> postMessage (Right <$> input) sendMsg 
        resulting <- holdDyn
            ([Message (User "none" "none") "ddd"]) -- what to show if nothing
            messages -- source of messages (if any)

        _ <- el "div" $
            simpleList resulting fancyMsg 
        pure ()
  where
    fancyMsg :: (MonadWidget t m) => Dynamic t Message -> m (Element EventResult GhcjsDomSpace t)
    fancyMsg msg = elClass "div" "message" $ do
        _ <- elDynHtml' "h1" $ Text.pack . name . from <$> msg
        elDynHtml' "span" $ Text.pack . content <$> msg

messageInput :: (MonadWidget t m) => m (Dynamic t Message)
messageInput = do
    user <- userInput
    message <- labeledInput "message"
    pure $ (Message <$> user) <*> (Text.unpack <$> _textInput_value message)

userInput :: (MonadWidget t m) => m (Dynamic t User)
userInput = do
        username <- labeledInput "username"
        emailInput <- labeledInput "email"
        pure $ User . Text.unpack <$> _textInput_value username <*> (Text.unpack <$> _textInput_value emailInput)

labeledInput :: (MonadWidget t m) => Text.Text -> m (TextInput t)
labeledInput label = elClass "div" "field" $ do
    elClass "label" "label" $ text label
    elClass "div" "control" $ textInput (def & textInputConfig_attributes .~ constDyn (Text.pack "class" =: Text.pack "input"))

frontend/src/ServantClient.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

{-# LANGUAGE NoMonomorphismRestriction          #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE  TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- | This modules purpose is just to generate the xhr clients.
--   there is some type magick going on generating these,
--   therefore the functions are isolated.
module ServantClient
  ( postMessage, getUsers 
  ) where

import Reflex
import Reflex.Dom
import qualified Data.Text as Text
import Servant.API
import Common
import Servant.Reflex
import Data.Proxy

-- | This intermediate definition is necisarry because the @m is similar for both clients,
--   they have the same wrapping monad however the containing type is different
--   (which is why we have the nomonomorphism restirction disabled)
apiClients :: forall t m. (MonadWidget t m) => _
apiClients = client serviceAPI (Proxy @m) (Proxy @()) (constDyn url)
  where url :: BaseUrl
        url = BasePath "/"

getUsers :: MonadWidget t m
          => Event t ()  -- ^ Trigger the XHR Request
          -> m (Event t (ReqResult () [User])) -- ^ Consume the answer
postMessage :: MonadWidget t m
            => Dynamic t (Either Text.Text Message)
            -> Event t ()
            -> m (Event t (ReqResult () [Message]))
(getUsers :<|> postMessage) = apiClients

Jappie

Fullstack Haskell: Reflex and Servant