module Network.Web.Params (
Method(..), toMethod
, Version(..), toVersion, fromVersion
, Status(..), toStatus, fromStatus, badStatus
, Persist(..), toPersist, fromPersist
, ServerException(..)
, FieldKey(..), FieldValue
, toFieldKey, fromFieldKey
, CT, textHtml, selectContentType
) where
import Control.Exception
import qualified Data.ByteString.Char8 as S
import Data.Char
import qualified Data.Map as M
import Data.Typeable
data Method = GET | HEAD | POST | PUT | DELETE | TRACE | CONNECT
| UnknownMethod deriving (Show,Eq,Enum,Bounded)
methodAlist :: [(S.ByteString,Method)]
methodAlist = let methods = [minBound..maxBound]
in zip (map (S.pack . show) methods) methods
toMethod :: S.ByteString -> Method
toMethod s = maybe UnknownMethod id $ lookup s methodAlist
data Version = HTTP10 | HTTP11 deriving (Eq,Show)
fromVersion :: Version -> S.ByteString
fromVersion HTTP10 = "HTTP/1.0"
fromVersion HTTP11 = "HTTP/1.1"
toVersion :: S.ByteString -> Version
toVersion "HTTP/1.1" = HTTP11
toVersion _ = HTTP10
data Status = Continue | SwitchingProtocols
| OK | Created | Accepted | NonAuthoritativeInformation
| NoContent | ResetContent | PartialContent Integer Integer
| MultipleChoices | MovedPermanently | Found | SeeOther
| NotModified | UseProxy | TemporaryRedirect
| BadRequest | Unauthorized | PaymentRequired | Forbidden
| NotFound | MethodNotAllowed | NotAcceptable
| ProxyAuthenticationRequired | RequestTimeout | Conflict
| Gone | LengthRequired | PreconditionFailed
| RequestEntityTooLarge | RequestURITooLarge
| UnsupportedMediaType | RequestedRangeNotSatisfiable
| ExpectationFailed
| InternalServerError | NotImplemented | BadGateway
| ServiceUnavailable | GatewayTimeout | HTTPVersionNotSupported
deriving Show
fromStatus :: Status -> S.ByteString
fromStatus Continue = "100 Continue"
fromStatus SwitchingProtocols = "101 Switching Protocols"
fromStatus OK = "200 OK"
fromStatus Created = "201 Created"
fromStatus Accepted = "202 Accepted"
fromStatus NonAuthoritativeInformation = "203 Non-Authoritative Information"
fromStatus NoContent = "204 No Content"
fromStatus ResetContent = "205 Reset Content"
fromStatus (PartialContent _ _) = "206 Partial Content"
fromStatus MultipleChoices = "300 Multiple Choices"
fromStatus MovedPermanently = "301 Moved Permanently"
fromStatus Found = "302 Found"
fromStatus SeeOther = "303 See Other"
fromStatus NotModified = "304 Not Modified"
fromStatus UseProxy = "305 Use Proxy"
fromStatus TemporaryRedirect = "307 Temporary Redirect"
fromStatus BadRequest = "400 Bad Request"
fromStatus Unauthorized = "401 Unauthorized"
fromStatus PaymentRequired = "402 Payment Required"
fromStatus Forbidden = "403 Forbidden"
fromStatus NotFound = "404 Not Found"
fromStatus MethodNotAllowed = "405 Method Not Allowed"
fromStatus NotAcceptable = "406 Not Acceptable"
fromStatus ProxyAuthenticationRequired = "407 Proxy Authentication Required"
fromStatus RequestTimeout = "408 RequestTimeout"
fromStatus Conflict = "409 Conflict"
fromStatus Gone = "410 Gone"
fromStatus LengthRequired = "411 Length Required"
fromStatus PreconditionFailed = "412 Precondition Failed"
fromStatus RequestEntityTooLarge = "413 Request Entity Too Large"
fromStatus RequestURITooLarge = "414 Request-URI Too Large"
fromStatus UnsupportedMediaType = "415 Unsupported Media Type"
fromStatus RequestedRangeNotSatisfiable = "416 Requested Range Not Satisfiable"
fromStatus ExpectationFailed = "417 Expectation Failed"
fromStatus InternalServerError = "500 Internal Server Error"
fromStatus NotImplemented = "501 Not Implemented"
fromStatus BadGateway = "502 Bad Gateway"
fromStatus ServiceUnavailable = "503 Service Unavailable"
fromStatus GatewayTimeout = "504 Gateway Time-out"
fromStatus HTTPVersionNotSupported = "505 HTTP Version Not Supported"
toStatus :: S.ByteString -> Maybe Status
toStatus "200" = Just OK
toStatus "302" = Just Found
toStatus "400" = Just BadRequest
toStatus "501" = Just NotImplemented
toStatus _ = Nothing
badStatus :: Status -> Bool
badStatus status = n == '4' || n == '5'
where
n:_ = show status
data FieldKey = FkAcceptLanguage
| FkCacheControl
| FkConnection
| FkContentLength
| FkContentType
| FkCookie
| FkDate
| FkHost
| FkIfModifiedSince
| FkIfRange
| FkIfUnmodifiedSince
| FkLastModified
| FkLocation
| FkRange
| FkServer
| FkSetCookie2
| FkStatus
| FkTransferEncoding
| FkOther S.ByteString
deriving (Eq,Show,Ord)
fieldKeyList :: [FieldKey]
fieldKeyList = [ FkAcceptLanguage
, FkCacheControl
, FkConnection
, FkContentLength
, FkContentType
, FkCookie
, FkDate
, FkHost
, FkIfModifiedSince
, FkIfRange
, FkIfUnmodifiedSince
, FkLastModified
, FkLocation
, FkRange
, FkServer
, FkSetCookie2
, FkStatus
, FkTransferEncoding ]
fieldStringList :: [S.ByteString]
fieldStringList = [ "Accept-Language"
, "Cache-Control"
, "Connection"
, "Content-Length"
, "Content-Type"
, "Cookie"
, "Date"
, "Host"
, "If-Modified-Since"
, "If-Range"
, "If-Unmodified-Since"
, "Last-Modified"
, "Location"
, "Range"
, "Server"
, "Set-Cookie2"
, "Status"
, "Transfer-Encoding" ]
type FieldValue = S.ByteString
stringFieldKey :: M.Map FieldValue FieldKey
stringFieldKey = M.fromList (zip fieldStringList fieldKeyList)
fieldKeyString :: M.Map FieldKey FieldValue
fieldKeyString = M.fromList (zip fieldKeyList fieldStringList)
toFieldKey :: S.ByteString -> FieldKey
toFieldKey str = maybe (FkOther cstr) id $ M.lookup cstr stringFieldKey
where
cstr = capitalize str
fromFieldKey :: FieldKey -> S.ByteString
fromFieldKey (FkOther cstr) = cstr
fromFieldKey key = maybe err id $ M.lookup key fieldKeyString
where
err = error "fromFieldKey"
(<:>) :: Char -> S.ByteString -> S.ByteString
(<:>) = S.cons
capitalize :: S.ByteString -> S.ByteString
capitalize s = toup s
where
toup "" = ""
toup bs
| isLetter x = toUpper x <:> stay xs
| otherwise = x <:> toup xs
where
x = S.head bs
xs = S.tail bs
stay "" = ""
stay bs
| isLetter x = x <:> stay xs
| otherwise = x <:> toup xs
where
x = S.head bs
xs = S.tail bs
type CT = S.ByteString
selectContentType :: String -> CT
selectContentType "" = textPlain
selectContentType ext = maybe appOct id (lookup lext contentTypeDB)
where
lext = map toLower ext
textHtml :: CT
textHtml = "text/html"
textPlain :: CT
textPlain = "text/plain"
appOct :: CT
appOct = "application/octet-stream"
contentTypeDB :: [(FilePath,CT)]
contentTypeDB = [ (".html", textHtml)
, (".txt", textPlain)
, (".css", "text/css")
, (".js", "application/javascript")
, (".jpg", "image/jpeg")
, (".png", "image/png")
, (".gif", "image/gif")
, (".pdf", "application/pdf")
, (".zip", "application/zip")
, (".gz", appOct)
, (".ico", "image/x-icon")
]
data Persist = Close | Keep | PerUnknown deriving (Eq,Show)
fromPersist :: Persist -> S.ByteString
fromPersist Close = "close"
fromPersist Keep = "keep-alive"
fromPersist PerUnknown = "unknown"
toPersist :: S.ByteString -> Persist
toPersist cs = readPersist' (downcase cs)
where
downcase = S.map toLower
readPersist' "close" = Close
readPersist' "keep-alive" = Keep
readPersist' _ = PerUnknown
data ServerException
= TimeOut
| TerminatedByClient
deriving (Eq, Ord, Typeable)
instance Exception ServerException
instance Show ServerException where
showsPrec _ TimeOut = showString "Connection time out"
showsPrec _ TerminatedByClient = showString "Connection is terminated by client"