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