Network.HTTP.Lucu.Resource.Tree
Network.HTTP.Lucu.Response
Network.HTTP.Lucu.StaticFile
+ Network.HTTP.Lucu.StatusCode
Network.HTTP.Lucu.Utils
Other-Modules:
Network.HTTP.Lucu.Resource.Internal
Network.HTTP.Lucu.ResponseWriter
Network.HTTP.Lucu.SocketLike
+ Network.HTTP.Lucu.StatusCode.Internal
ghc-options:
-Wall
-- ** Things to be used in the Resource monad
-- *** Status Code
- , StatusCode(..)
+ , module Network.HTTP.Lucu.StatusCode
-- *** 'Abortion'
, module Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.StaticFile
+import Network.HTTP.Lucu.StatusCode
-- |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
}
-- > [("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)
{-# LANGUAGE
OverloadedStrings
+ , RecordWildCards
+ , TypeOperators
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.DefaultPage
{-# 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
+= 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
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'
$ 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'
data AugmentedRequest
= AugmentedRequest {
arRequest ∷ !Request
- , arInitialStatus ∷ !StatusCode
+ , arInitialStatus ∷ !SomeStatusCode
, arWillChunkBody ∷ !Bool
, arWillDiscardBody ∷ !Bool
, arWillClose ∷ !Bool
initialAR ∷ AugmentedRequest
initialAR = AugmentedRequest {
arRequest = req
- , arInitialStatus = Ok
+ , arInitialStatus = fromStatusCode OK
, arWillChunkBody = False
, arWillDiscardBody = False
, arWillClose = False
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
→ setWillClose True
HttpVersion 1 1
→ modify $ \ar → ar { arWillChunkBody = True }
- _ → do setStatus HttpVersionNotSupported
+ _ → do setStatus HTTPVersionNotSupported
setWillClose True
examineMethod ∷ State AugmentedRequest ()
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
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
let statusForNoneMatch
= if method ≡ GET ∨ method ≡ HEAD then
- NotModified
+ fromStatusCode NotModified
else
- PreconditionFailed
+ fromStatusCode PreconditionFailed
-- If-None-Match があればそれを見る。
ifNoneMatch ← getHeader "If-None-Match"
let statusForIfModSince
= if method ≡ GET ∨ method ≡ HEAD then
- NotModified
+ fromStatusCode NotModified
else
- PreconditionFailed
+ fromStatusCode PreconditionFailed
-- If-Modified-Since があればそれを見る。
ifModSince ← getHeader "If-Modified-Since"
-- |@'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
-- |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
{-# 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
, 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)
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 = (∅)
}
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
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
when isNeeded
$ do let cont = Response {
resVersion = HttpVersion 1 1
- , resStatus = Continue
+ , resStatus = fromStatusCode Continue
, resHeaders = (∅)
}
hPutBuilder cHandle $ A.toBuilder $ printResponse cont
--- /dev/null
+{-# 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
+|]
--- /dev/null
+{-# 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
, 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
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
projects / Lucu.git / commitdiff