Using Data.Vault in Scotty to store a redis connection for action handlers.

FocusAuth.hs

{-# LANGUAGE OverloadedStrings #-}

module Focus.Auth where

import qualified Database.Redis as R
import Crypto.BCrypt (validatePassword, hashPasswordUsingPolicy, fastBcryptHashingPolicy)

import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Control.Monad.Trans (liftIO)

-- * Authentication

checkAuth :: ByteString -> ByteString -> R.Redis (Maybe ByteString)
checkAuth login pwd = do
    a <- R.get (authField login)
    case a of
        Right (Just auth) -> if validatePassword auth pwd
                                 then return $! Just login
                                 else return Nothing
        _ -> return Nothing

setPassword :: ByteString -> ByteString -> R.Redis ()
setPassword login newpwd = do
    Just auth <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy newpwd
    R.set (authField login) auth
    return ()

authField login = BS.concat ["auth:", login]

scotty-vault.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Web.Scotty (scotty, ScottyM, ActionM, next, middleware, get, param, request, status, header, json, html, text)
import Network.Wai (Middleware, Request(Request, queryString, requestHeaders, vault), responseLBS)
import Network.HTTP.Types (unauthorized401)
import qualified Database.Redis as R

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Base64 (decodeLenient)

import qualified Data.Map as M
import qualified Data.Vault as V
import Data.Maybe (fromMaybe, fromJust, isJust)
import Control.Monad (liftM, unless, guard)
import Control.Monad.Trans (liftIO)

import qualified Focus.Auth as FA

main :: IO ()
main = scotty 3000 app

unAuthorized :: ActionM ()
unAuthorized = do
    status unauthorized401
    header "WWW-Authenticate" "Basic realm=\"Protected\""
    text "Authentication required."

-- | Update a vault value in a request.
setVault :: Request -> V.Key a -> a -> Request
setVault req key value = req { vault = V.insert key value (vault req)}

-- | Extract a vault value from a request which must be set already.
getVault :: Request -> V.Key a -> a
getVault req key = fromJust $ V.lookup key (vault req)

-- | Get a vault value from inside an ActionM.
lookVault :: V.Key a -> ActionM a
lookVault key = request >>= return . fromJust . V.lookup key . vault

app :: ScottyM ()
app = do
    rkey <- liftIO V.newKey
    middleware $ connectRedis rkey

    akey <- liftIO V.newKey
    middleware $ basicAuth akey (redisCheckAuth rkey)
    middleware $ siteLockdown akey

    get "/favicon.ico" $ html "ಠ_ಠ"

    get "/service/:alias/:method" $ do
        r <- request

        rcon <- lookVault rkey
        let redis = liftIO . R.runRedis rcon

        lols <- redis $ R.incrby "ololo:canned-function" 1

        auth <- lookVault akey
        liftIO . putStrLn $ "Auth get: " ++ show auth
    
        -- crashes too hard with 500
        -- unless (isJust auth) $ fail "not authorized"

        -- Works, but too clunky. Even more messy for multiple actions.
        case auth of
            Nothing -> unAuthorized
            Just login -> do
                method <- param "method"
                html $ method

    get "/another/" $ do
        auth <- lookVault akey
        case auth of
            Nothing -> unAuthorized
            Just login -> html "Hi there!"

-- * Middleware

-- ** Redis connection

connectRedis :: V.Key R.Connection -> Middleware
connectRedis key app req = do
    rcon <- liftIO $ R.connect R.defaultConnectInfo {R.connectPort = R.UnixSocket "redis.sock"}
    liftIO $ putStrLn "Redis connected."

    response <- app $ setVault req key rcon

    liftIO . R.runRedis rcon $ R.quit
    liftIO $ putStrLn "Redis closed."

    return $! response

-- ** Authorization

type AuthResult = Maybe ByteString
type AuthChecker = Request -> ByteString -> ByteString -> IO AuthResult

-- | Extract auth headers and hand them out to checker function.
basicAuth :: V.Key AuthResult -> AuthChecker -> Middleware
basicAuth akey check app req = do
    let creds = case [v | (k, v) <- requestHeaders req, k == "Authorization" ] of
                 [value] -> Just $ BS.split ':' . decodeLenient . head . drop 1 . BS.split ' ' $ value
                 _ -> Nothing

    auth <- case creds of
        Just [login, password] -> liftIO $ check req login password
        _ -> return Nothing

    liftIO . putStrLn $ "Auth set: " ++ show auth
    app $ setVault req akey auth

-- | Process auth credentials using previously-stored redis connection.
redisCheckAuth :: V.Key R.Connection -> AuthChecker
redisCheckAuth rkey req login password = R.runRedis (getVault req rkey) $ FA.checkAuth login password

-- | Check authorization for every request.
siteLockdown :: V.Key AuthResult -> Middleware
siteLockdown akey app req = do
    if isJust $ getVault req akey
        then app req
        else return $ responseLBS
                      unauthorized401
                      [ ("Content-Type", "text/plain")
                      , ("WWW-Authenticate", "Basic realm=\"Protected\"") ]
                      "Authentication required."