{-# LANGUAGE
- GeneralizedNewtypeDeriving
+ FlexibleInstances
+ , GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
+ , TypeSynonymInstances
, OverloadedStrings
, UnicodeSyntax
#-}
( Headers
, HasHeaders(..)
- , singleton
-
- , toHeaders
- , fromHeaders
-
, headers
, printHeaders
)
where
import Control.Applicative
+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 qualified Data.ByteString as BS
-import Data.List
-import Data.Map (Map)
+import Data.List (intersperse)
import qualified Data.Map as M
-import qualified Data.Map.Unicode as M
+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.Unicode
newtype Headers
- = Headers (Map CIAscii Ascii)
- deriving (Eq, Show, Monoid)
+ = Headers (M.Map CIAscii Ascii)
+ deriving (Eq, Monoid, Show)
class HasHeaders a where
getHeaders ∷ a → Headers
setHeaders ∷ a → Headers → a
+ modifyHeaders ∷ (Headers → Headers) → a → a
+ {-# INLINE modifyHeaders #-}
+ modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
+
getHeader ∷ CIAscii → a → Maybe Ascii
- getHeader key a
- = case getHeaders a of
- Headers m → M.lookup key m
+ {-# INLINE getHeader #-}
+ getHeader = (∘ getHeaders) ∘ lookup
hasHeader ∷ CIAscii → a → Bool
{-# INLINE hasHeader #-}
- hasHeader key a
- = case getHeaders a of
- Headers m → key M.∈ m
+ hasHeader = (∘ getHeaders) ∘ member
getCIHeader ∷ CIAscii → a → Maybe CIAscii
{-# INLINE getCIHeader #-}
- getCIHeader key a
- = A.toCIAscii <$> getHeader key a
+ getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
deleteHeader ∷ CIAscii → a → a
{-# INLINE deleteHeader #-}
- deleteHeader key a
- = case getHeaders a of
- Headers m
- → setHeaders a $ Headers $ M.delete key m
+ deleteHeader = modifyHeaders ∘ delete
setHeader ∷ CIAscii → Ascii → a → a
{-# INLINE setHeader #-}
- setHeader key val a
- = case getHeaders a of
- Headers m
- → setHeaders a $ Headers $ M.insert key val m
+ setHeader = (modifyHeaders ∘) ∘ insertWith const
instance HasHeaders Headers where
getHeaders = id
setHeaders _ = id
-singleton ∷ CIAscii → Ascii → Headers
-{-# INLINE singleton #-}
-singleton key val
- = Headers $ M.singleton key val
-
-toHeaders ∷ [(CIAscii, Ascii)] → Headers
-{-# INLINE toHeaders #-}
-toHeaders = flip mkHeaders (∅)
-
-mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
-mkHeaders [] (Headers m) = Headers m
-mkHeaders ((key, val):xs) (Headers m)
- = mkHeaders xs $ Headers $
- case M.lookup key m of
- Nothing → M.insert key val m
- Just old → M.insert key (merge old val) m
+-- |@'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
+
+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
+
+merge ∷ Ascii → Ascii → Ascii
+{-# INLINE merge #-}
+merge a b
+ | nullA a ∧ nullA b = (∅)
+ | nullA a = b
+ | nullA b = a
+ | otherwise = a ⊕ ", " ⊕ b
where
- merge ∷ Ascii → Ascii → Ascii
- {-# INLINE merge #-}
- merge a b
- | nullA a ∧ nullA b = (∅)
- | nullA a = b
- | nullA b = a
- | otherwise = a ⊕ ", " ⊕ b
-
nullA ∷ Ascii → Bool
{-# INLINE nullA #-}
- nullA = BS.null ∘ A.toByteString
-
-fromHeaders ∷ Headers → [(CIAscii, Ascii)]
-fromHeaders (Headers m) = M.toList m
+ nullA = null ∘ A.toByteString
{-
message-header = field-name ":" [ field-value ]
{-# INLINEABLE headers #-}
headers = do xs ← P.many header
crlf
- return $ toHeaders xs
+ return $ fromFoldable xs
where
header ∷ Parser (CIAscii, Ascii)
header = do name ← A.toCIAscii <$> token
printHeaders ∷ Headers → AsciiBuilder
printHeaders (Headers m)
- = mconcat (map printHeader (M.toList m)) ⊕
+ = mconcat (map printHeader (fromFoldable m)) ⊕
A.toAsciiBuilder "\x0D\x0A"
where
printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
projects / Lucu.git / commitdiff