Network/HTTP/Lucu/Response.hs

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