Network/HTTP/Lucu/Headers.hs

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