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 instance HasHeaders Headers where
  61     getHeaders   = id
  62     setHeaders _ = id
  63
  64 toHeaders ∷ [(CIAscii, Ascii)] → Headers
  65 {-# INLINE toHeaders #-}
  66 toHeaders = flip mkHeaders (∅)
  67
  68 mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
  69 mkHeaders []              (Headers m) = Headers m
  70 mkHeaders ((key, val):xs) (Headers m)
  71     = mkHeaders xs $ Headers $
  72       case M.lookup key m of
  73         Nothing  → M.insert key val m
  74         Just old → M.insert key (merge old val) m
  75     where
  76       merge ∷ Ascii → Ascii → Ascii
  77       {-# INLINE merge #-}
  78       merge a b
  79           | nullA a ∧ nullA b = (∅)
  80           | nullA a           = b
  81           |           nullA b = a
  82           | otherwise         = a ⊕ ", " ⊕ b
  83
  84       nullA ∷ Ascii → Bool
  85       {-# INLINE nullA #-}
  86       nullA = BS.null ∘ A.toByteString
  87
  88 fromHeaders ∷ Headers → [(CIAscii, Ascii)]
  89 fromHeaders (Headers m) = M.toList m
  90
  91 {-
  92   message-header = field-name ":" [ field-value ]
  93   field-name     = token
  94   field-value    = *( field-content | LWS )
  95   field-content  = <field-value を構成し、*TEXT あるいは
  96                     token, separators, quoted-string を連結
  97                     したものから成る OCTET>
  98
  99   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
 100   LWS は單一の SP に變換される。
 101 -}
 102 headersP ∷ Parser Headers
 103 {-# INLINEABLE headersP #-}
 104 headersP = do xs ← P.many header
 105               crlf
 106               return $ toHeaders xs
 107     where
 108       header ∷ Parser (CIAscii, Ascii)
 109       header = try $
 110                do name ← A.toCIAscii <$> token
 111                   _    ← char ':'
 112                   skipMany lws
 113                   values ← sepBy content lws
 114                   skipMany lws
 115                   crlf
 116                   return (name, joinValues values)
 117
 118       content ∷ Parser Ascii
 119       {-# INLINE content #-}
 120       content = A.unsafeFromByteString
 121                 <$>
 122                 takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
 123
 124       joinValues ∷ [Ascii] → Ascii
 125       {-# INLINE joinValues #-}
 126       joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
 127
 128 hPutHeaders ∷ HandleLike h => h → Headers → IO ()
 129 hPutHeaders !h !(Headers m)
 130     = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
 131     where
 132       putH ∷ (CIAscii, Ascii) → IO ()
 133       putH (!name, !value)
 134           = do hPutBS h (A.ciToByteString name)
 135                hPutBS h ": "
 136                hPutBS h (A.toByteString value)
 137                hPutBS h "\r\n"