Auth.hs

module CQRSExample.Controller.Auth
       ( basicAuth
       ) where

import           Control.Monad.Trans.Class (lift)
import qualified Data.ByteString.Char8 as B
import           Data.Foldable (foldMap)
import qualified Happstack.Crypto.Base64 as Base64
import           Happstack.Lite (ServerPart, Response)
import           Happstack.Server.Monads (setHeaderM, getHeaderM, escape)
import           Happstack.Server.Response (unauthorized, toResponse)

-- | Support for Basic Auth.
basicAuth :: String -> (String -> String -> IO Bool) -> (String -> ServerPart Response) -> ServerPart Response
basicAuth realmName authMap rest = do
  aHeader <- getHeaderM "authorization"
  case foldMap parseHeader aHeader of
    (name, ':':password) -> do
      found <- lift $ authMap name password
      case found of
        True -> rest name
        False -> err
    _  -> err
  where
    parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6
    headerName  = "WWW-Authenticate"
    headerValue = "Basic realm=\"" ++ realmName ++ "\""
    err = escape $ do
            setHeaderM headerName headerValue
            unauthorized $ toResponse ("Not authorized" :: String)