Network/HTTP/Lucu/Headers.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , GeneralizedNewtypeDeriving
   4   , MultiParamTypeClasses
   5   , TypeSynonymInstances
   6   , OverloadedStrings
   7   , UnicodeSyntax
   8   #-}
   9 -- |An internal module for HTTP headers.
  10 module Network.HTTP.Lucu.Headers
  11     ( Headers
  12     , HasHeaders(..)
  13
  14     , headers
  15     , printHeaders
  16     )
  17     where
  18 import Control.Applicative hiding (empty)
  19 import Control.Applicative.Unicode hiding ((∅))
  20 import Control.Arrow
  21 import Control.Monad
  22 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  23 import qualified Data.Ascii as A
  24 import Data.Attoparsec.Char8 as P
  25 import Data.List (intersperse)
  26 import qualified Data.Map as M (Map)
  27 import Data.Collections
  28 import Data.Collections.BaseInstances ()
  29 import Data.Monoid
  30 import Data.Monoid.Unicode
  31 import Network.HTTP.Lucu.Parser.Http
  32 import Prelude hiding (filter, foldr, lookup, null)
  33 import Prelude.Unicode
  34
  35 newtype Headers
  36     = Headers (M.Map CIAscii Ascii)
  37       deriving (Eq, Show)
  38
  39 class HasHeaders a where
  40     getHeaders ∷ a → Headers
  41     setHeaders ∷ a → Headers → a
  42
  43     modifyHeaders ∷ (Headers → Headers) → a → a
  44     {-# INLINE modifyHeaders #-}
  45     modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
  46
  47     getHeader ∷ CIAscii → a → Maybe Ascii
  48     {-# INLINE getHeader #-}
  49     getHeader = (∘ getHeaders) ∘ lookup
  50
  51     hasHeader ∷ CIAscii → a → Bool
  52     {-# INLINE hasHeader #-}
  53     hasHeader = (∘ getHeaders) ∘ member
  54
  55     getCIHeader ∷ CIAscii → a → Maybe CIAscii
  56     {-# INLINE getCIHeader #-}
  57     getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
  58
  59     deleteHeader ∷ CIAscii → a → a
  60     {-# INLINE deleteHeader #-}
  61     deleteHeader = modifyHeaders ∘ delete
  62
  63     setHeader ∷ CIAscii → Ascii → a → a
  64     {-# INLINE setHeader #-}
  65     setHeader = (modifyHeaders ∘) ∘ insertWith const
  66
  67 instance HasHeaders Headers where
  68     getHeaders   = id
  69     setHeaders _ = id
  70
  71 -- |@'insert' (key, val)@ merges @val@ with an existing one if any.
  72 instance Unfoldable Headers (CIAscii, Ascii) where
  73     {-# INLINE insert #-}
  74     insert (key, val) (Headers m)
  75         = Headers $ insertWith merge key val m
  76     {-# INLINE empty #-}
  77     empty
  78         = Headers empty
  79     {-# INLINE singleton #-}
  80     singleton p
  81         = Headers $ singleton p
  82     {-# INLINE insertMany #-}
  83     insertMany f (Headers m)
  84         = Headers $ insertMany f m
  85     {-# INLINE insertManySorted #-}
  86     insertManySorted f (Headers m)
  87         = Headers $ insertManySorted f m
  88
  89 instance Foldable Headers (CIAscii, Ascii) where
  90     {-# INLINE null #-}
  91     null (Headers m) = null m
  92     {-# INLINE size #-}
  93     size (Headers m) = size m
  94     {-# INLINE foldr #-}
  95     foldr f b (Headers m) = foldr f b m
  96
  97 instance Collection Headers (CIAscii, Ascii) where
  98     {-# INLINE filter #-}
  99     filter f (Headers m) = Headers $ filter f m
 100
 101 instance Indexed Headers CIAscii Ascii where
 102     {-# INLINE index #-}
 103     index k (Headers m) = index k m
 104     {-# INLINE adjust #-}
 105     adjust f k (Headers m) = Headers $ adjust f k m
 106     {-# INLINE inDomain #-}
 107     inDomain k (Headers m) = inDomain k m
 108
 109 instance Monoid Headers where
 110     {-# INLINE mempty #-}
 111     mempty = empty
 112     {-# INLINE mappend #-}
 113     mappend (Headers α) (Headers β)
 114         = Headers $ insertManySorted β α
 115
 116 -- FIXME: override every methods
 117 instance Map Headers CIAscii Ascii where
 118     {-# INLINE lookup #-}
 119     lookup k (Headers m) = lookup k m
 120     {-# INLINE insertWith #-}
 121     insertWith f k v (Headers m)
 122         = Headers $ insertWith f k v m
 123     {-# INLINE mapWithKey #-}
 124     mapWithKey f (Headers m)
 125         = Headers $ mapWithKey f m
 126     {-# INLINE unionWith #-}
 127     unionWith f (Headers α) (Headers β)
 128         = Headers $ unionWith f α β
 129     {-# INLINE intersectionWith #-}
 130     intersectionWith f (Headers α) (Headers β)
 131         = Headers $ intersectionWith f α β
 132     {-# INLINE differenceWith #-}
 133     differenceWith f (Headers α) (Headers β)
 134         = Headers $ differenceWith f α β
 135     {-# INLINE isSubmapBy #-}
 136     isSubmapBy f (Headers α) (Headers β)
 137         = isSubmapBy f α β
 138     {-# INLINE isProperSubmapBy #-}
 139     isProperSubmapBy f (Headers α) (Headers β)
 140         = isProperSubmapBy f α β
 141
 142 instance SortingCollection Headers (CIAscii, Ascii) where
 143     {-# INLINE minView #-}
 144     minView (Headers m) = second Headers <$> minView m
 145
 146 merge ∷ Ascii → Ascii → Ascii
 147 {-# INLINE merge #-}
 148 merge a b
 149     | nullA a ∧ nullA b = (∅)
 150     | nullA a           = b
 151     |           nullA b = a
 152     | otherwise         = a ⊕ ", " ⊕ b
 153     where
 154       nullA ∷ Ascii → Bool
 155       {-# INLINE nullA #-}
 156       nullA = null ∘ A.toByteString
 157
 158 {-
 159   message-header = field-name ":" [ field-value ]
 160   field-name     = token
 161   field-value    = *( field-content | LWS )
 162   field-content  = <field-value を構成し、*TEXT あるいは
 163                     token, separators, quoted-string を連結
 164                     したものから成る OCTET>
 165
 166   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 167   LWS は單一の SP に變換される。
 168 -}
 169 headers ∷ Parser Headers
 170 {-# INLINEABLE headers #-}
 171 headers = do xs ← P.many header
 172              crlf
 173              return $ fromFoldable xs
 174     where
 175       header ∷ Parser (CIAscii, Ascii)
 176       header = do name ← A.toCIAscii <$> token
 177                   void $ char ':'
 178                   skipMany lws
 179                   values ← content `sepBy` try lws
 180                   skipMany (try lws)
 181                   crlf
 182                   return (name, joinValues values)
 183
 184       content ∷ Parser Ascii
 185       {-# INLINE content #-}
 186       content = A.unsafeFromByteString
 187                 <$>
 188                 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
 189
 190       joinValues ∷ [Ascii] → Ascii
 191       {-# INLINE joinValues #-}
 192       joinValues = A.fromAsciiBuilder
 193                    ∘ mconcat
 194                    ∘ intersperse (A.toAsciiBuilder "\x20")
 195                    ∘ map A.toAsciiBuilder
 196
 197 printHeaders ∷ Headers → AsciiBuilder
 198 printHeaders (Headers m)
 199     = mconcat (map printHeader (fromFoldable m)) ⊕
 200       A.toAsciiBuilder "\x0D\x0A"
 201     where
 202       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
 203       printHeader (name, value)
 204           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
 205             A.toAsciiBuilder ": "                 ⊕
 206             A.toAsciiBuilder value                ⊕
 207             A.toAsciiBuilder "\x0D\x0A"