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