X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=1ae5abd9589bd2f697f849b5f1189ecc6e0c3bcf;hp=b5a934118e68cf513b3fe72a4c357b212bd847eb;hb=3318fe0;hpb=69686745233be9269796be9f26621040fb7d9d1c diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index b5a9341..1ae5abd 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,32 +1,27 @@ {-# LANGUAGE - BangPatterns - , OverloadedStrings - , UnboxedTuples + OverloadedStrings + , RecordWildCards + , 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 qualified Data.ByteString.Char8 as C8 import Data.Maybe -import qualified Data.Sequence as S -import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Format 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) @@ -36,129 +31,113 @@ import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.DOM.TypeDefs -getDefaultPage ∷ Config → Maybe Request → Response → Text +getDefaultPage ∷ Config → Maybe Request → Response → Builder {-# INLINEABLE getDefaultPage #-} -getDefaultPage !conf !req !res +getDefaultPage conf req res = let msgA = getMsg req res [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA ⋙ writeDocumentToString [ withIndent True ] ) () in - T.pack xmlStr + BB.fromString xmlStr -writeDefaultPage ∷ Interaction → STM () -writeDefaultPage !itr - -- Content-Type が正しくなければ補完できない。 - = do res ← readItr itr itrResponse id - when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do reqM ← readItr itr itrRequest id +defaultPageContentType ∷ Ascii +{-# INLINE defaultPageContentType #-} +defaultPageContentType = "application/xhtml+xml" - let conf = itrConfig itr - page = getDefaultPage conf reqM res - - writeTVar (itrBodyToSend itr) - (S.singleton (encodeUtf8 page)) - -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 (# sCode, sMsg #) = statusCode status - sig = concat [ C8.unpack (cnfServerSoftware conf) - , " at " - , C8.unpack (cnfServerHost conf) - ] +mkDefaultPage conf status msgA + = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status + sig = concat [ A.toString (cnfServerSoftware conf) + , " at " + , T.unpack (cnfServerHost conf) + ] in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (fmtDec 3 sCode ⧺ " " ⧺ C8.unpack sMsg) + += txt sStr )) += ( eelem "body" += ( eelem "h1" - += txt (C8.unpack sMsg) + += txt sStr ) += ( eelem "p" += 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: + | 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