]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/HttpVersion.hs
Authorization
[Lucu.git] / 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)