From 51eda5b02d4528e2e240cbfc228de02b1c83799a Mon Sep 17 00:00:00 2001 From: PHO Date: Sun, 6 Nov 2011 23:57:21 +0900 Subject: [PATCH] StatusCode is now a type class, not an algebraic data type. Ditz-issue: c566a8433e8af700655680f53e99cfe9f563ed32 --- Lucu.cabal | 2 + Network/HTTP/Lucu.hs | 3 +- Network/HTTP/Lucu/Abortion.hs | 8 +- Network/HTTP/Lucu/Abortion/Internal.hs | 2 +- Network/HTTP/Lucu/DefaultPage.hs | 143 +++++++++---------- Network/HTTP/Lucu/Interaction.hs | 4 +- Network/HTTP/Lucu/Postprocess.hs | 6 +- Network/HTTP/Lucu/Preprocess.hs | 10 +- Network/HTTP/Lucu/RequestReader.hs | 4 +- Network/HTTP/Lucu/Resource.hs | 19 +-- Network/HTTP/Lucu/Resource/Internal.hs | 2 +- Network/HTTP/Lucu/Response.hs | 173 ++++------------------- Network/HTTP/Lucu/ResponseWriter.hs | 2 +- Network/HTTP/Lucu/StatusCode.hs | 133 +++++++++++++++++ Network/HTTP/Lucu/StatusCode/Internal.hs | 146 +++++++++++++++++++ Network/HTTP/Lucu/Utils.hs | 16 --- 16 files changed, 411 insertions(+), 262 deletions(-) create mode 100644 Network/HTTP/Lucu/StatusCode.hs create mode 100644 Network/HTTP/Lucu/StatusCode/Internal.hs diff --git a/Lucu.cabal b/Lucu.cabal index 8a04bd4..deed597 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -87,6 +87,7 @@ Library Network.HTTP.Lucu.Resource.Tree Network.HTTP.Lucu.Response Network.HTTP.Lucu.StaticFile + Network.HTTP.Lucu.StatusCode Network.HTTP.Lucu.Utils Other-Modules: @@ -103,6 +104,7 @@ Library Network.HTTP.Lucu.Resource.Internal Network.HTTP.Lucu.ResponseWriter Network.HTTP.Lucu.SocketLike + Network.HTTP.Lucu.StatusCode.Internal ghc-options: -Wall diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 58cb486..3579c5c 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -44,7 +44,7 @@ module Network.HTTP.Lucu -- ** Things to be used in the Resource monad -- *** Status Code - , StatusCode(..) + , module Network.HTTP.Lucu.StatusCode -- *** 'Abortion' , module Network.HTTP.Lucu.Abortion @@ -80,3 +80,4 @@ import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.StaticFile +import Network.HTTP.Lucu.StatusCode diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 40a8cb5..064a97e 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -23,22 +23,22 @@ import Prelude.Unicode -- |Construct an 'Abortion' with additional headers and an optional -- message text. -mkAbortion ∷ StatusCode → [(CIAscii, Ascii)] → Maybe Text → Abortion +mkAbortion ∷ StatusCode sc ⇒ sc → [(CIAscii, Ascii)] → Maybe Text → Abortion {-# INLINE mkAbortion #-} mkAbortion sc hdr msg = Abortion { - aboStatus = sc + aboStatus = fromStatusCode sc , aboHeaders = toHeaders hdr , aboMessage = msg } -- |Construct an 'Abortion' without any additional headers but with a -- message text. -mkAbortion' ∷ StatusCode → Text → Abortion +mkAbortion' ∷ StatusCode sc ⇒ sc → Text → Abortion {-# INLINE mkAbortion' #-} mkAbortion' sc msg = Abortion { - aboStatus = sc + aboStatus = fromStatusCode sc , aboHeaders = (∅) , aboMessage = Just msg } diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs index f71e045..6142c23 100644 --- a/Network/HTTP/Lucu/Abortion/Internal.hs +++ b/Network/HTTP/Lucu/Abortion/Internal.hs @@ -45,7 +45,7 @@ import Text.XML.HXT.Arrow.XmlState -- > [("Location", "http://example.net/")] -- > "It has been moved to example.net" data Abortion = Abortion { - aboStatus ∷ !StatusCode + aboStatus ∷ !SomeStatusCode , aboHeaders ∷ !Headers , aboMessage ∷ !(Maybe Text) } deriving (Eq, Show, Typeable) diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 19a7293..8fcc37d 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings + , RecordWildCards + , TypeOperators , UnicodeSyntax #-} module Network.HTTP.Lucu.DefaultPage @@ -44,7 +46,11 @@ defaultPageContentType ∷ Ascii {-# INLINE defaultPageContentType #-} defaultPageContentType = "application/xhtml+xml" -mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree +mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc) + ⇒ Config + → sc + → b ⇝ XmlTree + → b ⇝ XmlTree {-# INLINEABLE mkDefaultPage #-} mkDefaultPage conf status msgA = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status @@ -67,82 +73,71 @@ mkDefaultPage conf status msgA += eelem "hr" += ( eelem "address" += txt sig )))) -getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree +getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree {-# INLINEABLE getMsg #-} -getMsg req res - = case resStatus res of - -- 1xx は body を持たない - -- 2xx の body は補完しない - - -- 3xx - MovedPermanently - → txt ("The resource at " ⧺ path ⧺ " has been moved to ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt " permanently." - - Found - → txt ("The resource at " ⧺ path ⧺ " is currently located at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt ". This is not a permanent relocation." - - SeeOther - → txt ("The resource at " ⧺ path ⧺ " can be found at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt "." - - TemporaryRedirect - → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt "." - - -- 4xx - BadRequest - → txt "The server could not understand the request you sent." - - Unauthorized - → txt ("You need a valid authentication to access " ⧺ path) - - Forbidden - → txt ("You don't have permission to access " ⧺ path) - - NotFound - → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.") - - Gone - → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.") - - RequestEntityTooLarge - → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.") - - RequestURITooLarge - → txt "The request URI you sent was too large to accept." - - -- 5xx - InternalServerError - → txt ("An internal server error has occured during the process of your request to " ⧺ path) - - ServiceUnavailable - → txt "The service is temporarily unavailable. Try later." - - _ → none - +getMsg req res@(Response {..}) + -- 1xx responses don't have a body. + -- 2xx responses don't need a body to be completed. + -- 3xx: + | toStatusCode resStatus ≡ Just MovedPermanently + = txt ("The resource at " ⧺ path ⧺ " has been moved to ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt " permanently." + + | toStatusCode resStatus ≡ Just Found + = txt ("The resource at " ⧺ path ⧺ " is currently located at ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt ". This is not a permanent relocation." + + | toStatusCode resStatus ≡ Just SeeOther + = txt ("The resource at " ⧺ path ⧺ " can be found at ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt "." + + | toStatusCode resStatus ≡ Just TemporaryRedirect + = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt "." + + -- 4xx: + | toStatusCode resStatus ≡ Just BadRequest + = txt "The server could not understand the request you sent." + | toStatusCode resStatus ≡ Just Unauthorized + = txt ("You need a valid authentication to access " ⧺ path) + | toStatusCode resStatus ≡ Just Forbidden + = txt ("You don't have permission to access " ⧺ path) + | toStatusCode resStatus ≡ Just NotFound + = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.") + | toStatusCode resStatus ≡ Just Gone + = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.") + | toStatusCode resStatus ≡ Just RequestEntityTooLarge + = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.") + | toStatusCode resStatus ≡ Just RequestURITooLarge + = txt "The request URI you sent was too large to accept." + + -- 5xx: + | toStatusCode resStatus ≡ Just InternalServerError + = txt ("An internal server error has occured during the process of your request to " ⧺ path) + | toStatusCode resStatus ≡ Just ServiceUnavailable + = txt "The service is temporarily unavailable. Try later." + + | otherwise + = none where path ∷ String - path = let uri = reqURI $ fromJust req - in - uriPath uri + path = uriPath $ reqURI $ fromJust req loc ∷ String loc = A.toString $ fromJust $ getHeader "Location" res diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index f1e7ab3..df5e230 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -216,11 +216,11 @@ type InteractionQueue = TVar (Seq SomeInteraction) mkInteractionQueue ∷ IO InteractionQueue mkInteractionQueue = newTVarIO (∅) -setResponseStatus ∷ NormalInteraction → StatusCode → STM () +setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM () setResponseStatus (NI {..}) sc = do res ← readTVar niResponse let res' = res { - resStatus = sc + resStatus = fromStatusCode sc } writeTVar niResponse res' diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 6735652..29c3c51 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -47,14 +47,14 @@ abortOnCertainConditions (NI {..}) $ A.toAsciiBuilder "Inappropriate status code for a response: " ⊕ printStatusCode resStatus - when ( resStatus ≡ MethodNotAllowed ∧ - hasHeader "Allow" res ) + when ( toStatusCode resStatus ≡ Just MethodNotAllowed ∧ + hasHeader "Allow" res ) $ abort' $ A.toAsciiBuilder "The status was " ⊕ printStatusCode resStatus ⊕ A.toAsciiBuilder " but no \"Allow\" header." - when ( resStatus ≢ NotModified ∧ + when ( toStatusCode resStatus ≢ Just NotModified ∧ isRedirection resStatus ∧ hasHeader "Location" res ) $ abort' diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 26fbd53..3a02ad8 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -31,7 +31,7 @@ import Prelude.Unicode data AugmentedRequest = AugmentedRequest { arRequest ∷ !Request - , arInitialStatus ∷ !StatusCode + , arInitialStatus ∷ !SomeStatusCode , arWillChunkBody ∷ !Bool , arWillDiscardBody ∷ !Bool , arWillClose ∷ !Bool @@ -51,7 +51,7 @@ preprocess localHost localPort req@(Request {..}) initialAR ∷ AugmentedRequest initialAR = AugmentedRequest { arRequest = req - , arInitialStatus = Ok + , arInitialStatus = fromStatusCode OK , arWillChunkBody = False , arWillDiscardBody = False , arWillClose = False @@ -69,9 +69,9 @@ setRequest ∷ Request → State AugmentedRequest () setRequest req = modify $ \ar → ar { arRequest = req } -setStatus ∷ StatusCode → State AugmentedRequest () +setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest () setStatus sc - = modify $ \ar → ar { arInitialStatus = sc } + = modify $ \ar → ar { arInitialStatus = fromStatusCode sc } setWillClose ∷ Bool → State AugmentedRequest () setWillClose b @@ -90,7 +90,7 @@ examineHttpVersion → setWillClose True HttpVersion 1 1 → modify $ \ar → ar { arWillChunkBody = True } - _ → do setStatus HttpVersionNotSupported + _ → do setStatus HTTPVersionNotSupported setWillClose True examineMethod ∷ State AugmentedRequest () diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 7f48c9b..b5feafe 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -118,7 +118,9 @@ acceptParsableRequest ctx@(Context {..}) req input do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar case rsrc of Nothing - → do let ar' = ar { arInitialStatus = NotFound } + → do let ar' = ar { + arInitialStatus = fromStatusCode NotFound + } acceptSemanticallyInvalidRequest ctx ar' input Just (path, def) → acceptRequestForResource ctx ar input path def diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 704feda..f7b90f9 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -161,6 +161,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time import qualified Data.Time.HTTP as HTTP +import Data.Typeable import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config @@ -404,9 +405,9 @@ foundETag tag let statusForNoneMatch = if method ≡ GET ∨ method ≡ HEAD then - NotModified + fromStatusCode NotModified else - PreconditionFailed + fromStatusCode PreconditionFailed -- If-None-Match があればそれを見る。 ifNoneMatch ← getHeader "If-None-Match" @@ -454,9 +455,9 @@ foundTimeStamp timeStamp let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then - NotModified + fromStatusCode NotModified else - PreconditionFailed + fromStatusCode PreconditionFailed -- If-Modified-Since があればそれを見る。 ifModSince ← getHeader "If-Modified-Since" @@ -612,16 +613,16 @@ getForm limit -- |@'redirect' code uri@ declares the response status as @code@ and -- \"Location\" header field as @uri@. The @code@ must satisfy -- 'isRedirection' or it raises an error. -redirect ∷ StatusCode → URI → Resource () -redirect code uri - = do when (code ≡ NotModified ∨ not (isRedirection code)) +redirect ∷ StatusCode sc ⇒ sc → URI → Resource () +redirect sc uri + = do when (cast sc ≡ Just NotModified ∨ (¬) (isRedirection sc)) $ abort $ mkAbortion' InternalServerError $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Attempted to redirect with status " - ⊕ printStatusCode code - setStatus code + ⊕ printStatusCode sc + setStatus sc setLocation uri -- |@'setContentType' mType@ declares the response header diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index f43ec6c..e066fa9 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -304,7 +304,7 @@ getChunk' n -- |Declare the response status code. If you don't call this function, -- the status code will be defaulted to \"200 OK\". -setStatus ∷ StatusCode → Resource () +setStatus ∷ StatusCode sc ⇒ sc → Resource () setStatus sc = do ni ← getInteraction liftIO $ atomically diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 35c168f..cfff819 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,20 +1,21 @@ {-# LANGUAGE - DeriveDataTypeable - , OverloadedStrings + OverloadedStrings , RecordWildCards - , UnboxedTuples , UnicodeSyntax , ViewPatterns #-} - -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response - ( StatusCode(..) - , printStatusCode - + ( -- * Class and Types + StatusCode(..) + , SomeStatusCode(..) , Response(..) + , module Network.HTTP.Lucu.StatusCode + + -- * Functions , emptyResponse , resCanHaveBody + , printStatusCode , printResponse , isInformational @@ -25,84 +26,24 @@ module Network.HTTP.Lucu.Response , isServerError ) where -import Data.Ascii (Ascii, AsciiBuilder) +import Data.Ascii (AsciiBuilder) import qualified Data.Ascii as A import Data.Monoid.Unicode -import Data.Typeable import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Utils +import Network.HTTP.Lucu.StatusCode +import Network.HTTP.Lucu.StatusCode.Internal import Prelude.Unicode --- |This is the definition of HTTP status code. --- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status --- codes so you don't have to memorize, for instance, that \"Gateway --- Timeout\" is 504. -data StatusCode = Continue - | SwitchingProtocols - | Processing - -- - | Ok - | Created - | Accepted - | NonAuthoritativeInformation - | NoContent - | ResetContent - | PartialContent - | MultiStatus - -- - | MultipleChoices - | MovedPermanently - | Found - | SeeOther - | NotModified - | UseProxy - | TemporaryRedirect - -- - | BadRequest - | Unauthorized - | PaymentRequired - | Forbidden - | NotFound - | MethodNotAllowed - | NotAcceptable - | ProxyAuthenticationRequired - | RequestTimeout - | Conflict - | Gone - | LengthRequired - | PreconditionFailed - | RequestEntityTooLarge - | RequestURITooLarge - | UnsupportedMediaType - | RequestRangeNotSatisfiable - | ExpectationFailed - | UnprocessableEntitiy - | Locked - | FailedDependency - -- - | InternalServerError - | NotImplemented - | BadGateway - | ServiceUnavailable - | GatewayTimeout - | HttpVersionNotSupported - | InsufficientStorage - deriving (Eq, Show, Typeable) - -- |Convert a 'StatusCode' to an 'AsciiBuilder'. -printStatusCode ∷ StatusCode → AsciiBuilder +printStatusCode ∷ StatusCode sc ⇒ sc → AsciiBuilder {-# INLINEABLE printStatusCode #-} -printStatusCode (statusCode → (# num, msg #)) - = ( show3 num ⊕ - A.toAsciiBuilder " " ⊕ - A.toAsciiBuilder msg - ) +printStatusCode = A.toAsciiBuilder ∘ textualStatus -- |This is the definition of an HTTP response. data Response = Response { resVersion ∷ !HttpVersion - , resStatus ∷ !StatusCode + , resStatus ∷ !SomeStatusCode , resHeaders ∷ !Headers } deriving (Show, Eq) @@ -111,11 +52,11 @@ instance HasHeaders Response where setHeaders res hdr = res { resHeaders = hdr } -- |Returns an HTTP\/1.1 'Response' with no header fields. -emptyResponse ∷ StatusCode → Response +emptyResponse ∷ StatusCode sc ⇒ sc → Response emptyResponse sc = Response { resVersion = HttpVersion 1 1 - , resStatus = sc + , resStatus = fromStatusCode sc , resHeaders = (∅) } @@ -124,11 +65,11 @@ emptyResponse sc resCanHaveBody ∷ Response → Bool {-# INLINEABLE resCanHaveBody #-} resCanHaveBody (Response {..}) - | isInformational resStatus = False - | resStatus ≡ NoContent = False - | resStatus ≡ ResetContent = False - | resStatus ≡ NotModified = False - | otherwise = True + | isInformational resStatus = False + | toStatusCode resStatus ≡ Just NoContent = False + | toStatusCode resStatus ≡ Just ResetContent = False + | toStatusCode resStatus ≡ Just NotModified = False + | otherwise = True -- |Convert a 'Response' to 'AsciiBuilder'. printResponse ∷ Response → AsciiBuilder @@ -141,91 +82,35 @@ printResponse (Response {..}) printHeaders resHeaders -- |@'isInformational' sc@ returns 'True' iff @sc < 200@. -isInformational ∷ StatusCode → Bool +isInformational ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isInformational #-} isInformational = satisfy (< 200) -- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@. -isSuccessful ∷ StatusCode → Bool +isSuccessful ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isSuccessful #-} isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300) -- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@. -isRedirection ∷ StatusCode → Bool +isRedirection ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isRedirection #-} isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400) -- |@'isError' sc@ returns 'True' iff @400 <= sc@ -isError ∷ StatusCode → Bool +isError ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isError #-} isError = satisfy (≥ 400) -- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@. -isClientError ∷ StatusCode → Bool +isClientError ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isClientError #-} isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500) -- |@'isServerError' sc@ returns 'True' iff @500 <= sc@. -isServerError ∷ StatusCode → Bool +isServerError ∷ StatusCode sc ⇒ sc → Bool {-# INLINE isServerError #-} isServerError = satisfy (≥ 500) -satisfy ∷ (Int → Bool) → StatusCode → Bool +satisfy ∷ StatusCode sc ⇒ (Int → Bool) → sc → Bool {-# INLINE satisfy #-} -satisfy p (statusCode → (# num, _ #)) = p num - -statusCode ∷ StatusCode → (# Int, Ascii #) -{-# INLINEABLE statusCode #-} - -statusCode Continue = (# 100, "Continue" #) -statusCode SwitchingProtocols = (# 101, "Switching Protocols" #) -statusCode Processing = (# 102, "Processing" #) - -statusCode Ok = (# 200, "OK" #) -statusCode Created = (# 201, "Created" #) -statusCode Accepted = (# 202, "Accepted" #) -statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #) -statusCode NoContent = (# 204, "No Content" #) -statusCode ResetContent = (# 205, "Reset Content" #) -statusCode PartialContent = (# 206, "Partial Content" #) -statusCode MultiStatus = (# 207, "Multi Status" #) - -statusCode MultipleChoices = (# 300, "Multiple Choices" #) -statusCode MovedPermanently = (# 301, "Moved Permanently" #) -statusCode Found = (# 302, "Found" #) -statusCode SeeOther = (# 303, "See Other" #) -statusCode NotModified = (# 304, "Not Modified" #) -statusCode UseProxy = (# 305, "Use Proxy" #) -statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #) - -statusCode BadRequest = (# 400, "Bad Request" #) -statusCode Unauthorized = (# 401, "Unauthorized" #) -statusCode PaymentRequired = (# 402, "Payment Required" #) -statusCode Forbidden = (# 403, "Forbidden" #) -statusCode NotFound = (# 404, "Not Found" #) -statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #) -statusCode NotAcceptable = (# 406, "Not Acceptable" #) -statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #) -statusCode RequestTimeout = (# 408, "Request Timeout" #) -statusCode Conflict = (# 409, "Conflict" #) -statusCode Gone = (# 410, "Gone" #) -statusCode LengthRequired = (# 411, "Length Required" #) -statusCode PreconditionFailed = (# 412, "Precondition Failed" #) -statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #) -statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #) -statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #) -statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #) -statusCode ExpectationFailed = (# 417, "Expectation Failed" #) -statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #) -statusCode Locked = (# 423, "Locked" #) -statusCode FailedDependency = (# 424, "Failed Dependency" #) - -statusCode InternalServerError = (# 500, "Internal Server Error" #) -statusCode NotImplemented = (# 501, "Not Implemented" #) -statusCode BadGateway = (# 502, "Bad Gateway" #) -statusCode ServiceUnavailable = (# 503, "Service Unavailable" #) -statusCode GatewayTimeout = (# 504, "Gateway Timeout" #) -statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #) -statusCode InsufficientStorage = (# 507, "Insufficient Storage" #) --- FIXME: Textual representations should also include numbers. --- FIXME: StatusCode should be a type class rather than a type. +satisfy p (numericCode → num) = p num diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index d89ee9e..24ee47e 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -106,7 +106,7 @@ writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) when isNeeded $ do let cont = Response { resVersion = HttpVersion 1 1 - , resStatus = Continue + , resStatus = fromStatusCode Continue , resHeaders = (∅) } hPutBuilder cHandle $ A.toBuilder $ printResponse cont diff --git a/Network/HTTP/Lucu/StatusCode.hs b/Network/HTTP/Lucu/StatusCode.hs new file mode 100644 index 0000000..950d964 --- /dev/null +++ b/Network/HTTP/Lucu/StatusCode.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE + DeriveDataTypeable + , QuasiQuotes + #-} +-- |Definition of HTTP status code. +-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status +-- codes so you don't have to memorize that, say, \"Gateway Timeout\" +-- is 504. +module Network.HTTP.Lucu.StatusCode + ( -- * Informational + Continue(..) + , SwitchingProtocols(..) + , Processing(..) + + -- * Successful + , OK(..) + , Created(..) + , Accepted(..) + , NonAuthoritativeInformation(..) + , NoContent(..) + , ResetContent(..) + , PartialContent(..) + , MultiStatus(..) + , AlreadyReported(..) + , IMUsed(..) + + -- * Redirection + , MultipleChoices(..) + , MovedPermanently(..) + , Found(..) + , SeeOther(..) + , NotModified(..) + , UseProxy(..) + , TemporaryRedirect(..) + + -- * Client Error + , BadRequest(..) + , Unauthorized(..) + , PaymentRequired(..) + , Forbidden(..) + , NotFound(..) + , MethodNotAllowed(..) + , NotAcceptable(..) + , ProxyAuthenticationRequired(..) + , RequestTimeout(..) + , Conflict(..) + , Gone(..) + , LengthRequired(..) + , PreconditionFailed(..) + , RequestEntityTooLarge(..) + , RequestURITooLarge(..) + , UnsupportedMediaType(..) + , RequestRangeNotSatisfiable(..) + , ExpectationFailed(..) + , UnprocessableEntity(..) + , Locked(..) + , FailedDependency(..) + , UpgradeRequired(..) + + -- * Server Error + , InternalServerError(..) + , NotImplemented(..) + , BadGateway(..) + , ServiceUnavailable(..) + , GatewayTimeout(..) + , HTTPVersionNotSupported(..) + , VariantAlsoNegotiates(..) + , InsufficientStorage(..) + , LoopDetected(..) + , NotExtended(..) + ) + where +import Data.Typeable +import Network.HTTP.Lucu.StatusCode.Internal + +[statusCodes| +100 Continue +101 Switching Protocols +102 Processing + +200 OK +201 Created +202 Accepted +203 Non Authoritative Information +204 No Content +205 Reset Content +206 Partial Content +207 Multi Status +208 Already Reported +226 IM Used + +300 Multiple Choices +301 Moved Permanently +302 Found +303 See Other +304 Not Modified +305 Use Proxy +307 Temporary Redirect + +400 Bad Request +401 Unauthorized +402 Payment Required +403 Forbidden +404 Not Found +405 Method Not Allowed +406 Not Acceptable +407 Proxy Authentication Required +408 Request Timeout +409 Conflict +410 Gone +411 Length Required +412 Precondition Failed +413 Request Entity Too Large +414 Request URI Too Large +415 Unsupported Media Type +416 Request Range Not Satisfiable +417 Expectation Failed +422 Unprocessable Entity +423 Locked +424 Failed Dependency +426 Upgrade Required + +500 Internal Server Error +501 Not Implemented +502 Bad Gateway +503 Service Unavailable +504 Gateway Timeout +505 HTTP Version Not Supported +506 Variant Also Negotiates +507 Insufficient Storage +508 Loop Detected +510 Not Extended +|] diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs new file mode 100644 index 0000000..9269c5d --- /dev/null +++ b/Network/HTTP/Lucu/StatusCode/Internal.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE + DeriveDataTypeable + , ExistentialQuantification + , FlexibleInstances + , TemplateHaskell + , UnicodeSyntax + , ViewPatterns + #-} +module Network.HTTP.Lucu.StatusCode.Internal + ( StatusCode(..) + , SomeStatusCode(..) + , statusCodes + ) + where +import Control.Applicative +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import Data.Attoparsec.Lazy as LP +import qualified Data.ByteString.Lazy.Char8 as Lazy +import Data.List +import Data.Typeable +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Network.HTTP.Lucu.Parser +import Prelude.Unicode + +-- |The type class for HTTP status codes. +-- +-- Minimal complete definition: 'numericCode' and 'textualStatus'. +class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where + -- |Return the 3-digit integer for this status e.g. @200@ + numericCode ∷ sc → Int + -- |Return the combination of 3-digit integer and reason phrase + -- for this status e.g. @200 OK@ + textualStatus ∷ sc → Ascii + -- |Wrap the status code into 'SomeStatusCode'. + fromStatusCode ∷ sc → SomeStatusCode + fromStatusCode = SomeStatusCode + -- |Cast the status code from 'SomeStatusCode'. + toStatusCode ∷ SomeStatusCode → Maybe sc + toStatusCode (SomeStatusCode sc) = cast sc + +-- |FIXME: doc +data SomeStatusCode + = ∀sc. StatusCode sc ⇒ SomeStatusCode sc + deriving Typeable + +instance Show SomeStatusCode where + show (SomeStatusCode sc) = show sc + +instance Eq SomeStatusCode where + (SomeStatusCode α) == (SomeStatusCode β) + = numericCode α ≡ numericCode β + +instance StatusCode SomeStatusCode where + numericCode (SomeStatusCode sc) = numericCode sc + textualStatus (SomeStatusCode sc) = textualStatus sc + fromStatusCode = id + toStatusCode = Just + +-- |FIXME: doc +statusCodes ∷ QuasiQuoter +statusCodes = QuasiQuoter { + quoteExp = const unsupported + , quotePat = const unsupported + , quoteType = const unsupported + , quoteDec = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack + } + where + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of statusCodes quasi-quoter." + +parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])] +parseStatusCodes src + = case LP.parse pairs src of + LP.Fail _ eCtx e + → error $ "Unparsable status codes: " + ⧺ intercalate ", " eCtx + ⧺ ": " + ⧺ e + LP.Done _ xs + → xs + where + pairs ∷ Parser [(Int, [Ascii])] + pairs = do skipMany endOfLine + xs ← sepBy pair (skipMany1 endOfLine) + skipMany endOfLine + endOfInput + return xs + + "pairs" + + pair ∷ Parser (Int, [Ascii]) + pair = do skipSpace + num ← decimal + skipSpace1 + phrase ← sepBy1 word $ skipWhile1 (≡ '\x20') + return (num, phrase) + + "pair" + + word ∷ Parser Ascii + word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii + +statusDecl ∷ (Int, [Ascii]) → Q [Dec] +statusDecl (num, phrase) + = do a ← dataDecl + bs ← instanceDecl + return (a:bs) + where + name ∷ Name + name = mkName $ concatMap A.toString phrase + + dataDecl ∷ Q Dec + dataDecl = dataD (cxt []) + name + [] + [con] + [ mkName "Eq" + , mkName "Show" + , mkName "Typeable" + ] + + instanceDecl ∷ Q [Dec] + instanceDecl + = [d| instance StatusCode $typ where + {-# INLINE numericCode #-} + numericCode _ = $(lift num) + {-# INLINE textualStatus #-} + textualStatus _ = $txt + |] + + typ ∷ Q Type + typ = conT name + + con ∷ Q Con + con = return $ NormalC name [] + + txt ∷ Q Exp + txt = [| A.unsafeFromString $(lift txt') |] + + txt' ∷ String + txt' = concat $ intersperse "\x20" + $ show num : map A.toString phrase diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 5cee03a..d6e571d 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -10,15 +10,12 @@ module Network.HTTP.Lucu.Utils , quoteStr , parseWWWFormURLEncoded , splitPathInfo - , show3 , trim , liftCIAscii , liftText , liftMap ) where -import Blaze.ByteString.Builder.ByteString as B -import Blaze.Text.Int as BT import Control.Monad import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A @@ -98,19 +95,6 @@ splitPathInfo uri in map BS.pack reqPath --- |>>> show3 5 --- "005" -show3 ∷ Integral n ⇒ n → AsciiBuilder -{-# INLINEABLE show3 #-} -show3 = A.unsafeFromBuilder ∘ go - where - go i | i ≥ 0 ∧ i < 10 = B.fromByteString "00" ⊕ BT.digit i - | i ≥ 0 ∧ i < 100 = B.fromByteString "0" ⊕ BT.integral i - | i ≥ 0 ∧ i < 1000 = BT.integral i - | otherwise = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i) --- FIXME: Drop this function as soon as possible, to eliminate the --- dependency on blaze-textual. - -- |>>> trim " ab c d " -- "ab c d" trim ∷ String → String -- 2.40.0