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     , isInformational
  25     , isSuccessful
  26     , isRedirection
  27     , isError
  28     , isClientError
  29     , isServerError
  30     )
  31     where
  32 import Data.Ascii (Ascii, AsciiBuilder)
  33 import Data.Convertible.Base
  34 import Data.Convertible.Instances.Ascii ()
  35 import Data.Convertible.Utils
  36 import Data.Monoid.Unicode
  37 import Network.HTTP.Lucu.Headers
  38 import Network.HTTP.Lucu.HttpVersion
  39 import Network.HTTP.Lucu.StatusCode
  40 import Network.HTTP.Lucu.StatusCode.Internal
  41 import Prelude.Unicode
  42
  43 -- |This is the definition of an HTTP response.
  44 data Response = Response {
  45       resVersion ∷ !HttpVersion
  46     , resStatus  ∷ !SomeStatusCode
  47     , resHeaders ∷ !Headers
  48     } deriving (Show, Eq)
  49
  50 instance HasHeaders Response where
  51     getHeaders         = resHeaders
  52     setHeaders res hdr = res { resHeaders = hdr }
  53
  54 instance ConvertSuccess Response Ascii where
  55     {-# INLINE convertSuccess #-}
  56     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  57
  58 instance ConvertSuccess Response AsciiBuilder where
  59     {-# INLINE convertSuccess #-}
  60     convertSuccess (Response {..})
  61         = cs resVersion           ⊕
  62           cs (" " ∷ Ascii)        ⊕
  63           cs resStatus            ⊕
  64           cs ("\x0D\x0A" ∷ Ascii) ⊕
  65           cs resHeaders
  66
  67 deriveAttempts [ ([t| Response |], [t| Ascii        |])
  68                , ([t| Response |], [t| AsciiBuilder |])
  69                ]
  70
  71 -- |Returns an HTTP\/1.1 'Response' with no header fields.
  72 emptyResponse ∷ StatusCode sc ⇒ sc → Response
  73 emptyResponse sc
  74     = Response {
  75         resVersion = HttpVersion 1 1
  76       , resStatus  = fromStatusCode sc
  77       , resHeaders = (∅)
  78       }
  79
  80 -- |@'setStatusCode' sc res@ sets the status code of @res@ to @sc@.
  81 setStatusCode ∷ StatusCode sc ⇒ sc → Response → Response
  82 setStatusCode sc res
  83     = res {
  84         resStatus = fromStatusCode sc
  85       }
  86
  87 -- |Returns 'True' iff a given 'Response' allows the existence of
  88 -- response entity body.
  89 resCanHaveBody ∷ Response → Bool
  90 {-# INLINEABLE resCanHaveBody #-}
  91 resCanHaveBody (Response {..})
  92     | isInformational resStatus   = False
  93     | resStatus ≡ cs NoContent    = False
  94     | resStatus ≡ cs ResetContent = False
  95     | resStatus ≡ cs NotModified  = False
  96     | otherwise                   = True
  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