Network/HTTP/Lucu/Response.hs

   1 module Network.HTTP.Lucu.Response
   2     ( StatusCode(..)
   3     , Response(..)
   4     , hPutResponse    -- Handle -> Response -> IO ()
   5     , isInformational -- StatusCode -> Bool
   6     , isError         -- StatusCode -> Bool
   7     )
   8     where
   9
  10 import           Network.HTTP.Lucu.Headers
  11 import           Network.HTTP.Lucu.HttpVersion
  12 import           System.IO
  13 import           Text.Printf
  14
  15 data StatusCode = Continue
  16                 | SwitchingProtocols
  17                 | Processing
  18                 --
  19                 | Ok
  20                 | Created
  21                 | Accepted
  22                 | NonAuthoritativeInformation
  23                 | NoContent
  24                 | ResetContent
  25                 | PartialContent
  26                 | MultiStatus
  27                 --
  28                 | MultipleChoices
  29                 | MovedPermanently
  30                 | Found
  31                 | SeeOther
  32                 | NotModified
  33                 | UseProxy
  34                 | TemporaryRedirect
  35                 --
  36                 | BadRequest
  37                 | Unauthorized
  38                 | PaymentRequired
  39                 | Forbidden
  40                 | NotFound
  41                 | MethodNotAllowed
  42                 | NotAcceptable
  43                 | ProxyAuthenticationRequired
  44                 | RequestTimeout
  45                 | Conflict
  46                 | Gone
  47                 | LengthRequired
  48                 | PreconditionFailed
  49                 | RequestEntityTooLarge
  50                 | RequestURITooLarge
  51                 | UnsupportedMediaType
  52                 | RequestRangeNotSatisfiable
  53                 | ExpectationFailed
  54                 | UnprocessableEntitiy
  55                 | Locked
  56                 | FailedDependency
  57                 --
  58                 | InternalServerError
  59                 | NotImplemented
  60                 | BadGateway
  61                 | ServiceUnavailable
  62                 | GatewayTimeout
  63                 | HttpVersionNotSupported
  64                 | InsufficientStorage
  65                   deriving (Eq)
  66
  67 instance Show StatusCode where
  68     show sc = let (num, msg) = statusCode sc
  69               in
  70                 printf "%03d %s" num msg
  71
  72
  73 data Response = Response {
  74       resVersion :: HttpVersion
  75     , resStatus  :: StatusCode
  76     , resHeaders :: Headers
  77     }
  78                 deriving (Show, Eq)
  79
  80 instance HasHeaders Response where
  81     getHeaders = resHeaders
  82     setHeaders res hdr = res { resHeaders = hdr }
  83
  84
  85 hPutResponse :: Handle -> Response -> IO ()
  86 hPutResponse h res = do hPutHttpVersion h (resVersion res)
  87                         hPutChar        h ' '
  88                         hPutStatus      h (resStatus  res)
  89                         hPutStr         h "\r\n"
  90                         hPutHeaders     h (resHeaders res)
  91
  92 hPutStatus :: Handle -> StatusCode -> IO ()
  93 hPutStatus h sc = let (num, msg) = statusCode sc
  94                   in
  95                     hPrintf h "%03d %s" num msg
  96
  97
  98 isInformational :: StatusCode -> Bool
  99 isInformational sc = let (num, _) = statusCode sc
 100                      in num < 200
 101
 102 isError :: StatusCode -> Bool
 103 isError sc = let (num, _) = statusCode sc
 104              in num >= 400
 105
 106
 107 statusCode :: StatusCode -> (Int, String)
 108 statusCode Continue                    = (100, "Continue")
 109 statusCode SwitchingProtocols          = (101, "Switching Protocols")
 110 statusCode Processing                  = (102, "Processing")
 111 --
 112 statusCode Ok                          = (200, "OK")
 113 statusCode Created                     = (201, "Created")
 114 statusCode Accepted                    = (202, "Accepted")
 115 statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information")
 116 statusCode NoContent                   = (204, "No Content")
 117 statusCode ResetContent                = (205, "Reset Content")
 118 statusCode PartialContent              = (206, "Partial Content")
 119 statusCode MultiStatus                 = (207, "Multi Status")
 120 --
 121 statusCode MultipleChoices             = (300, "Multiple Choices")
 122 statusCode MovedPermanently            = (301, "Moved Permanently")
 123 statusCode Found                       = (302, "Found")
 124 statusCode SeeOther                    = (303, "See Other")
 125 statusCode NotModified                 = (304, "Not Modified")
 126 statusCode UseProxy                    = (305, "Use Proxy")
 127 statusCode TemporaryRedirect           = (306, "Temporary Redirect")
 128 --
 129 statusCode BadRequest                  = (400, "Bad Request")
 130 statusCode Unauthorized                = (401, "Unauthorized")
 131 statusCode PaymentRequired             = (402, "Payment Required")
 132 statusCode Forbidden                   = (403, "Forbidden")
 133 statusCode NotFound                    = (404, "Not Found")
 134 statusCode MethodNotAllowed            = (405, "Method Not Allowed")
 135 statusCode NotAcceptable               = (406, "Not Acceptable")
 136 statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required")
 137 statusCode RequestTimeout              = (408, "Request Timeout")
 138 statusCode Conflict                    = (409, "Conflict")
 139 statusCode Gone                        = (410, "Gone")
 140 statusCode LengthRequired              = (411, "Length Required")
 141 statusCode PreconditionFailed          = (412, "Precondition Failed")
 142 statusCode RequestEntityTooLarge       = (413, "Request Entity Too Large")
 143 statusCode RequestURITooLarge          = (414, "Request URI Too Large")
 144 statusCode UnsupportedMediaType        = (415, "Unsupported Media Type")
 145 statusCode RequestRangeNotSatisfiable  = (416, "Request Range Not Satisfiable")
 146 statusCode ExpectationFailed           = (417, "Expectation Failed")
 147 statusCode UnprocessableEntitiy        = (422, "Unprocessable Entity")
 148 statusCode Locked                      = (423, "Locked")
 149 statusCode FailedDependency            = (424, "Failed Dependency")
 150 --
 151 statusCode InternalServerError         = (500, "Internal Server Error")
 152 statusCode NotImplemented              = (501, "Not Implemented")
 153 statusCode BadGateway                  = (502, "Bad Gateway")
 154 statusCode ServiceUnavailable          = (503, "Service Unavailable")
 155 statusCode GatewayTimeout              = (504, "Gateway Timeout")
 156 statusCode HttpVersionNotSupported     = (505, "HTTP Version Not Supported")
 157 statusCode InsufficientStorage         = (507, "Insufficient Storage")