Network/HTTP/Lucu/Authentication.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TemplateHaskell
   6   , TypeSynonymInstances
   7   , UnicodeSyntax
   8   #-}
   9 -- |An internal module for HTTP authentication.
  10 module Network.HTTP.Lucu.Authentication
  11     ( AuthChallenge(..)
  12     , AuthCredential(..)
  13     , Realm
  14     , UserID
  15     , Password
  16     )
  17     where
  18 import Control.Monad
  19 import Data.Ascii (Ascii, AsciiBuilder)
  20 import Data.Attempt
  21 import Data.Attoparsec.Char8
  22 import qualified Data.ByteString.Base64 as B64
  23 import qualified Data.ByteString.Char8 as C8
  24 import Data.Convertible.Base
  25 import Data.Convertible.Instances.Ascii ()
  26 import Data.Convertible.Utils
  27 import Data.Default
  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 Default (Parser AuthCredential) where
  69     def = 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"