Network/HTTP/Lucu/Response.hs

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