From c060bff37e29f06e105c0ec2b1f844f55b48906c Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 2 Dec 2011 02:02:39 +0900 Subject: [PATCH] Use blaze-html instead of HXT. Ditz-issue: ce71be0bc848dbefccc5cea88e5c9339083d97ee --- Lucu.cabal | 2 +- Network/HTTP/Lucu/Abortion/Internal.hs | 19 +- Network/HTTP/Lucu/DefaultPage.hs | 170 ++++++++---------- Network/HTTP/Lucu/Interaction.hs | 6 +- Network/HTTP/Lucu/Postprocess.hs | 2 +- ...1be0bc848dbefccc5cea88e5c9339083d97ee.yaml | 12 +- examples/Multipart.hs | 35 ++-- 7 files changed, 120 insertions(+), 126 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 7773f80..a35fb08 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -56,6 +56,7 @@ Library base-unicode-symbols == 0.2.*, base64-bytestring == 0.1.*, blaze-builder == 0.3.*, + blaze-html == 0.4.*, bytestring == 0.9.*, case-insensitive == 0.4.*, collections-api == 1.0.*, @@ -63,7 +64,6 @@ Library containers == 0.4.*, directory == 1.1.*, filepath == 1.2.*, - hxt == 9.1.*, mtl == 2.0.*, network == 2.3.*, old-time == 1.0.*, diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs index 69d7a9e..a1ff54c 100644 --- a/Network/HTTP/Lucu/Abortion/Internal.hs +++ b/Network/HTTP/Lucu/Abortion/Internal.hs @@ -8,22 +8,16 @@ module Network.HTTP.Lucu.Abortion.Internal ) where import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder.Char.Utf8 as BB -import Control.Arrow.ListArrow -import Control.Arrow.Unicode import Control.Exception +import Text.Blaze import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T import Data.Typeable import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState -- |'Abortion' is an 'Exception' that aborts the execution of -- 'Network.HTTP.Lucu.Rsrc' monad with a 'StatusCode', additional @@ -59,19 +53,14 @@ instance HasHeaders Abortion where setHeaders abo hdr = abo { aboHeaders = hdr } abortPage ∷ Config → Maybe Request → Response → Abortion → Builder -abortPage conf reqM res abo +abortPage conf req res abo = case aboMessage abo of Just msg - → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) - ⋙ - writeDocumentToString [ withIndent True ] - ) () - in - BB.fromString html + → defaultPageWithMessage conf (aboStatus abo) $ toHtml msg Nothing → let res' = res { resStatus = aboStatus abo , resHeaders = resHeaders res ⊕ aboHeaders abo } in - getDefaultPage conf reqM res' + defaultPageForResponse conf req res' diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 0fefa7f..e106774 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -5,140 +5,126 @@ , 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.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 ∘ CI.original $ 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 ∷ 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 ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc + head $ title status + body $ do h1 status + p msg + hr + address $ do toHtml $ A.toText cnfServerSoftware + unsafeByteString " at " + toHtml $ CI.original cnfServerHost -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: | resStatus ≈ MovedPermanently - = txt ("The resource at " ⧺ path ⧺ " has been moved to ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt " permanently." + = do unsafeByteString "The resource at " + path + unsafeByteString " has been moved to " + a ! href (toValue loc) $ toHtml loc + unsafeByteString " 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." + = 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 - = txt ("The resource at " ⧺ path ⧺ " can be found at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt "." + = do unsafeByteString "The resource at " + path + unsafeByteString " can be found at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." | resStatus ≈ TemporaryRedirect - = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") - <+> - eelem "a" += sattr "href" loc - += txt loc - <+> - txt "." + = do unsafeByteString "The resource at " + path + unsafeByteString " is temporarily located at " + a ! href (toValue loc) $ toHtml loc + unsafeByteString "." -- 4xx: | resStatus ≈ BadRequest - = txt "The server could not understand the request you sent." + = unsafeByteString "The server could not understand the request you sent." | resStatus ≈ Unauthorized - = txt ("You need a valid authentication to access " ⧺ path) + = unsafeByteString "You need a valid authentication to access " ⊕ path | resStatus ≈ Forbidden - = txt ("You don't have permission to access " ⧺ path) + = unsafeByteString "You don't have permission to access " ⊕ path | resStatus ≈ NotFound - = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.") + = do unsafeByteString "The requested URL " + path + unsafeByteString " was not found on this server." | resStatus ≈ Gone - = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.") + = do unsafeByteString "The resource at " + path + unsafeByteString " was here in past times, but has gone permanently." | resStatus ≈ RequestEntityTooLarge - = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.") + = do unsafeByteString "The request entity you sent for " + path + unsafeByteString " was too large to accept." | resStatus ≈ RequestURITooLarge - = txt "The request URI you sent was too large to accept." + = unsafeByteString "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) + = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path | resStatus ≈ ServiceUnavailable - = txt "The service is temporarily unavailable. Try later." + = 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 = A.toText ∘ fromJust $ getHeader "Location" res - loc ∷ String - loc = A.toString ∘ fromJust $ getHeader "Location" res +hr ∷ Html +{-# INLINE hr #-} +hr = unsafeByteString "
" diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index f5ccd83..41c74a3 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -85,13 +85,13 @@ instance Interaction SyntacticallyInvalidInteraction mkSyntacticallyInvalidInteraction ∷ Config → IO SyntacticallyInvalidInteraction -mkSyntacticallyInvalidInteraction config@(Config {..}) +mkSyntacticallyInvalidInteraction conf@(Config {..}) = do date ← getCurrentDate let res = setHeader "Server" cnfServerSoftware $ setHeader "Date" date $ setHeader "Content-Type" defaultPageContentType $ emptyResponse BadRequest - body = getDefaultPage config Nothing res + body = defaultPageForResponse conf Nothing res return SYI { syiResponse = res , syiBodyToSend = body @@ -132,7 +132,7 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..}) else id ) $ emptyResponse arInitialStatus - body = getDefaultPage config (Just arRequest) res + body = defaultPageForResponse config (Just arRequest) res return SEI { seiRequest = arRequest , seiExpectedContinue = arExpectedContinue diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 09665c6..a835975 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -108,7 +108,7 @@ writeDefaultPageIfNeeded ni@(NI {..}) $ do writeHeader ni "Content-Type" $ Just defaultPageContentType writeHeader ni "Content-Encoding" Nothing res ← readTVar niResponse - let body = getDefaultPage niConfig (Just niRequest) res + let body = defaultPageForResponse niConfig (Just niRequest) res putTMVar niBodyToSend body completeUnconditionalHeaders ∷ NormalInteraction → STM () diff --git a/bugs/issue-ce71be0bc848dbefccc5cea88e5c9339083d97ee.yaml b/bugs/issue-ce71be0bc848dbefccc5cea88e5c9339083d97ee.yaml index 87e8382..a66d34d 100644 --- a/bugs/issue-ce71be0bc848dbefccc5cea88e5c9339083d97ee.yaml +++ b/bugs/issue-ce71be0bc848dbefccc5cea88e5c9339083d97ee.yaml @@ -5,8 +5,8 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted -disposition: +status: :closed +disposition: :fixed creation_time: 2011-11-29 12:14:42.124430 Z references: [] @@ -16,4 +16,12 @@ log_events: - PHO - created - "" +- - 2011-11-30 22:48:40.766070 Z + - PHO + - changed status from unstarted to in_progress + - "" +- - 2011-12-01 17:02:20.471027 Z + - PHO + - closed with disposition fixed + - Done. git_branch: diff --git a/examples/Multipart.hs b/examples/Multipart.hs index 906eff5..ab857a8 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings + , QuasiQuotes , UnicodeSyntax #-} import qualified Data.ByteString.Lazy.Char8 as Lazy @@ -10,7 +11,12 @@ import Data.Maybe import Data.Monoid.Unicode import Network import Network.HTTP.Lucu +import Prelude hiding (head) import Prelude.Unicode +import Text.Blaze hiding (text) +import Text.Blaze.Html5 hiding (text) +import Text.Blaze.Html5.Attributes hiding (form, title) +import Text.Blaze.Renderer.Utf8 main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } @@ -23,20 +29,25 @@ main = let config = defaultConfig { cnfServerPort = "9999" } resMain ∷ Resource resMain = C.fromList [ ( GET - , do setContentType $ parseMIMEType "text/html" - putChunks $ "Multipart Form Test\n" - ⊕ "
\n" - ⊕ " Upload some file:\n" - ⊕ " \n" - ⊕ " \n" - ⊕ " \n" - ⊕ "
\n" + , do setContentType [mimeType| text/html; charset="UTF-8" |] + putBuilder + $ renderHtmlBuilder + $ docTypeHtml ! lang "en" + $ do head $ do meta ! charset "UTF-8" + title "Multipart Form Test" + body $ form ! action "/" + ! method "post" + ! enctype "multipart/form-data" + $ do toHtml ("Upload some file:" ∷ String) + input ! type_ "text" ! name "text" + input ! type_ "file" ! name "file" + input ! type_ "submit" ! value "Submit" ) , ( POST - , do form ← getForm Nothing - let text = fromMaybe (∅) $ fdContent <$> lookup "text" form - file = fromMaybe (∅) $ fdContent <$> lookup "file" form - fileName = fdFileName =≪ lookup "file" form + , do f ← getForm Nothing + let text = fromMaybe (∅) $ fdContent <$> lookup "text" f + file = fromMaybe (∅) $ fdContent <$> lookup "file" f + fileName = fdFileName =≪ lookup "file" f setContentType $ parseMIMEType "text/plain" putChunks $ "You entered \"" ⊕ text ⊕ "\".\n" putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n" -- 2.40.0