X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=c5ae6f5c5d485ea8dbe4ca6046e70cbd7258ce47;hp=8fcc37d74800cfd1a75eeeddc056d73576ab666d;hb=6680828c79aff38431704075c339e043b577589e;hpb=51eda5b02d4528e2e240cbfc228de02b1c83799a diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 8fcc37d..c5ae6f5 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,143 +1,135 @@ {-# LANGUAGE OverloadedStrings , RecordWildCards + , ScopedTypeVariables , TypeOperators , UnicodeSyntax #-} module Network.HTTP.Lucu.DefaultPage - ( getDefaultPage - , defaultPageContentType - , mkDefaultPage + ( defaultPageContentType + , defaultPageForResponse + , defaultPageWithMessage ) 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 Data.Ascii (Ascii) -import qualified Data.Ascii as A +import qualified Data.CaseInsensitive as CI +import Data.Convertible.Base +import Data.Convertible.Utils import Data.Maybe -import qualified Data.Text as T +import Data.Monoid.Unicode +import Data.Text (Text) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Headers 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 → Builder -{-# INLINEABLE getDefaultPage #-} -getDefaultPage conf req res - = let msgA = getMsg req res - [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA - ⋙ - writeDocumentToString [ withIndent True ] - ) () - in - BB.fromString xmlStr +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" +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 -mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc) - ⇒ Config - → sc - → b ⇝ XmlTree - → b ⇝ XmlTree -{-# INLINEABLE mkDefaultPage #-} -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 sStr - )) - += ( eelem "body" - += ( eelem "h1" - += txt sStr - ) - += ( eelem "p" += msgA ) - += eelem "hr" - += ( eelem "address" += txt sig )))) +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 (cs cnfServerSoftware ∷ Text) + unsafeByteString " at " + toHtml $ CI.original cnfServerHost + where + scText ∷ sc → Text + scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode -getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree -{-# INLINEABLE getMsg #-} -getMsg req res@(Response {..}) +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: - | toStatusCode resStatus ≡ Just MovedPermanently - = txt ("The resource at " ⧺ path ⧺ " has been moved to ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt " permanently." + | resStatus ≈ MovedPermanently + = do unsafeByteString "The resource at " + path + unsafeByteString " has been moved to " + a ! href (toValue loc) $ toHtml loc + unsafeByteString " 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." + | 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." - | toStatusCode resStatus ≡ Just SeeOther - = txt ("The resource at " ⧺ path ⧺ " can be found at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt "." + | resStatus ≈ SeeOther + = do unsafeByteString "The resource at " + path + unsafeByteString " can be found at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." - | toStatusCode resStatus ≡ Just TemporaryRedirect - = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt "." + | resStatus ≈ TemporaryRedirect + = do unsafeByteString "The resource at " + path + unsafeByteString " is temporarily located at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." -- 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." + | 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: - | 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." + | 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 - = none + = (∅) where - path ∷ String - path = uriPath $ reqURI $ fromJust req + path ∷ Html + path = toHtml ∘ uriPath ∘ reqURI $ fromJust req + + loc ∷ Text + loc = cs ∘ fromJust $ getHeader "Location" res - loc ∷ String - loc = A.toString $ fromJust $ getHeader "Location" res +hr ∷ Html +{-# INLINE hr #-} +hr = unsafeByteString "
"