Network/HTTP/Lucu/Response.hs

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