{-# LANGUAGE
OverloadedStrings
, RecordWildCards
- , UnboxedTuples
+ , TypeOperators
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.DefaultPage
( getDefaultPage
- , writeDefaultPage
+ , defaultPageContentType
, mkDefaultPage
)
where
+import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
-import Control.Concurrent.STM
-import Control.Monad
+import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import Data.Maybe
import qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.URI hiding (path)
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.DOM.TypeDefs
-getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
+getDefaultPage ∷ Config → Maybe Request → Response → Builder
{-# INLINEABLE getDefaultPage #-}
getDefaultPage conf req res
= let msgA = getMsg req res
writeDocumentToString [ withIndent True ]
) ()
in
- Lazy.pack xmlStr
+ BB.fromString xmlStr
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage (Interaction {..})
- -- Content-Type が正しくなければ補完できない。
- = do res ← readTVar itrResponse
- when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
- $ do let page = getDefaultPage itrConfig itrRequest res
- putTMVar itrBodyToSend (BB.fromLazyText page)
+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
+= 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:
+ | resStatus ≈ MovedPermanently
+ = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt " permanently."
+
+ | resStatus ≈ Found
+ = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt ". This is not a permanent relocation."
+
+ | resStatus ≈ SeeOther
+ = txt ("The resource at " ⧺ path ⧺ " can be found at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ | resStatus ≈ TemporaryRedirect
+ = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
+ <+>
+ eelem "a" += sattr "href" loc
+ += txt loc
+ <+>
+ txt "."
+
+ -- 4xx:
+ | resStatus ≈ BadRequest
+ = txt "The server could not understand the request you sent."
+ | resStatus ≈ Unauthorized
+ = txt ("You need a valid authentication to access " ⧺ path)
+ | resStatus ≈ Forbidden
+ = txt ("You don't have permission to access " ⧺ path)
+ | resStatus ≈ NotFound
+ = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
+ | resStatus ≈ Gone
+ = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
+ | resStatus ≈ RequestEntityTooLarge
+ = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
+ | resStatus ≈ RequestURITooLarge
+ = txt "The request URI you sent was too large to accept."
+
+ -- 5xx:
+ | resStatus ≈ InternalServerError
+ = txt ("An internal server error has occured during the process of your request to " ⧺ path)
+ | resStatus ≈ 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
projects / Lucu.git / blobdiff