WaiAuth.hs

module CQRSExample.WaiAuth
       ( basicAuth
       ) where

import           Control.Monad.Trans.Class (lift)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Base64 as B64
import           Data.Foldable (foldMap)
import           Network.HTTP.Types (status401)
import           Network.Wai (Application, Request, Response, responseLBS, requestHeaders)

-- | Support for Basic Auth.
basicAuth :: String -> (String -> String -> IO (Maybe a)) -> (a -> Application) -> Application
basicAuth realmName authMap app req = do
  let aHeader = lookup "authorization" $ requestHeaders req
  case foldMap parseHeader aHeader of
    (name, ':':password) -> do
      found <- lift $ authMap name password
      case found of
        Just a -> app a req
        Nothing -> err
    _  -> err
  where
    -- TODO: Redo this hack.
    parseHeader = break (':'==) . f . B64.decode . B.drop 6
    f (Left _) = "error"
    f (Right s) = B8.unpack s
    err = return $ unauthorized realmName

-- Generate an "unauthorized" response.
unauthorized :: String -> Response
unauthorized realmName =
  responseLBS status401
  [ ("Content-Type", "text/plain")
  , ("WWW-Authenticate", B8.pack $ "Basic realm=\"" ++ realmName ++ "\"")
  ]
  "Not authorized"