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.Headers
  20 import           Network.HTTP.Lucu.HttpVersion
  21 import           System.IO
  22 import           Text.Printf
  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                 printf "%03d %s" 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 = do hPutHttpVersion h (resVersion res)
 100                         hPutChar        h ' '
 101                         hPutStatus      h (resStatus  res)
 102                         hPutStr         h "\r\n"
 103                         hPutHeaders     h (resHeaders res)
 104
 105 hPutStatus :: Handle -> StatusCode -> IO ()
 106 hPutStatus h sc = let (num, msg) = statusCode sc
 107                   in
 108                     hPrintf h "%03d %s" num msg
 109
 110 -- |@'isInformational' sc@ is True iff @sc < 200@.
 111 isInformational :: StatusCode -> Bool
 112 isInformational = doesMeet (< 200)
 113
 114 -- |@'isSuccessful' sc@ is True iff @200 <= sc < 300@.
 115 isSuccessful :: StatusCode -> Bool
 116 isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
 117
 118 -- |@'isRedirection' sc@ is True iff @300 <= sc < 400@.
 119 isRedirection :: StatusCode -> Bool
 120 isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
 121
 122 -- |@'isError' sc@ is True iff @400 <= sc@
 123 isError :: StatusCode -> Bool
 124 isError = doesMeet (>= 400)
 125
 126 -- |@'isClientError' sc@ is True iff @400 <= sc < 500@.
 127 isClientError :: StatusCode -> Bool
 128 isClientError = doesMeet (\ n -> n >= 400 && n < 500)
 129
 130 -- |@'isServerError' sc@ is True iff @500 <= sc@.
 131 isServerError :: StatusCode -> Bool
 132 isServerError = doesMeet (>= 500)
 133
 134
 135 doesMeet :: (Int -> Bool) -> StatusCode -> Bool
 136 doesMeet p sc = let (num, _) = statusCode sc
 137                 in
 138                   p num
 139
 140
 141 -- |@'statusCode' sc@ returns a tuple of numeric and textual
 142 -- representation of @sc@.
 143 statusCode :: StatusCode -> (Int, String)
 144 statusCode Continue                    = (100, "Continue")
 145 statusCode SwitchingProtocols          = (101, "Switching Protocols")
 146 statusCode Processing                  = (102, "Processing")
 147 --
 148 statusCode Ok                          = (200, "OK")
 149 statusCode Created                     = (201, "Created")
 150 statusCode Accepted                    = (202, "Accepted")
 151 statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information")
 152 statusCode NoContent                   = (204, "No Content")
 153 statusCode ResetContent                = (205, "Reset Content")
 154 statusCode PartialContent              = (206, "Partial Content")
 155 statusCode MultiStatus                 = (207, "Multi Status")
 156 --
 157 statusCode MultipleChoices             = (300, "Multiple Choices")
 158 statusCode MovedPermanently            = (301, "Moved Permanently")
 159 statusCode Found                       = (302, "Found")
 160 statusCode SeeOther                    = (303, "See Other")
 161 statusCode NotModified                 = (304, "Not Modified")
 162 statusCode UseProxy                    = (305, "Use Proxy")
 163 statusCode TemporaryRedirect           = (306, "Temporary Redirect")
 164 --
 165 statusCode BadRequest                  = (400, "Bad Request")
 166 statusCode Unauthorized                = (401, "Unauthorized")
 167 statusCode PaymentRequired             = (402, "Payment Required")
 168 statusCode Forbidden                   = (403, "Forbidden")
 169 statusCode NotFound                    = (404, "Not Found")
 170 statusCode MethodNotAllowed            = (405, "Method Not Allowed")
 171 statusCode NotAcceptable               = (406, "Not Acceptable")
 172 statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required")
 173 statusCode RequestTimeout              = (408, "Request Timeout")
 174 statusCode Conflict                    = (409, "Conflict")
 175 statusCode Gone                        = (410, "Gone")
 176 statusCode LengthRequired              = (411, "Length Required")
 177 statusCode PreconditionFailed          = (412, "Precondition Failed")
 178 statusCode RequestEntityTooLarge       = (413, "Request Entity Too Large")
 179 statusCode RequestURITooLarge          = (414, "Request URI Too Large")
 180 statusCode UnsupportedMediaType        = (415, "Unsupported Media Type")
 181 statusCode RequestRangeNotSatisfiable  = (416, "Request Range Not Satisfiable")
 182 statusCode ExpectationFailed           = (417, "Expectation Failed")
 183 statusCode UnprocessableEntitiy        = (422, "Unprocessable Entity")
 184 statusCode Locked                      = (423, "Locked")
 185 statusCode FailedDependency            = (424, "Failed Dependency")
 186 --
 187 statusCode InternalServerError         = (500, "Internal Server Error")
 188 statusCode NotImplemented              = (501, "Not Implemented")
 189 statusCode BadGateway                  = (502, "Bad Gateway")
 190 statusCode ServiceUnavailable          = (503, "Service Unavailable")
 191 statusCode GatewayTimeout              = (504, "Gateway Timeout")
 192 statusCode HttpVersionNotSupported     = (505, "HTTP Version Not Supported")
 193 statusCode InsufficientStorage         = (507, "Insufficient Storage")