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