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