In the previous blog post we saw interaction with servant in reflex. Although that covers the basics, there are several more hurdles to overcome to get comfortable with Reflex. I think most of these are encountered by building a simple login system. So let’s build something like:

													
                   	   +------------------+
   +-----------+       |    .      -      |
   | +--------+|       | .    -  .. .     |
   | +--------+|       | . .-- - + m..-.  |
   | +--------+|    \  |   m# + .-..% -   |
   | +--------+|     \ |   + .+ #.+...+   |
   | login ----+------X|    .. -.- *      |
   +-----------+     / |    ..  ..-#+ +   |
                    /  |      .  - -. .   |
                   	   |         . .      |
					   |          -       |
					   |                  |
		     		   +------------------+
					        Awesome app	

I’ve experienced that this is hard for the first time. With this blog post I hope that setting up authentication becomes easier, considering the following pain points:

1. ‘Switching screens’ after login, requires recursive do.
2. Dealing with cookies yourself is pretty hard, many pesky (security) details.
3. Rendering widgets inside FRP constructs requires widgetHold or ‘dyn’.

I’m of course a world expert on login systems, so in production do everything exactly as I do. Trust me, I’m from the internet. But seriously If you see something dubious, do contact me. I’ll happily rectify mistakes, and put you on the page of honour (if you want).

I left some code out of this blog post for succinctness. But the full source is available on github.

API Endpoints

type ServiceAPI = PublicAPI :<|> Auth '[Cookie, JWT] User :> AuthAPI

First we need to split our API into two types. The PublicAPI and the AuthAPI. Once the user is logged in he gets access to the AuthAPI. We’ll secure this with a JWT cookie. If the user does not have a proper cookie, he’ll get a 401 unauthorized status code.

type PublicAPI = "api" :> "1.0" :> "login" :> ReqBody '[JSON] User
								:> Post '[JSON] (AuthCookies NoContent)

This is our entire public api, we only expose the login endpoint. The result contains no content, but cookies. Servant assumes all status codes are possible in every request. Therefore we don’t have to mention the 401 status code.

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

The AuthAPI is similar to the ServiceAPI from the previous blog post, which only contained the users and message endpoints. Now we’ve extended it with a getme endpoint. The getme endpoint is a hack to do auto login with cookies. It allows us to do a request on initial page load to see if we have the cookies or not. Technically we shouldn’t have to do this trough a request, but it works for version 0.1.

Next we’ll implement these types into handlers:

login :: ApiSettings -> User -> Handler (AuthCookies NoContent)
login settings user = if elem user users then do
	withCookies <- liftIO $
		acceptLogin cookies (jwtSettings settings) user
	pure $ maybe (clearSession cookies NoContent) (\x -> x NoContent)
		withCookies
  else throwAll err401 -- unauthorized
  where
    cookies = cookieSettings settings

We added a new login handler, which checks if the user exists within the users list. If the user is in the list, we use acceptLogin to create a JWT from the user. [A]cceptLogin returns maybe a function which applies the JWT cookie. In the success branch of maybe we apply this function to NoContent to get an AuthCookies NoContent. The Nothing branch also produces AuthCookies NoConent, but it sets the cookie values with clearSession resulting in nothing instead of a JWT.

The ApiSettings is just a data type with various configurations:

data ApiSettings = ApiSettings
  { cookieSettings :: CookieSettings
  , jwtSettings    :: JWTSettings
  , connection     :: Connection
  }

You can’t use connection like this in production, it needs to be a pool, because servant is fully concurrent. You’ll end up with data races if you use a plain connection.

For the cookieSettings I modified the defaults quite a bit:

cookieConf =
  defaultCookieSettings
    { cookieIsSecure = NotSecure
    , cookieMaxAge = Just $ secondsToDiffTime $ 60 * 60 * 24 * 365
    , cookieXsrfSetting = Just $
        def { xsrfCookieName = Text.encodeUtf8 cookieName
            , xsrfHeaderName = Text.encodeUtf8 headerName
            }

    }

Cookies are set to NotSecure to allow it to work on HTTP. This is required for local testing, and avoids confusion about why your cookies, and your entire login system, don’t work locally. You should simply disable HTTP in production anyway. There is no good reason for using plain HTTP on a live website, ever since let’s encrypt became a thing.

The max age is simply an auto sign out after a period, a year in this case. This is a bit more secure because we don’t trust someone’s login forever.

XSRF settings are set to use the names from the Common XSRF module. This ensures the requests from the frontend use the same names as servant-auth expects.

authenticatedServer :: ApiSettings -> AuthResult User -> Server AuthAPI
authenticatedServer settings (Authenticated user) =
    (pure user :<|> pure users :<|> messages (connection settings))
authenticatedServer _ _ = throwAll err401 -- unauthorized

The authenticatedServer handles the endpoints for the authenticated API. The only new one is getMe, which just returns the authenticated user. All authenticated endpoints now have access to the user who was authenticated. This user is decoded from the JWT by servant-auth.

We get an AuthResult from servant-auth-server to work with. If the user is authenticated, we give access to the API, if not we return a 401 status code. This is done manually, which means the 401 response is not mandatory.

server :: ApiSettings -> FilePath -> Server Webservice
server settings staticFolder =
	(login settings :<|> authenticatedServer settings)
	:<|> serveDirectoryFileServer staticFolder

The server function now has to split our API on authenticated and public parts. It’s similar to the previous blog post. We still serve the static folder for testing.

app :: ApiSettings -> FilePath -> Application
app settings staticFolder =
  serveWithContext webservice context $ server settings staticFolder
  where
    context = cookieSettings settings :. jwtSettings settings :. EmptyContext

We now serve with context, this is the servant-auth entry point for decoding of the JWT from the Cookie.

This is probably not the way you want to do login on the sever side for the following reasons:

• We don’t handle passwords, period. (Authentication by trust is a thing?)
• One shouldn’t use JWT’s for sessions

Solving these issues is out of the scope of this article[^scope]. [^scope]: My articles tend to snowball anyway, for example invented how to do XSRF specifically for this article. I Don’t want to cargo cult a bunch of XSRF vulnerable websites.

The client API is much simpler:

postLogin :: MonadWidget t m
          => Dynamic t (Either Text.Text User)
          -> Event t ()
          -> m (Event t (ReqResult () (AuthCookies NoContent)))
getUsers :: MonadWidget t m
          => Event t ()
          -> m (Event t (ReqResult () [User]))
getMe :: 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]))
(postLogin :<|> (getMe :<|> getUsers :<|> postMessage)) = apiClients

The clients are still generated, the only thing I’ve done is spell out the type signatures.

Reflex

Time for some reflex. The reflex changes are rather small but dense:

loginWidget :: (MonadWidget t m) => m (Event t User)
loginWidget = do
  autoLoginEvt <- autoLogin
  formEvt <- loginForm
  pure $ leftmost [formEvt, autoLoginEvt]

This function performs either an auto login, or shows a login form. leftmost is a function that combines events, by using the value of whichever fires. If they fire both, the element that occurs first in the list is used. Hence the name leftmost.

Now let’s dive into it’s sub components, first autologin:

autoLogin :: (MonadWidget t m) => m (Event t User)
autoLogin = do
  pb <- getPostBuild
  withSuccess <$> getMe pb

We get the post build event, an event that fires after the widget is placed in the DOM. We use that to greedily to make the getMe request. If successful that is used as the resulting event. However the loginWidget makes a login form regardless of success:

userInput :: (MonadWidget t m) => m (Dynamic t User)
userInput = ...

loginForm :: (MonadWidget t m) => m (Event t User)
loginForm = do
  user <- userInput
  buttonEvt <- button "login"
  postResult <- postLogin (Right <$> user) buttonEvt
  void $ flash postResult $ text . Text.pack . show . reqFailure
  pure $ current user <@ withSuccess postResult

The userInput has remained the same as in the previous blog post. After the userInput form we create a button, which gives us a resulting buttonEvt event. This event only fires if the button is pressed. We use the buttonEvt to call postLogin. As input we use the dynamic user from the userInput form. This gives us a postResultEvt, an event that only fires on request completion. Remember postLogin is a function generated from our API type signature:

postLogin :: MonadWidget t m
          => Dynamic t (Either Text.Text User)
          -> Event t ()
          -> m (Event t (ReqResult () (AuthCookies NoContent)))

The ReqResult is a container for dealing with HTTP status codes, connection errors and decoding issues ¹. In case of failure the postResultEvt is ‘flashed’, or shown briefly for a couple of seconds. In case of success we tag the postResultEvt with the user and use that as resulting event.

Note that <@, is the same as <$, except it works on behaviors: The event gets the value of whatever the behavior is at the time of the event. A behavior is something that always has a value, but which can change at any moment. Whereas an event is something that happens at a point in time with some value. A mouse position is an example of behavior, whereas a mouse click is an event².

Next we move onto the function that ties everything together:

reflex :: MonadWidget t m => m ()
reflex = do
  rec loginEvt <- elDynAttr "div" loginAttr loginWidget
      loginAttr <- holdDyn (Map.empty) $ hidden <$ loginEvt
  void $ holdEvent () loginEvt authenticatedWidget

Once the login event happens this function will hide the loginWidget and put the authenticatedWidget on the DOM. loginAttr is used before it’s assigned however. This is impossible in a normal do block, but it is possible within a rec block. The rec keyword is from recursive do. It allows referencing of variables ‘higher’ in a do block. In our case we need to have loginAttr within the elDynAttr function.

I don’t want to go into how rec works³, but I do want to make clear why it’s needed. There is a reference cycle⁴. Look closely at loginAttr. It depends on loginEvt. Now look at how the loginEvt is made. It comes from a div that requires loginAttr. A cycle. I don’t know of any other way to solve this than using recursive do.

So the login widget resides in a div with dynamic attributes. These attributes are set on the next line, which starts out as an empty Map, no attributes. Once the login event happens, it becomes the hidden, which sets the style to display:none.

holdEvent is used to extract the user as a value from the event and render authenticatedWidget as a new part of the DOM. The holdEvent functions is a convenience function for widgetHold:

widgetHold :: (DomBuilder t m, MonadHold t m)
  => m a
  -> Event t (m a)
  -> m (Dynamic t a) 

holdEvent :: (Dom.DomBuilder t m, MonadHold t m)
  => b
  -> Event t a
  -> (a -> m b)
  -> m (Dynamic t b)
holdEvent val evt fun =
  Dom.widgetHold (pure val) $ fun <$> evt

widgetHold will show the first given widget, until the event happens which has a widget as value. Then the widget within that event is put onto the DOM instead of the original. It’s a bit like sequence⁵. In any case it returns the widget value as a dynamic.

holdEvent however assumes we initially don’t want to render anything on the DOM. Then it asks you to provide an event with any value and finally a function that consumes the value to produce the widget. It will execute the function and display the resulting widget on the DOM instead of nothing.

The first argument of holdEvent is the default value. The second argument is the event which we want to hold. The final argument is the function we want to execute producing a widget. The function keeps returning the default value until the event fires for the first time, then it will keep on displaying the fired event.

Note that widgetHold is slow ⁶ because it modifies the DOM ⁷. It’s much better to use dynText and elDynAttr to modify the dom/layout. However, widgetHold is really convenient to get access to values within events. I also think that the parts inside a widgetHold function don’t get evaluated until the event occurs. This is really convenient for login. Now you don’t have to evaluate the bulk of your app on initial page load. widgetHold can postpone evaluating large parts of your app. Which makes that initial render much faster⁸.

Anyway as we can see from the type signature, in this case the b ~ (), and the a ~ User. Which leads us to authenticatedWidget:

authenticatedWidget :: MonadWidget t m => User -> m ()
authenticatedWidget user =
  el "div" $ do
    getUsersWidget
    sendMsgWidget user

This is the same as the app discussed in the previous blog post. Although now we use the logged in user to send messages.

XSRF

To make servant reflex work nicely with servant-auth we need to modify the requests a bit, servant reflex supports this with ClientOptions:

clientOpts :: ClientOptions
clientOpts = ClientOptions $ tweakReq
  where
    tweakReq r = do
      mayCookie <- findCookie cookieName
      return $ r & headerMod headerName .~ mayCookie -- forgive lenses
    headerMod d = xhrRequest_config . xhrRequestConfig_headers . at d

apiClients :: forall t m. (MonadWidget t m) => _
apiClients = clientWithOpts
	serviceAPI (Proxy @m) (Proxy @()) (constDyn url) clientOpts

The client options lives in the JSM monad and gives us an opportunity to modify the XHRRequest how we want. We make sure the names are the same by using the ones defined in the common module.

Conclusion

So there you have it. Authentication. Not the most exciting thing in the world, but once this is done you can start making something cool. I hope I helped you get trough this ordeal fast, and explain some of the finer reflex points. Now I hope to see many cool reflex projects popping up. PM me your cool projects.

References

With the release of reflex 0.5 we now have updated docs!

• Source code
• Previous blog
• Reflex
• Reflex dom
• Servant reflex
• MonadFix
• Control.Monad.Fix
• Recursive do language extension
• Reflex dom XHR