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