Hi, I’m Geoffrey Roberts, one of the web developers at Anchor. I’d like to discuss something I’ve built in Haskell, and hopefully give you some ideas for other things you can do in terms of web development with the language.

I’ve been working on some web frontends in Snap Framework lately, and came to a point where I needed to know who was accessing the frontend, and whether they were allowed to use it. Seeing as the application needed to support both human-visible and RESTful interfaces, I realised that I couldn’t really use any off the shelf authentication methods.

While Snap does provide you with something out of the box to do authentication, it’s intended for human-usable interfaces only, since it’s reliant on cookie-identified sessions. Also, most of our other APIs already use some form of HTTP authentication, so it makes sense to go with an interface that people are already used to working with.

However, Snap doesn’t come with anything out of the box to handle HTTP authentication in the way it does for session-based authentication. We needed to write it ourselves.

Snaplets

Snap has a particular way of defining plugins or modules that allow certain bits of functionality to be abstracted away from the main webapp; the Snap team refers to their modular approach as Snaplets. However, given that the Haskell web space isn’t particularly well-developed, the Snap team only acknowledges the existence of about a dozen Snaplets on their website.

But here’s the rub; we don’t actually need to write a whole snaplet just to do HTTP authentication. It’s enough to write a few intermediary functions and define a couple of data types.

Data types

First, we’re going to define a data type that covers the kind of authentication that we are going to use. Let’s call it AuthHeader.

import Data.ByteString (ByteString)

data AuthHeader = BasicAuth ByteString deriving (Show, Eq)

For the time being, we’ll only support Basic HTTP authentication, but this could later be extended to support Digest and custom token-based headers too.

Writing the intermediary

The intermediary function that we’re going to write starts out like this:

withAuth :: Handler App App () -> Handler App App ()

As you can see, the type signature takes in a single action of type Handler App App (), and returns something of type Handler App App (). Essentially, the argument we’re taking is the handler that gets called when the HTTP authentication is successful. This means, that when we call our other handlers, they’d look something like this:

exampleHandler :: Handler App App ()

exampleHandler = withAuth $ do

writeBS "Hello authenticated user"

As you can see, the behaviour of the handler is nicely wrapped within withAuth .

Getting the Authorization header

Anyway, the rest of the intermediary looks a bit like this:

withAuth successful = do

rq throwChallenge

Just _ -> throwDenied

Firstly, it gets the current Request from the Snap monad, which Handler implements. We extract the Authorization header from it – note the use of let , because getHeader doesn’t operate within any of Handler‘s monads.

We then call to an external function called parseAuthorizationHeader to turn the value that could be the Authorization header into a value of type Maybe AuthHeader. We say it could be, because we can’t actually assume that the Request actually contains an Authorization header. To this end, getHeader actually returns a value of type Maybe ByteString, to allow for the possibility that the Request doesn’t have one.

parseAuthorizationHeader looks a bit like this:

parseAuthorizationHeader :: Maybe ByteString -> Maybe AuthHeader

parseAuthorizationHeader bs =

case bs of

Nothing -> Nothing

Just x ->

case (S.split ' ' x) of

("Basic" : y : _) ->

if S.length y > 0 then Just $ BasicAuth y else Nothing

_ -> Nothing

Note the use of S as prefixes for ByteString manipulation functions. Let’s make sure we add import qualified Data.ByteString.Char8 as S up the top of our module so we can support the split and length functions, and so we don’t introduce unnecessary ambiguity.

Testing the Authorization header

Going back to our intermediary function:

uok

This calls out to an action called testAuthHeader , which runs in the IO monad. We can use the IO monad within Handler, but it's buried down there in the stack a bit, which means we need to use liftIO to get to it.

testAuthHandler , at its simplest, looks a bit like this:

testAuthHeader :: Maybe AuthHeader -> IO Bool

testAuthHeader Nothing = return False

testAuthHeader (Just h) = return True

As you can see, it expects any kind of AuthHeader value with some content in it. It's not very secure, and it doesn't check the provenance of this header, but at least it checks.

Since the function is of type IO Bool, we need to wrap the pure Bool value back up into a monadic one, which is what return does. The reason behind working in the IO monad is that it gives us breathing space for calling out to extend this function later on, so we can check the auth header properly against external services.

Finally, we need to do something with our uok variable - this will tell us whether we are allowed to run successful .

if uok

then successful

else

case h of

Nothing -> throwChallenge

Just _ -> throwDenied

HTTP status code handlers

We have two more actions to implement, throwChallenge and throwDenied , and both of these are Handlers. If no Authorization header was present at all, we run throwChallenge . If there was an Authorization header present, but it wasn't valid, we run throwDenied . Both actions return a response with a particular HTTP status code, and in one case, set a special HTTP header.

throwChallenge :: Handler App App ()

throwChallenge = do

modifyResponse $ (setResponseStatus 401 "Unauthorized") . (setHeader "WWW-Authenticate" "Basic realm=my-authentication")

writeBS ""

throwDenied :: Handler App App ()

throwDenied = do

modifyResponse $ setResponseStatus 403 "Access Denied"

writeBS "Access Denied"

Note the way that setResponseStatus and setHeader are wrapped in modifyResponse. This is because modifyResponse modifies the current Response in the Snap monad, and setResponseStatus and setHeader are both pure functions that modify a Response that is passed to it as an argument. By using function composition, you can chain together Response-modifying functions and pass them to modifyResponse in one go.

Once this is done, just use writeBS to write output as a ByteString , and that's it. That really is all you need to be able to get started with HTTP Authentication.

More than the basics, part 1: Decoding Basic Authorization headers

Once you've implemented the bare minimum, however, there'll be other things you'll want to do with it. Let's start with the most obvious enhancement – decoding Basic Authorization headers.

If you want to extract a username and password from your Basic authorisation header, you'll want to write something that is able to decode it. Since Basic auth headers are base64 encoded, let's install the base64-bytestring package, and import it:

import qualified Data.ByteString.Base64 as BS64

Here's an example of how this could work.

decodeAuthHeader :: AuthHeader -> Maybe (ByteString, ByteString)

decodeAuthHeader (BasicAuth x) =

case S.split ':' $ BS64.decodeLenient x of

(u:p:_) -> Just (u, p)

_ -> Nothing

It's more rigorous to use Data.ByteString.Base64.decode instead of decodeLenient , but this is the simplest way to show how it will work.

Once you've got a decoded ByteString, you can split on the colon character, and then see if the resulting list has at least two elements. If it does, return the first two in a tuple, and wrap it in Just so we know that we have something good. For everything else, we just return a Nothing, because after all, we have nothing!

Also, note that when you're dealing with external services, you might not even need to decode the Basic Authorization header. We'll show you why next.

More than the basics, part 2: Authenticating against external sources

At some point you're going to want to define a data source to call out to, and configure it at launch time somehow. Now we're going to have to delve into Snap's more advanced functionality!

Note: this method doesn't really delve into Snaplet construction, but it does shed a little light on how you might be able to satisfy this one particular case.

Configuring your application to use external services

The easiest way to configure your application is to add a new parameter to your App, and populate it accordingly at launch time. You can then access the contents of this parameter within your Handlers.

First, define a new algebraic data type that will give you the information you need to connect to your external service. Let's call it BasicAuthDataSource.

data BasicAuthDataSource = AllowEverything

| MyAuthAPI {

myAuthEndpointURL :: String,

myAuthEndpointMethod :: String

}

This type defines two data sources. One is a dummy source that just allows every request that gets handed to it, and the other is an external service that is defined by a URL and HTTP method.

Now, we need to create a value to store state for Snap. Let's call this one BasicAuthManager, and define a function called authDataSource , so it's easy to pull the BasicAuthDataSource out when we need it.

data BasicAuthManager =

BasicAuthManager {

authDataSource :: BasicAuthDataSource

}

Now, you need to add the BasicAuthManager to your App. Go to your Application.hs file, and look for the definition of App. Add a new parameter for your BasicAuthManager right at the end:

data App = App

{ _heist :: Snaplet (Heist App)

, _httpauth :: BasicAuthManager BasicAuthDataSource

}

Finally, go to your Site.hs file, and note how your App is composed right at the end of the function. One example of how you might define your BasicAuthManager might be as follows:

app :: SnapletInit App App

app = makeSnaplet "app" "An snaplet example application." Nothing $ do

h

Acquiring the BasicAuthDataSource within our handler

Now that we've added our BasicAuthManager to our App, let's make use of it from our withAuth wrapper.

Remember our testAuthHeader function? Let's rewrite that to make use of something that calls our external API.

testAuthHeader :: BasicAuthDataSource -> Maybe AuthHeader -> IO Bool

testAuthHeader _ Nothing = return False

testAuthHeader s (Just h) = do

u return False

Just _ -> return True

Note that we're using a BasicAuthDataSource value, and we're calling out to a new function getUser to check if we have a valid user. But how do we get our BasicAuthDataSource?

Let's go back to withAuth , and modify it to pull the _httpauth out of our App's state.

withAuth :: Handler App App () -> Handler App App ()

withAuth successful = do

rq throwChallenge

Just _ -> throwDenied

Note the appearance of gets _httpauth - this is the bit that extracts the persistent BasicAuthManager from the App. From this point, we can simply call authDataSource on it to pull out the BasicAuthDataSource, and add that to our call to testAuthHeader .

Getting a user

The final piece of the puzzle is getUser , and everything that hangs off it. Let's start by defining that for all available BasicAuthDataSource types, and a data type called AuthUser to store the details of authenticated users.

data AuthUser = AuthUser {

authUserIdentity :: ByteString,

authUserDetails :: HashMap ByteString ByteString

} deriving (Show, Eq)

getUser :: BasicAuthDataSource -> AuthHeader -> IO (Maybe AuthUser)

getUser AllowEverything (BasicAuth _) = do

return $ Just $ AuthUser "basicAuthAllowed" Data.HashMap.empty

getUser [email protected](MyAuthAPI _ _) hdr = myAuthAPIGetUser a hdr

As you can see, using AllowEverything just assumes that any AuthHeader is valid, and therefore returns an arbitrary Just AuthUser. For MyAuthAPI, we have to define a function called myAuthAPIGetUser .

myAuthAPIGetUser :: BasicAuthDataSource -> AuthHeader -> IO (Maybe AuthUser)

myAuthAPIGetUser [email protected](MyAuthAPI _ _) hdr =

handle handler $ do

resp IO (Maybe a)

handler x = do

Prelude.putStrLn $ show x

return Nothing

myAuthAPIGetUser _ _ = error "Not a valid auth type"

This consists of two stages:

Querying the API and attempting to get a JSON response Checking to see if the JSON response translates to a valid user

Along the way, it tried to catch any Exceptions that get thrown, and returns a Nothing to indicate that we couldn't get any users from the API.

Querying the API and attempting to get a JSON response

For this part, we're using the wreq package, which is a tiny little HTTP client designed for user friendliness and brevity. There are many other HTTP clients available in Haskell; this is but one of them.

myAuthAPIReqJSON :: BasicAuthDataSource -> AuthHeader -> IO (Response ByteString)

myAuthAPIReqJSON (MyAuthAPI url method) hdr =

case method of

"get" -> do

getWith opts url

"post" -> do

postWith opts url (pack "")

_ -> error "Not a valid request verb"

where

opts = defaults

& header "Authorization" .~ [pack $ rqAuthHeader hdr]

& header "Accept" .~ [pack "application/json"]

rqAuthHeader (BasicAuth x) = "Basic " ++ (unpack x)

myAuthAPIReqJSON _ _ = error "Not a valid auth type"

As you can see, we're allowing for both HTTP GET and POST methods to query our endpoint, and as you can see, we're passing the Basic Authorization header that we got as part of our request onto the API we're querying, without decoding it. Pretty nifty, eh? However, if you do need to use decodeAuthHeader to split your AuthHeader up into a username & password, now is the time to do it.

We're also making sure to set our Accept header, so we can get a JSON response (if the server is obeying us). Either way, regardless of what happens, we get a Response ByteString back from the API, and we're ready to determine if we can extract a user from it.

Checking to see if the JSON response translates to a valid user

Let's extract a user from this API response.

For the sake of argument, let's say that the API returns a user in the following form:

{

"_id": "12345",

"_url": "https://api.example.com/user/12345",

"identity": "[email protected]",

"roles": ["SystemAdministrator"]

}

We can define a temporary data type for this JSON structure that we can later translate to an AuthUser. We'll also define an instance of the ToJSON class, as defined by the aeson package.

data MyAuthAPIUser = MyAuthAPIUser {

apiUserID :: String,

apiUserURL :: String,

apiUserIdentity :: String,

apiUserRoles :: [String]

}

instance FromJSON MyAuthAPIUser where

parseJSON (Object v) = MyAuthAPIUser

v .: "_id" <>

v .: "_url" <>

v .: "identity"

v .: "roles"

parseJSON _ = error "Unexpected JSON input"

Now that we have this temporary structure, let's implement determineUserFromResponse .

determineUserFromResponse :: Response ByteString -> IO (Maybe AuthUser)

determineUserFromResponse r = do

case decode (r ^. responseBody) :: Maybe MyAuthAPIUser of

Nothing -> return Nothing

Just u -> return $ Just $ AuthUser (pack $ apiUserIdentity u) (udList u)

where

udList u = fromList $ map (\(a, b) -> (pack a, pack b)) [

("internalID", apiUserID u),

("roles", intercalate "," $ apiUserRoles u),

("url", apiUserURL u)]

We're attempting to extract the Response's body and decode it to a MyAuthAPIUser in one swoop here. If we successfully decode it, we can generate an AuthUser from the contents of the MyAuthAPI user. If we fail to decode it, we can assume that the response didn't contain a valid user at all.

And that's it – we have everything we need to get a user from the API!

Conclusion

We've taken the long way around, but I hope this has been useful, at least as far as explaining how you can perform common tasks in Snap and use application state to keep track of configuration. In a future post, I might be able to elaborate on how to turn this simple example of state within Snap into a complete Snaplet.

In future months, you'll probably start to see more web technology coming out of Anchor that is based on Haskell, and we're looking forward to building more and more stuff based on it. Hopefully I'll be able to explain some of it to you, and if there's anything we can give back to the wider community, we'll see what we can do.

Thanks to Andrew Cowie, Tran Ma, Sharif Olorin and Thomas Sutton for their proofreading and suggestions.