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 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 (Map)
import Data.Collections
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
-import Prelude hiding (filter, foldl, foldl1, foldr, foldr1, lookup, null)
+import Prelude hiding (lookup, null)
import Prelude.Unicode
newtype 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 #-}
{-# INLINE singleton #-}
singleton = Headers ∘ singleton
--- FIXME: auto-derive
-instance Foldable Headers (CIAscii, Ascii) where
- {-# INLINE fold #-}
- fold (Headers m) = fold m
- {-# INLINE foldMap #-}
- foldMap f (Headers m) = foldMap f m
- {-# INLINE foldr #-}
- foldr f b (Headers m) = foldr f b m
- {-# INLINE foldl #-}
- foldl f b (Headers m) = foldl f b m
- {-# INLINE foldr1 #-}
- foldr1 f (Headers m) = foldr1 f m
- {-# INLINE foldl1 #-}
- foldl1 f (Headers m) = foldl1 f m
- {-# INLINE null #-}
- null (Headers m) = null m
- {-# INLINE size #-}
- size (Headers m) = size m
- {-# INLINE isSingleton #-}
- isSingleton (Headers m) = isSingleton m
-
--- FIXME: auto-derive
-instance Collection Headers (CIAscii, Ascii) where
- {-# INLINE filter #-}
- filter f (Headers m) = Headers $ filter f m
-
--- FIXME: auto-derive
-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
- {-# INLINE (//) #-}
- Headers m // l = Headers $ m // l
- {-# INLINE accum #-}
- accum f (Headers m) l = Headers $ accum f m l
-
instance Monoid Headers where
{-# INLINE mempty #-}
mempty = empty
{-# INLINE mappend #-}
mappend = insertMany
--- FIXME: auto-derive
-instance Map Headers CIAscii Ascii where
- {-# INLINE delete #-}
- delete k (Headers m) = Headers $ delete k m
- {-# INLINE member #-}
- member k (Headers m) = member k m
- {-# INLINE union #-}
- union (Headers α) (Headers β)
- = Headers $ union α β
- {-# INLINE intersection #-}
- intersection (Headers α) (Headers β)
- = Headers $ intersection α β
- {-# INLINE difference #-}
- difference (Headers α) (Headers β)
- = Headers $ difference α β
- {-# INLINE isSubset #-}
- isSubset (Headers α) (Headers β)
- = isSubset α β
- {-# INLINE isProperSubset #-}
- isProperSubset (Headers α) (Headers β)
- = isProperSubset α β
- {-# INLINE lookup #-}
- lookup k (Headers m) = lookup k m
- {-# INLINE alter #-}
- alter f k (Headers m)
- = Headers $ alter f k m
- {-# INLINE insertWith #-}
- insertWith f k v (Headers m)
- = Headers $ insertWith f k v m
- {-# INLINE fromFoldableWith #-}
- fromFoldableWith = (Headers ∘) ∘ fromFoldableWith
- {-# INLINE foldGroups #-}
- foldGroups = ((Headers ∘) ∘) ∘ foldGroups
- {-# 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 α β
-
--- FIXME: auto-derive
-instance SortingCollection Headers (CIAscii, Ascii) where
- {-# INLINE minView #-}
- minView (Headers m) = second Headers <$> minView m
-
merge ∷ Ascii → Ascii → Ascii
{-# INLINE merge #-}
merge a b
{-# 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 <$>)
projects / Lucu.git / blobdiff