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