BasicAuth.hs

module Lucienne.Controller.BasicAuth
  (basicAuth)
where

import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as Base64
import           Happstack.Server.Monads (escape,getHeaderM,setHeaderM)
import           Happstack.Server.Response (unauthorized)
import           Lucienne.Controller.Imports
import qualified Lucienne.Database as DB
import           Lucienne.Constant (programName)

basicAuth :: (User -> Controller Response) -> Controller Response
basicAuth protected = do
  header <- getHeaderM "authorization"
  case header of
    Nothing -> notAuthorized
    Just h  -> 
      case parseHeader h of
        Right (name, ':':password) -> do
          user <- lift $ DB.userByNameAndPassword name password
          case user of
            Nothing -> notAuthorized
            Just u  -> protected u
        _ -> notAuthorized

    where 
      parseHeader header = 
        fmap (break (':'==) . B.unpack) $ Base64.decode $ B.drop 6 $ header

      headerValue = "Basic realm=\"" ++ programName ++ "\""

      notAuthorized = 
        escape $ do
                setHeaderM "WWW-Authenticate" headerValue
                unauthorized $ toResponse ("Not authorized" :: String)