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