Network/HTTP/Lucu/Response.hs

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