From c060bff37e29f06e105c0ec2b1f844f55b48906c Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ 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 "<hr/>"
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 <pho@cielonegro.org>
-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 <pho@cielonegro.org>
- created
- ""
+- - 2011-11-30 22:48:40.766070 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+- - 2011-12-01 17:02:20.471027 Z
+ - PHO <pho@cielonegro.org>
+ - 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 $ "<title>Multipart Form Test</title>\n"
- â "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">\n"
- â " Upload some file:\n"
- â " <input type=\"text\" name=\"text\">\n"
- â " <input type=\"file\" name=\"file\">\n"
- â " <input type=\"submit\" value=\"Submit\">\n"
- â "</form>\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