HTTP Basic auth in Snap

Recently, I’ve implemented HTTP Basic auth for darcsden and wrote a simple wreq test for it. In this post I would like to outline the main technical details.

Server side

Transient storage

A lot of darcsden code is (especially the parts that are closer to the users’ web browser — handlers, pages, so on) is written around sessions. Sessions are stored in a special storage — implemented by the DarcsDen.Backend.Transient, but if we abstract away from the details we have a Session datatype. Authorization and authentication information is handled by sessions using functions setUser :: (BTIO bt) => Maybe User -> Session -> Snap Session, notice :: (BTIO bt) => String -> Session -> Snap () (display a message to the user) and others. The BTIO bt part is just a synonym for

type BTIO bt = (BackendTransient bt, ?backendTransient :: bt, MonadIO (BackendTransientM bt))

Which basically says that we are operating with a transient backend that supports all of necessary operations, and we can also do IO in it. Right now there are only two transient backends (read: two ways of storing sessions): Redis and in-process memory.

Running sessions

If we have a piece of Snap code that we want to “sessionify” we use the following interface:

withSession :: (BTIO bt) => (Session -> Snap ()) -> Snap ()

What this does is it basically checks for a cookie — in case it is present it grabs the session information from the storage (in accordance with the cookie); if the cookie is not present it creates a new session and stores it in a cookie.

If we have a page of a type Session -> Snap (), we might want to give user an option to do HTTP authentication on that page. We introduce another function

withBasicAuth :: (BP bp, BTIO bt) 
              => (Session -> Snap ()) 
              -> (Session -> Snap ())
withBasicAuth act s = do
    rq  do
          rawHeader <- maybe throwChallenge return $ getHeader “Authorization” rq
          let (Just (usr,pw)) = getCredentials rawHeader
          c  errorPage “Unknown user”
            Just u -> if checkPassword (fromBS pw) u
                         then doLogin (fromBS usr)
                         else errorPage “Bad password”
      _ -> act s

So, what is going on in here? First of all, we check if the “login” parameter is set to “true”. If it does, we try to get the “Authorization” header, de-encode it, and check whether the credentials are good.

throwChallenge :: Snap a
throwChallenge = do
    modifyResponse $ (setResponseStatus 401 “Unauthorized”) .
                     (setHeader “WWW-Authenticate” “Basic realm=darcsdenrealm”)
    getResponse >>= finishWith

If the response header is present, it is of a form Basic x, where x is a base64 encoded string user:password. We can extract the credentials from the header like this:

import qualified Data.ByteString          as B
import qualified Data.ByteString.Base64   as B
getCredentials :: B.ByteString  — ^ Header
               -> Maybe (B.ByteString, B.ByteString) — ^ Possibly (username, password)
getCredentials header =
    if (isInfixOf “Basic “ header)
      then fmap extract (hush (B.decode (B.drop 6 header)))
      else Nothing
    extract cred = case (B.breakByte (c2w ‘:’) cred) of
                     (usr, pw) -> (usr, safeTail pw)

On the client

The tests that I am currently writing for darcsden are all of the same form: I use wreq to do requests to the darcsden server, then, if necessary, I run taggy to extract information from the webpage, and compare it to the “canonical” information.

As it turns out, doing HTTP Basic Auth is very easy with wreq! First of all, we define a function for doing a GET request that will do some exception handling for us:

getSafeOpts :: Options -> String -> IO (Either Status (Response ByteString))
getSafeOpts opts url = fmap Right (getWith opts url) `catch` hndlr
    hndlr (StatusCodeException s _ _) = return (Left s)
    hndlr e = throwIO e

This way, we won’t get a runtime exception when accessing a non-existing page or getting a server error. Doing a GET request with HTTP Basic Auth is now very easy:

getWithAuth :: (String, String) -> String -> IO (Either Status (Response ByteString))
getWithAuth (username,pw) url = getSafeOpts opts url
    opts = defaults & auth ?~ basicAuth (toBS username) (toBS pw)
                    & param “login” .~ [“true”]

In that snippet we use lenses to set up an auth header and an HTTP parameter (?login=true).

Finally, after obtaining a Response ByteString, we can parse it with taggy-lens:

parsed :: Fold (Response L.ByteString) Text.Taggy.Node
parsed = responseBody 
       . to (decodeUtf8With lenientDecode)
       . html

We can then play with it in GHCi

*Main> Right r  r ^.. parsed
[NodeElement (Element {eltName = “DOCTYPE”, eltAttrs = fromList [(“html”,””)], eltChildren = [NodeElement (Element {eltName = “html”, eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = “head”, eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = “title”, eltAttrs = fromList [], eltChildren = [NodeContent “localhost”]}),NodeElement (Element {eltName = “link”, eltAttrs = fromList [(“href”,”http://localhost:8900/public/images/favicon.ico”),…

If we want to check that we are indeed logged in correctly, we should look for the “log out” button. Taggy does all the heavy lifting for us, we just have to write down a lens (more precisely, a fold) to “extract” a logout button from the page

logoutButton :: HasElement e => Fold e Text
logoutButton = allAttributed (ix “class” . only “logout”)
             . allNamed (only “a”)
             . contents

logoutButton searches for <div class=“logout”> and returns the text in the link inside the div. There might be many such links inside the node, hence we use a fold.

*Main> r ^.. parsed . logoutButton
[“log out”]

In this case, since we only care if such link is present, we can use a preview

*Main> r ^? parsed . logoutButton
Just “log out”


Well, that’s about it for now. I regret taking way too much time writing this update, and I hope to deliver another one soon. Meanwhile, some information regarding the darcsden SoC project can be found on the wiki.

2 thoughts on “HTTP Basic auth in Snap

  1. Simon Michael

    That was very informative! Thank you.

    I wonder why did you need to implement HTTP Basic Auth, given that darcsden already seems to do authentication, and apparently the superior non-Basic kind ?


Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s