)
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
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'
, 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/>"
{-# LANGUAGE
OverloadedStrings
+ , QuasiQuotes
, UnicodeSyntax
#-}
import qualified Data.ByteString.Lazy.Char8 as Lazy
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" }
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"
projects / Lucu.git / commitdiff