, OverloadedStrings
, UnicodeSyntax
#-}
+-- |An internal module for HTTP headers.
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
, toHeaders
, fromHeaders
- , headersP
+ , headers
, printHeaders
)
where
import Control.Applicative
+import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
import qualified Data.ByteString as BS
+import Data.List
import Data.Map (Map)
import qualified Data.Map as M
+import qualified Data.Map.Unicode as M
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
import Prelude.Unicode
newtype Headers
= case getHeaders a of
Headers m → M.lookup key m
+ hasHeader ∷ CIAscii → a → Bool
+ {-# INLINE hasHeader #-}
+ hasHeader key a
+ = case getHeaders a of
+ Headers m → key M.∈ m
+
getCIHeader ∷ CIAscii → a → Maybe CIAscii
{-# INLINE getCIHeader #-}
getCIHeader key a
field-value の先頭および末尾にある LWS は全て削除され、それ以外の
LWS は單一の SP に變換される。
-}
-headersP ∷ Parser Headers
-{-# INLINEABLE headersP #-}
-headersP = do xs ← P.many header
- crlf
- return $ toHeaders xs
+headers ∷ Parser Headers
+{-# INLINEABLE headers #-}
+headers = do xs ← P.many header
+ crlf
+ return $ toHeaders xs
where
header ∷ Parser (CIAscii, Ascii)
header = do name ← A.toCIAscii <$> token
- _ ← char ':'
+ void $ char ':'
skipMany lws
- values ← sepBy content (try lws)
+ values ← content `sepBy` try lws
skipMany (try lws)
crlf
return (name, joinValues values)
{-# INLINE content #-}
content = A.unsafeFromByteString
<$>
- takeWhile1 (\c → (¬) (isSPHT c) ∧ isText c)
+ takeWhile1 (\c → isText c ∧ c ≢ '\x20')
joinValues ∷ [Ascii] → Ascii
{-# INLINE joinValues #-}
- joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
+ joinValues = A.fromAsciiBuilder
+ ∘ mconcat
+ ∘ intersperse (A.toAsciiBuilder "\x20")
+ ∘ map A.toAsciiBuilder
printHeaders ∷ Headers → AsciiBuilder
printHeaders (Headers m)