Network/HTTP/Lucu/Response.hs

   1 {-# OPTIONS_HADDOCK 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 qualified Data.ByteString as Strict (ByteString)
  19 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
  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, Strict.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"          #)