FlexibleInstances
, GeneralizedNewtypeDeriving
, MultiParamTypeClasses
+ , TemplateHaskell
, TypeSynonymInstances
, OverloadedStrings
, UnicodeSyntax
#-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
-- |An internal module for HTTP headers.
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
-
- , headers
- , printHeaders
)
where
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Applicative.Unicode hiding ((∅))
-import Control.Arrow
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
+import qualified Data.Collections.Newtype.TH as C
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.Default
import Data.List (intersperse)
-import qualified Data.Map as M
+import qualified Data.Map as M (Map)
import Data.Collections
import Data.Collections.BaseInstances ()
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
-import Prelude hiding (filter, lookup, null)
+import Prelude hiding (lookup, null)
import Prelude.Unicode
newtype Headers
= Headers (M.Map CIAscii Ascii)
- deriving (Eq, Monoid, Show)
+ deriving (Eq, Show)
class HasHeaders a where
getHeaders ∷ a → Headers
getCIHeader ∷ CIAscii → a → Maybe CIAscii
{-# INLINE getCIHeader #-}
- getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
+ getCIHeader = ((cs <$>) ∘) ∘ getHeader
deleteHeader ∷ CIAscii → a → a
{-# INLINE deleteHeader #-}
getHeaders = id
setHeaders _ = id
+C.derive [d| instance Foldable Headers (CIAscii, Ascii)
+ instance Collection Headers (CIAscii, Ascii)
+ instance Indexed Headers CIAscii Ascii
+ instance Map Headers CIAscii Ascii
+ instance SortingCollection Headers (CIAscii, Ascii)
+ |]
+
-- |@'insert' (key, val)@ merges @val@ with an existing one if any.
instance Unfoldable Headers (CIAscii, Ascii) where
{-# INLINE insert #-}
insert (key, val) (Headers m)
= Headers $ insertWith merge key val m
+ {-# INLINE empty #-}
+ empty = Headers empty
+ {-# INLINE singleton #-}
+ singleton = Headers ∘ singleton
-instance Foldable Headers (CIAscii, Ascii) where
- {-# INLINE foldMap #-}
- foldMap f (Headers m) = foldMap f m
-
-instance Collection Headers (CIAscii, Ascii) where
- {-# INLINE filter #-}
- filter f (Headers m) = Headers $ filter f m
-
-instance Indexed Headers CIAscii Ascii where
- {-# INLINE index #-}
- index k (Headers m) = index k m
- {-# INLINE adjust #-}
- adjust f k (Headers m) = Headers $ adjust f k m
- {-# INLINE inDomain #-}
- inDomain k (Headers m) = inDomain k m
-
-instance Map Headers CIAscii Ascii where
- {-# INLINE lookup #-}
- lookup k (Headers m) = lookup k m
- {-# INLINE insertWith #-}
- insertWith f k v (Headers m)
- = Headers $ insertWith f k v m
- {-# INLINE mapWithKey #-}
- mapWithKey f (Headers m)
- = Headers $ mapWithKey f m
- {-# INLINE unionWith #-}
- unionWith f (Headers α) (Headers β)
- = Headers $ unionWith f α β
- {-# INLINE intersectionWith #-}
- intersectionWith f (Headers α) (Headers β)
- = Headers $ intersectionWith f α β
- {-# INLINE differenceWith #-}
- differenceWith f (Headers α) (Headers β)
- = Headers $ differenceWith f α β
- {-# INLINE isSubmapBy #-}
- isSubmapBy f (Headers α) (Headers β)
- = isSubmapBy f α β
- {-# INLINE isProperSubmapBy #-}
- isProperSubmapBy f (Headers α) (Headers β)
- = isProperSubmapBy f α β
-
-instance SortingCollection Headers (CIAscii, Ascii) where
- {-# INLINE minView #-}
- minView (Headers m) = second Headers <$> minView m
+instance Monoid Headers where
+ {-# INLINE mempty #-}
+ mempty = empty
+ {-# INLINE mappend #-}
+ mappend = insertMany
merge ∷ Ascii → Ascii → Ascii
{-# INLINE merge #-}
{-# INLINE nullA #-}
nullA = null ∘ A.toByteString
+instance ConvertSuccess Headers Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess Headers AsciiBuilder where
+ {-# INLINEABLE convertSuccess #-}
+ convertSuccess (Headers m)
+ = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii)
+ where
+ header ∷ (CIAscii, Ascii) → AsciiBuilder
+ {-# INLINE header #-}
+ header (name, value)
+ = cs name ⊕
+ cs (": " ∷ Ascii) ⊕
+ cs value ⊕
+ cs ("\x0D\x0A" ∷ Ascii)
+
+deriveAttempts [ ([t| Headers |], [t| Ascii |])
+ , ([t| Headers |], [t| AsciiBuilder |])
+ ]
+
{-
message-header = field-name ":" [ field-value ]
field-name = token
field-value の先頭および末尾にある LWS は全て削除され、それ以外の
LWS は單一の SP に變換される。
-}
-headers ∷ Parser Headers
-{-# INLINEABLE headers #-}
-headers = do xs ← P.many header
+instance Default (Parser Headers) where
+ {-# INLINEABLE def #-}
+ def = do xs ← many header
crlf
return $ fromFoldable xs
- where
- header ∷ Parser (CIAscii, Ascii)
- header = do name ← A.toCIAscii <$> token
- void $ char ':'
- skipMany lws
- values ← content `sepBy` try lws
- skipMany (try lws)
- crlf
- return (name, joinValues values)
-
- content ∷ Parser Ascii
- {-# INLINE content #-}
- content = A.unsafeFromByteString
- <$>
- takeWhile1 (\c → isText c ∧ c ≢ '\x20')
-
- joinValues ∷ [Ascii] → Ascii
- {-# INLINE joinValues #-}
- joinValues = A.fromAsciiBuilder
- ∘ mconcat
- ∘ intersperse (A.toAsciiBuilder "\x20")
- ∘ map A.toAsciiBuilder
-
-printHeaders ∷ Headers → AsciiBuilder
-printHeaders (Headers m)
- = mconcat (map printHeader (fromFoldable m)) ⊕
- A.toAsciiBuilder "\x0D\x0A"
- where
- printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
- printHeader (name, value)
- = A.toAsciiBuilder (A.fromCIAscii name) ⊕
- A.toAsciiBuilder ": " ⊕
- A.toAsciiBuilder value ⊕
- A.toAsciiBuilder "\x0D\x0A"
+ where
+ header ∷ Parser (CIAscii, Ascii)
+ {-# INLINEABLE header #-}
+ header = do name ← cs <$> token
+ void $ char ':'
+ skipMany lws
+ values ← content `sepBy` try lws
+ skipMany (try lws)
+ crlf
+ return (name, joinValues values)
+
+ content ∷ Parser Ascii
+ {-# INLINEABLE content #-}
+ content = A.unsafeFromByteString
+ <$>
+ takeWhile1 (\c → isText c ∧ c ≢ '\x20')
+
+ joinValues ∷ [Ascii] → Ascii
+ {-# INLINEABLE joinValues #-}
+ joinValues = cs
+ ∘ mconcat
+ ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
+ ∘ (cs <$>)