Network/HTTP/Lucu/HttpVersion.hs

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