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