X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=d95291764cf2ecd7c1b4c0e8beebe84a1f20744c;hb=bb41be0;hp=dbc3835d6bbd8e5e7362426c900c81d736771278;hpb=e34910f85f459f049b9e6e6b79db9ef95dfccc13;p=Lucu.git diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index dbc3835..d952917 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,162 +1,135 @@ {-# LANGUAGE - BangPatterns - , OverloadedStrings - , UnboxedTuples + OverloadedStrings + , RecordWildCards + , ScopedTypeVariables + , TypeOperators , UnicodeSyntax #-} module Network.HTTP.Lucu.DefaultPage - ( getDefaultPage - , writeDefaultPage - , mkDefaultPage + ( defaultPageContentType + , defaultPageForResponse + , defaultPageWithMessage ) where -import Control.Arrow -import Control.Arrow.ArrowList -import Control.Arrow.ListArrow -import Control.Arrow.Unicode -import Control.Concurrent.STM -import Control.Monad +import Blaze.ByteString.Builder (Builder) +import Data.Ascii (Ascii) import qualified Data.Ascii as A +import qualified Data.CaseInsensitive as CI +import Data.Convertible.Utils import Data.Maybe -import qualified Data.Sequence as S +import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding 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 Prelude hiding (head) import Prelude.Unicode -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState -import Text.XML.HXT.DOM.TypeDefs - -getDefaultPage â· Config â Maybe Request â Response â Text -{-# INLINEABLE getDefaultPage #-} -getDefaultPage !conf !req !res - = let msgA = getMsg req res - [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA - â - writeDocumentToString [ withIndent True ] - ) () - in - T.pack 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 - - 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 -{-# INLINEABLE mkDefaultPage #-} -mkDefaultPage !conf !status !msgA - = let sStr = A.toString $ 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 sStr - )) - += ( eelem "body" - += ( eelem "h1" - += txt sStr - ) - += ( eelem "p" += msgA ) - += eelem "hr" - += ( eelem "address" += txt sig )))) - -getMsg â· (ArrowXml a) â Maybe Request â Response â a 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 - +import Text.Blaze +import Text.Blaze.Html5 hiding (hr) +import Text.Blaze.Html5.Attributes hiding (title) +import Text.Blaze.Renderer.Utf8 + +defaultPageContentType â· Ascii +{-# INLINE defaultPageContentType #-} +defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\"" + +defaultPageForResponse â· Config â Maybe Request â Response â Builder +{-# INLINEABLE defaultPageForResponse #-} +defaultPageForResponse conf req res + = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res + +defaultPageWithMessage â· âsc. StatusCode sc â Config â sc â Html â Builder +{-# INLINEABLE defaultPageWithMessage #-} +defaultPageWithMessage (Config {..}) sc msg + = renderHtmlBuilder $ + do unsafeByteString "" + docType + html ! xmlns "http://www.w3.org/1999/xhtml" $ + do let status = toHtml $ scText sc + head $ title status + body $ do h1 status + p msg + hr + address $ do toHtml $ A.toText cnfServerSoftware + unsafeByteString " at " + toHtml $ CI.original cnfServerHost where - path â· String - path = let uri = reqURI $ fromJust req - in - uriPath uri + scText â· sc â Text + scText = convertSuccessVia ((â¥) â· Ascii) â fromStatusCode + +defaultMessage â· Maybe Request â Response â Html +{-# INLINEABLE defaultMessage #-} +defaultMessage req res@(Response {..}) + -- 1xx responses don't have a body. + -- 2xx responses don't need a body to be completed. + -- 3xx: + | resStatus â MovedPermanently + = do unsafeByteString "The resource at " + path + unsafeByteString " has been moved to " + a ! href (toValue loc) $ toHtml loc + unsafeByteString " permanently." + + | resStatus â Found + = do unsafeByteString "The resource at " + path + unsafeByteString " is currently located at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString ". This is not a permanent relocation." + + | resStatus â SeeOther + = do unsafeByteString "The resource at " + path + unsafeByteString " can be found at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." + + | resStatus â TemporaryRedirect + = do unsafeByteString "The resource at " + path + unsafeByteString " is temporarily located at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." + + -- 4xx: + | resStatus â BadRequest + = unsafeByteString "The server could not understand the request you sent." + | resStatus â Unauthorized + = unsafeByteString "You need a valid authentication to access " â path + | resStatus â Forbidden + = unsafeByteString "You don't have permission to access " â path + | resStatus â NotFound + = do unsafeByteString "The requested URL " + path + unsafeByteString " was not found on this server." + | resStatus â Gone + = do unsafeByteString "The resource at " + path + unsafeByteString " was here in past times, but has gone permanently." + | resStatus â RequestEntityTooLarge + = do unsafeByteString "The request entity you sent for " + path + unsafeByteString " was too large to accept." + | resStatus â RequestURITooLarge + = unsafeByteString "The request URI you sent was too large to accept." + + -- 5xx: + | resStatus â InternalServerError + = unsafeByteString "An internal server error has occured during the process of your request to " â path + | resStatus â ServiceUnavailable + = unsafeByteString "The service is temporarily unavailable. Try later." + + | otherwise + = (â ) + where + path â· Html + path = toHtml â uriPath â reqURI $ fromJust req + + loc â· Text + loc = A.toText â fromJust $ getHeader "Location" res - loc â· String - loc = A.toString $ fromJust $ getHeader "Location" res +hr â· Html +{-# INLINE hr #-} +hr = unsafeByteString "