Network/HTTP/Lucu/Response.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , RecordWildCards
   4   , UnicodeSyntax
   5   , ViewPatterns
   6   #-}
   7 -- |Definition of things related on HTTP response.
   8 module Network.HTTP.Lucu.Response
   9     ( -- * Class and Types
  10       StatusCode(..)
  11     , SomeStatusCode(..)
  12     , Response(..)
  13     , statusCodes
  14     , module Network.HTTP.Lucu.StatusCode
  15
  16       -- * Functions
  17     , emptyResponse
  18     , setStatusCode
  19     , resCanHaveBody
  20     , printStatusCode
  21     , printResponse
  22
  23     , (≈)
  24     , (≉)
  25     , isInformational
  26     , isSuccessful
  27     , isRedirection
  28     , isError
  29     , isClientError
  30     , isServerError
  31     )
  32     where
  33 import Data.Ascii (AsciiBuilder)
  34 import qualified Data.Ascii as A
  35 import Data.Monoid.Unicode
  36 import Network.HTTP.Lucu.Headers
  37 import Network.HTTP.Lucu.HttpVersion
  38 import Network.HTTP.Lucu.StatusCode
  39 import Network.HTTP.Lucu.StatusCode.Internal
  40 import Prelude.Unicode
  41
  42 -- |Convert a 'StatusCode' to an 'AsciiBuilder'.
  43 printStatusCode ∷ StatusCode sc ⇒ sc → AsciiBuilder
  44 {-# INLINEABLE printStatusCode #-}
  45 printStatusCode = A.toAsciiBuilder ∘ textualStatus
  46
  47 -- |This is the definition of an HTTP response.
  48 data Response = Response {
  49       resVersion ∷ !HttpVersion
  50     , resStatus  ∷ !SomeStatusCode
  51     , resHeaders ∷ !Headers
  52     } deriving (Show, Eq)
  53
  54 instance HasHeaders Response where
  55     getHeaders         = resHeaders
  56     setHeaders res hdr = res { resHeaders = hdr }
  57
  58 -- |Returns an HTTP\/1.1 'Response' with no header fields.
  59 emptyResponse ∷ StatusCode sc ⇒ sc → Response
  60 emptyResponse sc
  61     = Response {
  62         resVersion = HttpVersion 1 1
  63       , resStatus  = fromStatusCode sc
  64       , resHeaders = (∅)
  65       }
  66
  67 -- |@'setStatusCode' sc res@ sets the status code of @res@ to @sc@.
  68 setStatusCode ∷ StatusCode sc ⇒ sc → Response → Response
  69 setStatusCode sc res
  70     = res {
  71         resStatus = fromStatusCode sc
  72       }
  73
  74 -- |Returns 'True' iff a given 'Response' allows the existence of
  75 -- response entity body.
  76 resCanHaveBody ∷ Response → Bool
  77 {-# INLINEABLE resCanHaveBody #-}
  78 resCanHaveBody (Response {..})
  79     | isInformational resStatus = False
  80     | resStatus ≈ NoContent     = False
  81     | resStatus ≈ ResetContent  = False
  82     | resStatus ≈ NotModified   = False
  83     | otherwise                 = True
  84
  85 -- |Convert a 'Response' to 'AsciiBuilder'.
  86 printResponse ∷ Response → AsciiBuilder
  87 {-# INLINEABLE printResponse #-}
  88 printResponse (Response {..})
  89     = printHttpVersion resVersion ⊕
  90       A.toAsciiBuilder " "        ⊕
  91       printStatusCode  resStatus  ⊕
  92       A.toAsciiBuilder "\x0D\x0A" ⊕
  93       printHeaders     resHeaders
  94
  95 -- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
  96 isInformational ∷ StatusCode sc ⇒ sc → Bool
  97 {-# INLINE isInformational #-}
  98 isInformational = satisfy (< 200)
  99
 100 -- |@'isSuccessful' sc@ returns 'True' iff @200 '<=' sc '<' 300@.
 101 isSuccessful ∷ StatusCode sc ⇒ sc → Bool
 102 {-# INLINE isSuccessful #-}
 103 isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
 104
 105 -- |@'isRedirection' sc@ returns 'True' iff @300 '<=' sc '<' 400@.
 106 isRedirection ∷ StatusCode sc ⇒ sc → Bool
 107 {-# INLINE isRedirection #-}
 108 isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
 109
 110 -- |@'isError' sc@ returns 'True' iff @400 '<=' sc@
 111 isError ∷ StatusCode sc ⇒ sc → Bool
 112 {-# INLINE isError #-}
 113 isError = satisfy (≥ 400)
 114
 115 -- |@'isClientError' sc@ returns 'True' iff @400 '<=' sc '<' 500@.
 116 isClientError ∷ StatusCode sc ⇒ sc → Bool
 117 {-# INLINE isClientError #-}
 118 isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
 119
 120 -- |@'isServerError' sc@ returns 'True' iff @500 '<=' sc@.
 121 isServerError ∷ StatusCode sc ⇒ sc → Bool
 122 {-# INLINE isServerError #-}
 123 isServerError = satisfy (≥ 500)
 124
 125 satisfy ∷ StatusCode sc ⇒ (Int → Bool) → sc → Bool
 126 {-# INLINE satisfy #-}
 127 satisfy p (numericCode → num) = p num