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