Network/HTTP/Lucu/Authentication.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |An internal module for HTTP authentication.
   9 module Network.HTTP.Lucu.Authentication
  10     ( AuthChallenge(..)
  11     , AuthCredential(..)
  12     , Realm
  13     , UserID
  14     , Password
  15     )
  16     where
  17 import Control.Monad
  18 import Data.Ascii (Ascii, AsciiBuilder)
  19 import Data.Attempt
  20 import Data.Attoparsec.Char8
  21 import Data.Attoparsec.Parsable
  22 import qualified Data.ByteString.Base64 as B64
  23 import Data.ByteString (ByteString)
  24 import qualified Data.ByteString.Char8 as C8
  25 import Data.Convertible.Base
  26 import Data.Convertible.Instances.Ascii ()
  27 import Data.Convertible.Utils
  28 import Data.Monoid.Unicode
  29 import Network.HTTP.Lucu.Parser.Http
  30 import Network.HTTP.Lucu.Utils
  31 import Prelude.Unicode
  32
  33 -- |Authentication challenge to be sent to clients with
  34 -- \"WWW-Authenticate\" header field. See
  35 -- 'Network.HTTP.Lucu.setWWWAuthenticate'.
  36 data AuthChallenge
  37     = BasicAuthChallenge !Realm
  38       deriving (Eq)
  39
  40 -- |'Realm' is just an 'Ascii' string.
  41 type Realm = Ascii
  42
  43 -- |Authorization credential to be sent by client with
  44 -- \"Authorization\" header. See 'Network.HTTP.Lucu.getAuthorization'.
  45 data AuthCredential
  46     = BasicAuthCredential !UserID !Password
  47       deriving (Show, Eq)
  48
  49 -- |'UserID' is just an 'Ascii' string containing no colons (\':\').
  50 type UserID = Ascii
  51
  52 -- |'Password' is just an 'Ascii' string.
  53 type Password = Ascii
  54
  55 instance ConvertSuccess AuthChallenge Ascii where
  56     {-# INLINE convertSuccess #-}
  57     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  58
  59 instance ConvertSuccess AuthChallenge AsciiBuilder where
  60     {-# INLINE convertSuccess #-}
  61     convertSuccess (BasicAuthChallenge realm)
  62         = cs ("Basic realm=" ∷ Ascii) ⊕ quoteStr realm
  63
  64 deriveAttempts [ ([t| AuthChallenge |], [t| Ascii        |])
  65                , ([t| AuthChallenge |], [t| AsciiBuilder |])
  66                ]
  67
  68 instance Parsable ByteString AuthCredential where
  69     parser = do void $ string "Basic"
  70                 skipMany1 lws
  71                 b64 ← takeWhile1 base64
  72                 case C8.break (≡ ':') (B64.decodeLenient b64) of
  73                   (user, cPassword)
  74                       | C8.null cPassword
  75                           → fail "no colons in the basic auth credential"
  76                       | otherwise
  77                           → do u ← asc user
  78                                p ← asc (C8.tail cPassword)
  79                                return (BasicAuthCredential u p)
  80         where
  81           base64 ∷ Char → Bool
  82           base64 = inClass "a-zA-Z0-9+/="
  83
  84           asc ∷ C8.ByteString → Parser Ascii
  85           asc bs
  86               = case ca bs of
  87                   Success as → return as
  88                   Failure _  → fail "Non-ascii character in auth credential"