Network/HTTP/Lucu/Response.hs

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