Network/HTTP/Lucu/Headers.hs

   1 {-# LANGUAGE
   2     GeneralizedNewtypeDeriving
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 module Network.HTTP.Lucu.Headers
   7     ( Headers
   8     , HasHeaders(..)
   9
  10     , singleton
  11
  12     , toHeaders
  13     , fromHeaders
  14
  15     , headersP
  16     , printHeaders
  17     )
  18     where
  19 import Control.Applicative
  20 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  21 import qualified Data.Ascii as A
  22 import Data.Attoparsec.Char8 as P
  23 import qualified Data.ByteString as BS
  24 import Data.Map (Map)
  25 import qualified Data.Map as M
  26 import Data.Monoid
  27 import Data.Monoid.Unicode
  28 import Network.HTTP.Lucu.Parser.Http
  29 import Network.HTTP.Lucu.Utils
  30 import Prelude.Unicode
  31
  32 newtype Headers
  33     = Headers (Map CIAscii Ascii)
  34       deriving (Eq, Show, Monoid)
  35
  36 class HasHeaders a where
  37     getHeaders ∷ a → Headers
  38     setHeaders ∷ a → Headers → a
  39
  40     getHeader ∷ CIAscii → a → Maybe Ascii
  41     getHeader key a
  42         = case getHeaders a of
  43             Headers m → M.lookup key m
  44
  45     getCIHeader ∷ CIAscii → a → Maybe CIAscii
  46     {-# INLINE getCIHeader #-}
  47     getCIHeader key a
  48         = A.toCIAscii <$> getHeader key a
  49
  50     deleteHeader ∷ CIAscii → a → a
  51     {-# INLINE deleteHeader #-}
  52     deleteHeader key a
  53         = case getHeaders a of
  54             Headers m
  55               → setHeaders a $ Headers $ M.delete key m
  56
  57     setHeader ∷ CIAscii → Ascii → a → a
  58     {-# INLINE setHeader #-}
  59     setHeader key val a
  60         = case getHeaders a of
  61             Headers m
  62               → setHeaders a $ Headers $ M.insert key val m
  63
  64 instance HasHeaders Headers where
  65     getHeaders   = id
  66     setHeaders _ = id
  67
  68 singleton ∷ CIAscii → Ascii → Headers
  69 {-# INLINE singleton #-}
  70 singleton key val
  71     = Headers $ M.singleton key val
  72
  73 toHeaders ∷ [(CIAscii, Ascii)] → Headers
  74 {-# INLINE toHeaders #-}
  75 toHeaders = flip mkHeaders (∅)
  76
  77 mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
  78 mkHeaders []              (Headers m) = Headers m
  79 mkHeaders ((key, val):xs) (Headers m)
  80     = mkHeaders xs $ Headers $
  81       case M.lookup key m of
  82         Nothing  → M.insert key val m
  83         Just old → M.insert key (merge old val) m
  84     where
  85       merge ∷ Ascii → Ascii → Ascii
  86       {-# INLINE merge #-}
  87       merge a b
  88           | nullA a ∧ nullA b = (∅)
  89           | nullA a           = b
  90           |           nullA b = a
  91           | otherwise         = a ⊕ ", " ⊕ b
  92
  93       nullA ∷ Ascii → Bool
  94       {-# INLINE nullA #-}
  95       nullA = BS.null ∘ A.toByteString
  96
  97 fromHeaders ∷ Headers → [(CIAscii, Ascii)]
  98 fromHeaders (Headers m) = M.toList m
  99
 100 {-
 101   message-header = field-name ":" [ field-value ]
 102   field-name     = token
 103   field-value    = *( field-content | LWS )
 104   field-content  = <field-value を構成し、*TEXT あるいは
 105                     token, separators, quoted-string を連結
 106                     したものから成る OCTET>
 107
 108   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 109   LWS は單一の SP に變換される。
 110 -}
 111 headersP ∷ Parser Headers
 112 {-# INLINEABLE headersP #-}
 113 headersP = do xs ← P.many header
 114               crlf
 115               return $ toHeaders xs
 116     where
 117       header ∷ Parser (CIAscii, Ascii)
 118       header = do name ← A.toCIAscii <$> token
 119                   _    ← char ':'
 120                   skipMany lws
 121                   values ← sepBy content (try lws)
 122                   skipMany (try lws)
 123                   crlf
 124                   return (name, joinValues values)
 125
 126       content ∷ Parser Ascii
 127       {-# INLINE content #-}
 128       content = A.unsafeFromByteString
 129                 <$>
 130                 takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
 131
 132       joinValues ∷ [Ascii] → Ascii
 133       {-# INLINE joinValues #-}
 134       joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
 135
 136 printHeaders ∷ Headers → AsciiBuilder
 137 printHeaders (Headers m)
 138     = mconcat (map printHeader (M.toList m)) ⊕
 139       A.toAsciiBuilder "\x0D\x0A"
 140     where
 141       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
 142       printHeader (name, value)
 143           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
 144             A.toAsciiBuilder ": "                 ⊕
 145             A.toAsciiBuilder value                ⊕
 146             A.toAsciiBuilder "\x0D\x0A"