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