]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Headers.hs
issue #18
[Lucu.git] / Network / HTTP / Lucu / Headers.hs
1 {-# LANGUAGE
2     FlexibleInstances
3   , GeneralizedNewtypeDeriving
4   , MultiParamTypeClasses
5   , TemplateHaskell
6   , TypeSynonymInstances
7   , OverloadedStrings
8   , UnicodeSyntax
9   #-}
10 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
11 -- |An internal module for HTTP headers.
12 module Network.HTTP.Lucu.Headers
13     ( Headers
14     , HasHeaders(..)
15
16     , headers
17     , printHeaders
18     )
19     where
20 import Control.Applicative hiding (empty)
21 import Control.Applicative.Unicode hiding ((∅))
22 import Control.Monad
23 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
24 import qualified Data.Ascii as A
25 import Data.Attoparsec.Char8 as P
26 import qualified Data.Collections.Newtype.TH as C
27 import Data.List (intersperse)
28 import qualified Data.Map as M (Map)
29 import Data.Collections
30 import Data.Collections.BaseInstances ()
31 import Data.Monoid
32 import Data.Monoid.Unicode
33 import Network.HTTP.Lucu.Parser.Http
34 import Prelude hiding (lookup, null)
35 import Prelude.Unicode
36
37 newtype Headers
38     = Headers (M.Map CIAscii Ascii)
39       deriving (Eq, Show)
40
41 class HasHeaders a where
42     getHeaders ∷ a → Headers
43     setHeaders ∷ a → Headers → a
44
45     modifyHeaders ∷ (Headers → Headers) → a → a
46     {-# INLINE modifyHeaders #-}
47     modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
48
49     getHeader ∷ CIAscii → a → Maybe Ascii
50     {-# INLINE getHeader #-}
51     getHeader = (∘ getHeaders) ∘ lookup
52
53     hasHeader ∷ CIAscii → a → Bool
54     {-# INLINE hasHeader #-}
55     hasHeader = (∘ getHeaders) ∘ member
56
57     getCIHeader ∷ CIAscii → a → Maybe CIAscii
58     {-# INLINE getCIHeader #-}
59     getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
60
61     deleteHeader ∷ CIAscii → a → a
62     {-# INLINE deleteHeader #-}
63     deleteHeader = modifyHeaders ∘ delete
64
65     setHeader ∷ CIAscii → Ascii → a → a
66     {-# INLINE setHeader #-}
67     setHeader = (modifyHeaders ∘) ∘ insertWith const
68
69 instance HasHeaders Headers where
70     getHeaders   = id
71     setHeaders _ = id
72
73 C.derive [d| instance Foldable   Headers (CIAscii, Ascii)
74              instance Collection Headers (CIAscii, Ascii)
75              instance Indexed    Headers  CIAscii  Ascii
76              instance Map        Headers  CIAscii  Ascii
77              instance SortingCollection Headers (CIAscii, Ascii)
78            |]
79
80 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
81 instance Unfoldable Headers (CIAscii, Ascii) where
82     {-# INLINE insert #-}
83     insert (key, val) (Headers m)
84         = Headers $ insertWith merge key val m
85     {-# INLINE empty #-}
86     empty     = Headers empty
87     {-# INLINE singleton #-}
88     singleton = Headers ∘ singleton
89
90 instance Monoid Headers where
91     {-# INLINE mempty #-}
92     mempty  = empty
93     {-# INLINE mappend #-}
94     mappend = insertMany
95
96 merge ∷ Ascii → Ascii → Ascii
97 {-# INLINE merge #-}
98 merge a b
99     | nullA a ∧ nullA b = (∅)
100     | nullA a           = b
101     |           nullA b = a
102     | otherwise         = a ⊕ ", " ⊕ b
103     where
104       nullA ∷ Ascii → Bool
105       {-# INLINE nullA #-}
106       nullA = null ∘ A.toByteString
107
108 {-
109   message-header = field-name ":" [ field-value ]
110   field-name     = token
111   field-value    = *( field-content | LWS )
112   field-content  = <field-value を構成し、*TEXT あるいは
113                     token, separators, quoted-string を連結
114                     したものから成る OCTET>
115
116   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
117   LWS は單一の SP に變換される。
118 -}
119 headers ∷ Parser Headers
120 {-# INLINEABLE headers #-}
121 headers = do xs ← P.many header
122              crlf
123              return $ fromFoldable xs
124     where
125       header ∷ Parser (CIAscii, Ascii)
126       header = do name ← A.toCIAscii <$> token
127                   void $ char ':'
128                   skipMany lws
129                   values ← content `sepBy` try lws
130                   skipMany (try lws)
131                   crlf
132                   return (name, joinValues values)
133
134       content ∷ Parser Ascii
135       {-# INLINE content #-}
136       content = A.unsafeFromByteString
137                 <$>
138                 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
139
140       joinValues ∷ [Ascii] → Ascii
141       {-# INLINE joinValues #-}
142       joinValues = A.fromAsciiBuilder
143                    ∘ mconcat
144                    ∘ intersperse (A.toAsciiBuilder "\x20")
145                    ∘ (A.toAsciiBuilder <$>)
146
147 printHeaders ∷ Headers → AsciiBuilder
148 printHeaders (Headers m)
149     = mconcat (printHeader <$> fromFoldable m) ⊕
150       A.toAsciiBuilder "\x0D\x0A"
151     where
152       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
153       printHeader (name, value)
154           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
155             A.toAsciiBuilder ": "                 ⊕
156             A.toAsciiBuilder value                ⊕
157             A.toAsciiBuilder "\x0D\x0A"