Network/HTTP/Lucu/Headers.hs

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