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