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
  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
  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, lookup, null)
  33 import Prelude.Unicode
  34
  35 newtype Headers
  36     = Headers (M.Map CIAscii Ascii)
  37       deriving (Eq, Monoid, 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
  77 instance Foldable Headers (CIAscii, Ascii) where
  78     {-# INLINE foldMap #-}
  79     foldMap f (Headers m) = foldMap f m
  80
  81 instance Collection Headers (CIAscii, Ascii) where
  82     {-# INLINE filter #-}
  83     filter f (Headers m) = Headers $ filter f m
  84
  85 instance Indexed Headers CIAscii Ascii where
  86     {-# INLINE index #-}
  87     index k (Headers m) = index k m
  88     {-# INLINE adjust #-}
  89     adjust f k (Headers m) = Headers $ adjust f k m
  90     {-# INLINE inDomain #-}
  91     inDomain k (Headers m) = inDomain k m
  92
  93 instance Map Headers CIAscii Ascii where
  94     {-# INLINE lookup #-}
  95     lookup k (Headers m) = lookup k m
  96     {-# INLINE insertWith #-}
  97     insertWith f k v (Headers m)
  98         = Headers $ insertWith f k v m
  99     {-# INLINE mapWithKey #-}
 100     mapWithKey f (Headers m)
 101         = Headers $ mapWithKey f m
 102     {-# INLINE unionWith #-}
 103     unionWith f (Headers α) (Headers β)
 104         = Headers $ unionWith f α β
 105     {-# INLINE intersectionWith #-}
 106     intersectionWith f (Headers α) (Headers β)
 107         = Headers $ intersectionWith f α β
 108     {-# INLINE differenceWith #-}
 109     differenceWith f (Headers α) (Headers β)
 110         = Headers $ differenceWith f α β
 111     {-# INLINE isSubmapBy #-}
 112     isSubmapBy f (Headers α) (Headers β)
 113         = isSubmapBy f α β
 114     {-# INLINE isProperSubmapBy #-}
 115     isProperSubmapBy f (Headers α) (Headers β)
 116         = isProperSubmapBy f α β
 117
 118 instance SortingCollection Headers (CIAscii, Ascii) where
 119     {-# INLINE minView #-}
 120     minView (Headers m) = second Headers <$> minView m
 121
 122 merge ∷ Ascii → Ascii → Ascii
 123 {-# INLINE merge #-}
 124 merge a b
 125     | nullA a ∧ nullA b = (∅)
 126     | nullA a           = b
 127     |           nullA b = a
 128     | otherwise         = a ⊕ ", " ⊕ b
 129     where
 130       nullA ∷ Ascii → Bool
 131       {-# INLINE nullA #-}
 132       nullA = null ∘ A.toByteString
 133
 134 {-
 135   message-header = field-name ":" [ field-value ]
 136   field-name     = token
 137   field-value    = *( field-content | LWS )
 138   field-content  = <field-value を構成し、*TEXT あるいは
 139                     token, separators, quoted-string を連結
 140                     したものから成る OCTET>
 141
 142   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 143   LWS は單一の SP に變換される。
 144 -}
 145 headers ∷ Parser Headers
 146 {-# INLINEABLE headers #-}
 147 headers = do xs ← P.many header
 148              crlf
 149              return $ fromFoldable xs
 150     where
 151       header ∷ Parser (CIAscii, Ascii)
 152       header = do name ← A.toCIAscii <$> token
 153                   void $ char ':'
 154                   skipMany lws
 155                   values ← content `sepBy` try lws
 156                   skipMany (try lws)
 157                   crlf
 158                   return (name, joinValues values)
 159
 160       content ∷ Parser Ascii
 161       {-# INLINE content #-}
 162       content = A.unsafeFromByteString
 163                 <$>
 164                 takeWhile1 (\c → isText c ∧ c ≢ '\x20')
 165
 166       joinValues ∷ [Ascii] → Ascii
 167       {-# INLINE joinValues #-}
 168       joinValues = A.fromAsciiBuilder
 169                    ∘ mconcat
 170                    ∘ intersperse (A.toAsciiBuilder "\x20")
 171                    ∘ map A.toAsciiBuilder
 172
 173 printHeaders ∷ Headers → AsciiBuilder
 174 printHeaders (Headers m)
 175     = mconcat (map printHeader (fromFoldable m)) ⊕
 176       A.toAsciiBuilder "\x0D\x0A"
 177     where
 178       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
 179       printHeader (name, value)
 180           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
 181             A.toAsciiBuilder ": "                 ⊕
 182             A.toAsciiBuilder value                ⊕
 183             A.toAsciiBuilder "\x0D\x0A"