Authorization.hs

{-# OPTIONS_HADDOCK prune #-}

-- |Manipulation of WWW authorization.
module Network.HTTP.Lucu.Authorization
    ( AuthChallenge(..)
    , AuthCredential(..)
    , Realm
    , UserID
    , Password

    , authCredentialP -- private
    )
    where

import qualified Codec.Binary.Base64 as B64
import           Data.Maybe
import           Network.HTTP.Lucu.Parser
import           Network.HTTP.Lucu.Parser.Http
import           Network.HTTP.Lucu.Utils

-- |Authorization challenge to be sent to client with
-- \"WWW-Authenticate\" header. See
-- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
data AuthChallenge
    = BasicAuthChallenge Realm
      deriving (Eq)

-- |'Realm' is just a string which must not contain any non-ASCII letters.
type Realm = String    

-- |Authorization credential to be sent by client with
-- \"Authorization\" header. See
-- 'Network.HTTP.Lucu.Resource.getAuthorization'.
data AuthCredential
    = BasicAuthCredential UserID Password
      deriving (Show, Eq)

-- |'UserID' is just a string which must not contain colon and any
-- non-ASCII letters.
type UserID   = String

-- |'Password' is just a string which must not contain any non-ASCII
-- letters.
type Password = String


instance Show AuthChallenge where
    show (BasicAuthChallenge realm)
        = "Basic realm=" ++ quoteStr realm


authCredentialP :: Parser AuthCredential
authCredentialP = allowEOF $!
                  do _   <- string "Basic"
                     _   <- many1 lws
                     b64 <- many1
                            $ satisfy (\ c -> (c >= 'a' && c <= 'z') ||
                                              (c >= 'A' && c <= 'Z') ||
                                              (c >= '0' && c <= '9') ||
                                              c == '+' ||
                                              c == '/' ||
                                              c == '=')
                     let decoded = map (toEnum . fromEnum) (fromJust $ B64.decode b64)
                     case break (== ':') decoded of
                       (uid, ':' : password)
                           -> return (BasicAuthCredential uid password)
                       _   -> failP