Network/HTTP/Lucu/Response.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , UnboxedTuples
   6   , UnicodeSyntax
   7   , ViewPatterns
   8   #-}
   9
  10 -- |Definition of things related on HTTP response.
  11 module Network.HTTP.Lucu.Response
  12     ( StatusCode(..)
  13     , printStatusCode
  14
  15     , Response(..)
  16     , emptyResponse
  17     , resCanHaveBody
  18     , printResponse
  19
  20     , isInformational
  21     , isSuccessful
  22     , isRedirection
  23     , isError
  24     , isClientError
  25     , isServerError
  26
  27     , statusCode
  28     )
  29     where
  30 import Data.Ascii (Ascii, AsciiBuilder)
  31 import qualified Data.Ascii as A
  32 import Data.Monoid.Unicode
  33 import Data.Typeable
  34 import Network.HTTP.Lucu.Headers
  35 import Network.HTTP.Lucu.HttpVersion
  36 import Network.HTTP.Lucu.Utils
  37 import Prelude.Unicode
  38
  39 -- |This is the definition of HTTP status code.
  40 -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status
  41 -- codes so you don't have to memorize, for instance, that \"Gateway
  42 -- Timeout\" is 504.
  43 data StatusCode = Continue
  44                 | SwitchingProtocols
  45                 | Processing
  46                 --
  47                 | Ok
  48                 | Created
  49                 | Accepted
  50                 | NonAuthoritativeInformation
  51                 | NoContent
  52                 | ResetContent
  53                 | PartialContent
  54                 | MultiStatus
  55                 --
  56                 | MultipleChoices
  57                 | MovedPermanently
  58                 | Found
  59                 | SeeOther
  60                 | NotModified
  61                 | UseProxy
  62                 | TemporaryRedirect
  63                 --
  64                 | BadRequest
  65                 | Unauthorized
  66                 | PaymentRequired
  67                 | Forbidden
  68                 | NotFound
  69                 | MethodNotAllowed
  70                 | NotAcceptable
  71                 | ProxyAuthenticationRequired
  72                 | RequestTimeout
  73                 | Conflict
  74                 | Gone
  75                 | LengthRequired
  76                 | PreconditionFailed
  77                 | RequestEntityTooLarge
  78                 | RequestURITooLarge
  79                 | UnsupportedMediaType
  80                 | RequestRangeNotSatisfiable
  81                 | ExpectationFailed
  82                 | UnprocessableEntitiy
  83                 | Locked
  84                 | FailedDependency
  85                 --
  86                 | InternalServerError
  87                 | NotImplemented
  88                 | BadGateway
  89                 | ServiceUnavailable
  90                 | GatewayTimeout
  91                 | HttpVersionNotSupported
  92                 | InsufficientStorage
  93                   deriving (Eq, Show, Typeable)
  94
  95 -- |Convert a 'StatusCode' to an 'AsciiBuilder'.
  96 printStatusCode ∷ StatusCode → AsciiBuilder
  97 {-# INLINEABLE printStatusCode #-}
  98 printStatusCode (statusCode → (# num, msg #))
  99     = ( show3 num            ⊕
 100         A.toAsciiBuilder " " ⊕
 101         A.toAsciiBuilder msg
 102       )
 103
 104 -- |This is the definition of an HTTP response.
 105 data Response = Response {
 106       resVersion ∷ !HttpVersion
 107     , resStatus  ∷ !StatusCode
 108     , resHeaders ∷ !Headers
 109     } deriving (Show, Eq)
 110
 111 instance HasHeaders Response where
 112     getHeaders         = resHeaders
 113     setHeaders res hdr = res { resHeaders = hdr }
 114
 115 -- |Returns an HTTP\/1.1 'Response' with no header fields.
 116 emptyResponse ∷ StatusCode → Response
 117 emptyResponse sc
 118     = Response {
 119         resVersion = HttpVersion 1 1
 120       , resStatus  = sc
 121       , resHeaders = (∅)
 122       }
 123
 124 -- |Returns 'True' iff a given 'Response' allows the existence of
 125 -- response entity body.
 126 resCanHaveBody ∷ Response → Bool
 127 {-# INLINEABLE resCanHaveBody #-}
 128 resCanHaveBody (Response {..})
 129     | isInformational resStatus = False
 130     | resStatus ≡ NoContent     = False
 131     | resStatus ≡ ResetContent  = False
 132     | resStatus ≡ NotModified   = False
 133     | otherwise                 = True
 134
 135 -- |Convert a 'Response' to 'AsciiBuilder'.
 136 printResponse ∷ Response → AsciiBuilder
 137 {-# INLINEABLE printResponse #-}
 138 printResponse (Response {..})
 139     = printHttpVersion resVersion ⊕
 140       A.toAsciiBuilder " "        ⊕
 141       printStatusCode  resStatus  ⊕
 142       A.toAsciiBuilder "\x0D\x0A" ⊕
 143       printHeaders     resHeaders
 144
 145 -- |@'isInformational' sc@ returns 'True' iff @sc < 200@.
 146 isInformational ∷ StatusCode → Bool
 147 {-# INLINE isInformational #-}
 148 isInformational = satisfy (< 200)
 149
 150 -- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@.
 151 isSuccessful ∷ StatusCode → Bool
 152 {-# INLINE isSuccessful #-}
 153 isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
 154
 155 -- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@.
 156 isRedirection ∷ StatusCode → Bool
 157 {-# INLINE isRedirection #-}
 158 isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
 159
 160 -- |@'isError' sc@ returns 'True' iff @400 <= sc@
 161 isError ∷ StatusCode → Bool
 162 {-# INLINE isError #-}
 163 isError = satisfy (≥ 400)
 164
 165 -- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@.
 166 isClientError ∷ StatusCode → Bool
 167 {-# INLINE isClientError #-}
 168 isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
 169
 170 -- |@'isServerError' sc@ returns 'True' iff @500 <= sc@.
 171 isServerError ∷ StatusCode → Bool
 172 {-# INLINE isServerError #-}
 173 isServerError = satisfy (≥ 500)
 174
 175 satisfy ∷ (Int → Bool) → StatusCode → Bool
 176 {-# INLINE satisfy #-}
 177 satisfy p (statusCode → (# num, _ #)) = p num
 178
 179 -- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
 180 -- representation of @sc@.
 181 statusCode ∷ StatusCode → (# Int, Ascii #)
 182 {-# INLINEABLE statusCode #-}
 183
 184 statusCode Continue                    = (# 100, "Continue"                      #)
 185 statusCode SwitchingProtocols          = (# 101, "Switching Protocols"           #)
 186 statusCode Processing                  = (# 102, "Processing"                    #)
 187
 188 statusCode Ok                          = (# 200, "OK"                            #)
 189 statusCode Created                     = (# 201, "Created"                       #)
 190 statusCode Accepted                    = (# 202, "Accepted"                      #)
 191 statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #)
 192 statusCode NoContent                   = (# 204, "No Content"                    #)
 193 statusCode ResetContent                = (# 205, "Reset Content"                 #)
 194 statusCode PartialContent              = (# 206, "Partial Content"               #)
 195 statusCode MultiStatus                 = (# 207, "Multi Status"                  #)
 196
 197 statusCode MultipleChoices             = (# 300, "Multiple Choices"              #)
 198 statusCode MovedPermanently            = (# 301, "Moved Permanently"             #)
 199 statusCode Found                       = (# 302, "Found"                         #)
 200 statusCode SeeOther                    = (# 303, "See Other"                     #)
 201 statusCode NotModified                 = (# 304, "Not Modified"                  #)
 202 statusCode UseProxy                    = (# 305, "Use Proxy"                     #)
 203 statusCode TemporaryRedirect           = (# 306, "Temporary Redirect"            #)
 204
 205 statusCode BadRequest                  = (# 400, "Bad Request"                   #)
 206 statusCode Unauthorized                = (# 401, "Unauthorized"                  #)
 207 statusCode PaymentRequired             = (# 402, "Payment Required"              #)
 208 statusCode Forbidden                   = (# 403, "Forbidden"                     #)
 209 statusCode NotFound                    = (# 404, "Not Found"                     #)
 210 statusCode MethodNotAllowed            = (# 405, "Method Not Allowed"            #)
 211 statusCode NotAcceptable               = (# 406, "Not Acceptable"                #)
 212 statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #)
 213 statusCode RequestTimeout              = (# 408, "Request Timeout"               #)
 214 statusCode Conflict                    = (# 409, "Conflict"                      #)
 215 statusCode Gone                        = (# 410, "Gone"                          #)
 216 statusCode LengthRequired              = (# 411, "Length Required"               #)
 217 statusCode PreconditionFailed          = (# 412, "Precondition Failed"           #)
 218 statusCode RequestEntityTooLarge       = (# 413, "Request Entity Too Large"      #)
 219 statusCode RequestURITooLarge          = (# 414, "Request URI Too Large"         #)
 220 statusCode UnsupportedMediaType        = (# 415, "Unsupported Media Type"        #)
 221 statusCode RequestRangeNotSatisfiable  = (# 416, "Request Range Not Satisfiable" #)
 222 statusCode ExpectationFailed           = (# 417, "Expectation Failed"            #)
 223 statusCode UnprocessableEntitiy        = (# 422, "Unprocessable Entity"          #)
 224 statusCode Locked                      = (# 423, "Locked"                        #)
 225 statusCode FailedDependency            = (# 424, "Failed Dependency"             #)
 226
 227 statusCode InternalServerError         = (# 500, "Internal Server Error"         #)
 228 statusCode NotImplemented              = (# 501, "Not Implemented"               #)
 229 statusCode BadGateway                  = (# 502, "Bad Gateway"                   #)
 230 statusCode ServiceUnavailable          = (# 503, "Service Unavailable"           #)
 231 statusCode GatewayTimeout              = (# 504, "Gateway Timeout"               #)
 232 statusCode HttpVersionNotSupported     = (# 505, "HTTP Version Not Supported"    #)
 233 statusCode InsufficientStorage         = (# 507, "Insufficient Storage"          #)