]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Authorization.hs
d085234b5e1b4cf8c7c71cae9a10bb059c167a7c
[Lucu.git] / Network / HTTP / Lucu / Authorization.hs
1 {-# LANGUAGE
2     UnicodeSyntax
3   #-}
4 {-# OPTIONS_HADDOCK prune #-}
5
6 -- |Manipulation of WWW authorization.
7 module Network.HTTP.Lucu.Authorization
8     ( AuthChallenge(..)
9     , AuthCredential(..)
10     , Realm
11     , UserID
12     , Password
13
14     , authCredentialP -- private
15     )
16     where
17 import Data.Ascii (Ascii)
18 import qualified Data.Ascii as A
19 import qualified Data.ByteString.Base64 as B64
20 import qualified Data.ByteString.Char8 as C8
21 import Network.HTTP.Lucu.Parser.Http
22 import Network.HTTP.Lucu.Utils
23 import Prelude.Unicode
24
25 -- |Authorization challenge to be sent to client with
26 -- \"WWW-Authenticate\" header. See
27 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
28 data AuthChallenge
29     = BasicAuthChallenge Realm
30       deriving (Eq)
31
32 -- |'Realm' is just a string which must not contain any non-ASCII letters.
33 type Realm = Ascii
34
35 -- |Authorization credential to be sent by client with
36 -- \"Authorization\" header. See
37 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
38 data AuthCredential
39     = BasicAuthCredential UserID Password
40       deriving (Show, Eq)
41
42 -- |'UserID' is just a string which must not contain colon and any
43 -- non-ASCII letters.
44 type UserID   = Ascii
45
46 -- |'Password' is just a string which must not contain any non-ASCII
47 -- letters.
48 type Password = Ascii
49
50 -- FIXME: Don't use String for network output.
51 instance Show AuthChallenge where
52     show (BasicAuthChallenge realm)
53         = "Basic realm=" ⧺ quoteStr realm
54
55 authCredentialP ∷ Parser AuthCredential
56 authCredentialP
57     = allowEOF $!
58       do _   ← string "Basic"
59          _   ← many1 lws
60          b64 ← many1
61                $ satisfy (\c → (c ≥ 'a' ∧ c ≤ 'z') ∨
62                                (c ≥ 'A' ∧ c ≤ 'Z') ∨
63                                (c ≥ '0' ∧ c ≤ '9') ∨
64                                 c ≡ '+' ∨
65                                 c ≡ '/' ∨
66                                 c ≡ '=')
67          case break (≡ ':') (decode b64) of
68            (uid, ':' : password)
69                → return (BasicAuthCredential uid password)
70            _   → failP
71     where
72       decode ∷ String → String
73       decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack