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 True iff @sc < 200@.
 113 isInformational :: StatusCode -> Bool
 114 isInformational = doesMeet (< 200)
 115
 116 -- |@'isSuccessful' sc@ is True iff @200 <= sc < 300@.
 117 isSuccessful :: StatusCode -> Bool
 118 isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
 119
 120 -- |@'isRedirection' sc@ is True iff @300 <= sc < 400@.
 121 isRedirection :: StatusCode -> Bool
 122 isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
 123
 124 -- |@'isError' sc@ is True iff @400 <= sc@
 125 isError :: StatusCode -> Bool
 126 isError = doesMeet (>= 400)
 127
 128 -- |@'isClientError' sc@ is True iff @400 <= sc < 500@.
 129 isClientError :: StatusCode -> Bool
 130 isClientError = doesMeet (\ n -> n >= 400 && n < 500)
 131
 132 -- |@'isServerError' sc@ is 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")