Network/HTTP/Lucu/HttpVersion.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 {-# OPTIONS_HADDOCK prune #-}
   7
   8 -- |Manipulation of HTTP version string.
   9 module Network.HTTP.Lucu.HttpVersion
  10     ( HttpVersion(..)
  11     , httpVersionP
  12     , hPutHttpVersion
  13     )
  14     where
  15 import Control.Monad.Unicode
  16 import Data.Attoparsec.Char8
  17 import Network.HTTP.Lucu.HandleLike
  18 import Prelude hiding (min)
  19
  20 -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
  21 data HttpVersion
  22     = HttpVersion !Int !Int
  23       deriving (Eq, Show)
  24
  25 instance Ord HttpVersion where
  26     (HttpVersion majA minA) `compare` (HttpVersion majB minB)
  27         | majA > majB = GT
  28         | majA < majB = LT
  29         | minA > minB = GT
  30         | minA < minB = LT
  31         | otherwise   = EQ
  32
  33 httpVersionP ∷ Parser HttpVersion
  34 httpVersionP = string "HTTP/"
  35                ≫
  36                choice [ string "1.1" ≫ return (HttpVersion 1 1)
  37                       , string "1.0" ≫ return (HttpVersion 1 0)
  38                       , do major ← decimal
  39                            _     ← char '.'
  40                            minor ← decimal
  41                            return $ HttpVersion major minor
  42                       ]
  43
  44 hPutHttpVersion ∷ HandleLike h ⇒ h → HttpVersion → IO ()
  45 hPutHttpVersion !h !v
  46     = case v of
  47         -- 頻出するので高速化
  48         HttpVersion 1 0 → hPutBS h "HTTP/1.0"
  49         HttpVersion 1 1 → hPutBS h "HTTP/1.1"
  50         -- 一般の場合
  51         HttpVersion !maj !min
  52             → do hPutBS   h "HTTP/"
  53                  hPutStr  h (show maj)
  54                  hPutChar h '.'
  55                  hPutStr  h (show min)