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.Convertible.Base
  36 import Data.Convertible.Instances.Ascii ()
  37 import Data.Convertible.Utils
  38 import Data.Monoid.Unicode
  39 import Network.HTTP.Lucu.Headers
  40 import Network.HTTP.Lucu.HttpVersion
  41 import Network.HTTP.Lucu.StatusCode
  42 import Network.HTTP.Lucu.StatusCode.Internal
  43 import Prelude.Unicode
  44
  45 -- |Convert a 'StatusCode' to an 'AsciiBuilder'.
  46 printStatusCode ∷ StatusCode sc ⇒ sc → AsciiBuilder
  47 {-# INLINEABLE printStatusCode #-}
  48 printStatusCode = A.toAsciiBuilder ∘ textualStatus
  49
  50 -- |This is the definition of an HTTP response.
  51 data Response = Response {
  52       resVersion ∷ !HttpVersion
  53     , resStatus  ∷ !SomeStatusCode
  54     , resHeaders ∷ !Headers
  55     } deriving (Show, Eq)
  56
  57 instance HasHeaders Response where
  58     getHeaders         = resHeaders
  59     setHeaders res hdr = res { resHeaders = hdr }
  60
  61 -- |Returns an HTTP\/1.1 'Response' with no header fields.
  62 emptyResponse ∷ StatusCode sc ⇒ sc → Response
  63 emptyResponse sc
  64     = Response {
  65         resVersion = HttpVersion 1 1
  66       , resStatus  = fromStatusCode sc
  67       , resHeaders = (∅)
  68       }
  69
  70 -- |@'setStatusCode' sc res@ sets the status code of @res@ to @sc@.
  71 setStatusCode ∷ StatusCode sc ⇒ sc → Response → Response
  72 setStatusCode sc res
  73     = res {
  74         resStatus = fromStatusCode sc
  75       }
  76
  77 -- |Returns 'True' iff a given 'Response' allows the existence of
  78 -- response entity body.
  79 resCanHaveBody ∷ Response → Bool
  80 {-# INLINEABLE resCanHaveBody #-}
  81 resCanHaveBody (Response {..})
  82     | isInformational resStatus = False
  83     | resStatus ≈ NoContent     = False
  84     | resStatus ≈ ResetContent  = False
  85     | resStatus ≈ NotModified   = False
  86     | otherwise                 = True
  87
  88 -- |Convert a 'Response' to 'AsciiBuilder'.
  89 printResponse ∷ Response → AsciiBuilder
  90 {-# INLINEABLE printResponse #-}
  91 printResponse (Response {..})
  92     = cs resVersion ⊕
  93       A.toAsciiBuilder " "        ⊕
  94       printStatusCode  resStatus  ⊕
  95       A.toAsciiBuilder "\x0D\x0A" ⊕
  96       cs resHeaders
  97
  98 -- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
  99 isInformational ∷ StatusCode sc ⇒ sc → Bool
 100 {-# INLINE isInformational #-}
 101 isInformational = satisfy (< 200)
 102
 103 -- |@'isSuccessful' sc@ returns 'True' iff @200 '<=' sc '<' 300@.
 104 isSuccessful ∷ StatusCode sc ⇒ sc → Bool
 105 {-# INLINE isSuccessful #-}
 106 isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
 107
 108 -- |@'isRedirection' sc@ returns 'True' iff @300 '<=' sc '<' 400@.
 109 isRedirection ∷ StatusCode sc ⇒ sc → Bool
 110 {-# INLINE isRedirection #-}
 111 isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
 112
 113 -- |@'isError' sc@ returns 'True' iff @400 '<=' sc@
 114 isError ∷ StatusCode sc ⇒ sc → Bool
 115 {-# INLINE isError #-}
 116 isError = satisfy (≥ 400)
 117
 118 -- |@'isClientError' sc@ returns 'True' iff @400 '<=' sc '<' 500@.
 119 isClientError ∷ StatusCode sc ⇒ sc → Bool
 120 {-# INLINE isClientError #-}
 121 isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
 122
 123 -- |@'isServerError' sc@ returns 'True' iff @500 '<=' sc@.
 124 isServerError ∷ StatusCode sc ⇒ sc → Bool
 125 {-# INLINE isServerError #-}
 126 isServerError = satisfy (≥ 500)
 127
 128 satisfy ∷ StatusCode sc ⇒ (Int → Bool) → sc → Bool
 129 {-# INLINE satisfy #-}
 130 satisfy p (numericCode → num) = p num