From 2ba762c77d16ad5c880144cde8d9760076e9d854 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Thu, 17 Oct 2024 00:33:04 +0200 Subject: [PATCH] Move everything from xhtml to blaze & HTML5 This is a rather mechanical translation from the old `xhtml` library to the more modern `blaze` library. We use HTML5 everywhere, thus we also change the `DOCTYPE`. Pandoc needs to be configured to return HTML5 as well, but it looks like every use of the html writer already uses `writeHtml5String`. So I guess we are good? --- README.markdown | 2 +- data/markup.HTML | 2 +- data/markupHelp/HTML | 2 +- data/templates/page.st | 5 +- src/Network/Gitit/Authentication.hs | 210 ++++++++------ src/Network/Gitit/ContentTransformer.hs | 112 ++++---- src/Network/Gitit/Handlers.hs | 362 +++++++++++++----------- src/Network/Gitit/Layout.hs | 52 ++-- src/Network/Gitit/Types.hs | 2 +- 9 files changed, 405 insertions(+), 344 deletions(-) diff --git a/README.markdown b/README.markdown index d49e0cc06..2515e45ca 100644 --- a/README.markdown +++ b/README.markdown @@ -567,7 +567,7 @@ Now add the following lines to the apache configuration file for the SetOutputFilter proxy-html ProxyPassReverse / ProxyHTMLURLMap / /wiki/ - ProxyHTMLDocType "" XHTML + ProxyHTMLDocType html5 RequestHeader unset Accept-Encoding diff --git a/data/markup.HTML b/data/markup.HTML index f07e606cd..87eff0b17 100644 --- a/data/markup.HTML +++ b/data/markup.HTML @@ -1,6 +1,6 @@ # Markup -The syntax for wiki pages is standard XHTML. All tags must be +The syntax for wiki pages is standard HTML 5. All tags must be properly closed. ## Wiki links diff --git a/data/markupHelp/HTML b/data/markupHelp/HTML index 1bedefbf0..436539063 100644 --- a/data/markupHelp/HTML +++ b/data/markupHelp/HTML @@ -45,6 +45,6 @@ external, ~~~~~~~~ -For more: [xhtml tutorial](http://www.w3schools.com/Xhtml/), +For more: [HTML tutorial](https://developer.mozilla.org/en-US/docs/Learn/HTML), [pandoc](http://pandoc.org/README.html). diff --git a/data/templates/page.st b/data/templates/page.st index 3bb382ac9..6670fbb95 100644 --- a/data/templates/page.st +++ b/data/templates/page.st @@ -1,6 +1,5 @@ - - + + diff --git a/src/Network/Gitit/Authentication.hs b/src/Network/Gitit/Authentication.hs index 87d78c8ba..98aaf1846 100644 --- a/src/Network/Gitit/Authentication.hs +++ b/src/Network/Gitit/Authentication.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane , Henry Laxen @@ -35,8 +36,6 @@ import Network.Gitit.Server import Network.Gitit.Util import Network.Gitit.Authentication.Github import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) -import Text.XHtml hiding ( (), dir, method, password, rev ) -import qualified Text.XHtml as X ( password ) import System.Process (readProcessWithExitCode) import Control.Monad (unless, liftM, mplus) import Control.Monad.Trans (liftIO) @@ -53,6 +52,13 @@ import Network.HTTP (urlEncodeVars, urlDecode, urlEncode) import Codec.Binary.UTF8.String (encodeString) import Data.ByteString.UTF8 (toString) import Network.Gitit.Rpxnow as R +import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml ) +import Text.Blaze.Html5 hiding (i, search, u, s, contents, source, html, title, map) +import qualified Text.Blaze.Html5 as Html5 hiding (search) +import qualified Text.Blaze.Html5.Attributes as Html5.Attr hiding (dir, span) +import Text.Blaze.Html5.Attributes +import Data.String (IsString(fromString)) +import qualified Text.XHtml as XHTML -- | Replace each occurrence of one sublist in a list with another. -- Vendored in from pandoc 2.11.4 as 2.12 removed this function. @@ -86,15 +92,33 @@ registerUser params = do pPassword = pword, pEmail = email } + +gui :: AttributeValue -> Html -> Html +gui act = Html5.form ! Html5.Attr.action act ! Html5.Attr.method "post" + + +textfieldInput :: AttributeValue -> AttributeValue -> Html +textfieldInput nameAndId val = input ! type_ "text" ! Html5.Attr.id nameAndId ! name nameAndId ! value val +textfieldInput' :: AttributeValue -> Html +textfieldInput' nameAndId = input ! type_ "text" ! Html5.Attr.id nameAndId ! name nameAndId +passwordInput :: AttributeValue -> Html +passwordInput nameAndId = input ! type_ "password" ! Html5.Attr.id nameAndId ! name nameAndId +submitInput :: AttributeValue -> AttributeValue -> Html +submitInput nameAndId val = input ! type_ "submit" ! Html5.Attr.id nameAndId ! name nameAndId ! value val + +intTabindex :: Int -> Attribute +intTabindex i = Html5.Attr.tabindex (fromString $ show i) + resetPasswordRequestForm :: Params -> Handler resetPasswordRequestForm _ = do - let passwordForm = gui "" ! [identifier "resetPassword"] << fieldset << - [ label ! [thefor "username"] << "Username: " - , textfield "username" ! [size "20", intAttr "tabindex" 1], stringToHtml " " - , submit "resetPassword" "Reset Password" ! [intAttr "tabindex" 2]] + let passwordForm = gui "" ! Html5.Attr.id "resetPassword" $ fieldset $ mconcat + [ Html5.label ! Html5.Attr.for "username" $ "Username: " + , textfieldInput' "username" ! size "20" ! intTabindex 1 + , " " + , submitInput "resetPassword" "Reset Password" ! intTabindex 2] cfg <- getConfig let contents = if null (mailCommand cfg) - then p << "Sorry, password reset not available." + then p $ "Sorry, password reset not available." else passwordForm formattedPage defaultPageLayout{ pgShowPageTools = False, @@ -115,11 +139,11 @@ resetPasswordRequest params = do if null errors then do let response = - p << [ stringToHtml "An email has been sent to " - , bold $ stringToHtml . uEmail $ fromJust mbUser + p $ mconcat + [ "An email has been sent to " + , strong $ fromString . uEmail $ fromJust mbUser , br - , stringToHtml - "Please click on the enclosed link to reset your password." + , "Please click on the enclosed link to reset your password." ] sendReregisterEmail (fromJust mbUser) formattedPage defaultPageLayout{ @@ -175,7 +199,7 @@ validateReset params postValidate = do (True, True) -> [] (True, False) -> ["Your reset code is invalid"] (False, _) -> ["User " ++ - renderHtmlFragment (stringToHtml uname) ++ + renderHtml (fromString uname) ++ " is not known"] if null errors then postValidate (fromJust user) @@ -230,54 +254,61 @@ sharedForm mbUser = withData $ \params -> do "" -> getReferer x -> return x let accessQ = case mbUser of - Just _ -> noHtml + Just _ -> mempty Nothing -> case accessQuestion cfg of - Nothing -> noHtml - Just (prompt, _) -> label ! [thefor "accessCode"] << prompt +++ br +++ - X.password "accessCode" ! [size "15", intAttr "tabindex" 1] - +++ br + Nothing -> mempty + Just (prompt, _) -> mconcat + [ Html5.label ! Html5.Attr.for "accessCode" $ fromString prompt + , br + , passwordInput "accessCode" ! size "15" ! intTabindex 1 + , br + ] let captcha = if useRecaptcha cfg then captchaFields (recaptchaPublicKey cfg) Nothing - else noHtml + else mempty let initField field = case mbUser of Nothing -> "" Just user -> field user let userNameField = case mbUser of - Nothing -> label ! [thefor "username"] << - "Username (at least 3 letters or digits):" - +++ br +++ - textfield "username" ! [size "20", intAttr "tabindex" 2] +++ br - Just user -> label ! [thefor "username"] << - ("Username (cannot be changed): " ++ uUsername user) - +++ br + Nothing -> mconcat + [ Html5.label ! Html5.Attr.for "username" $ "Username (at least 3 letters or digits):" + , br + , textfieldInput' "username" ! size "20" ! intTabindex 2 + , br + ] + Just user -> Html5.label ! Html5.Attr.for "username" $ + (fromString $ "Username (cannot be changed): " ++ uUsername user) + <> br let submitField = case mbUser of - Nothing -> submit "register" "Register" - Just _ -> submit "resetPassword" "Reset Password" + Nothing -> submitInput "register" "Register" + Just _ -> submitInput "resetPassword" "Reset Password" - return $ gui "" ! [identifier "loginForm"] << fieldset << + return $ gui "" ! Html5.Attr.id "loginForm" $ fieldset $ mconcat [ accessQ , userNameField - , label ! [thefor "email"] << "Email (optional, will not be displayed on the Wiki):" + , Html5.label ! Html5.Attr.for "email" $ "Email (optional, will not be displayed on the Wiki):" , br - , textfield "email" ! [size "20", intAttr "tabindex" 3, value (initField uEmail)] - , br ! [theclass "req"] - , textfield "full_name_1" ! [size "20", theclass "req"] + , textfieldInput "email" (fromString $ initField uEmail) ! size "20" ! intTabindex 3 + , br ! class_ "req" + , textfieldInput' "full_name_1" ! size "20" ! class_ "req" , br - , label ! [thefor "password"] - << ("Password (at least 6 characters," ++ + , Html5.label ! Html5.Attr.for "password" + $ fromString ("Password (at least 6 characters," ++ " including at least one non-letter):") , br - , X.password "password" ! [size "20", intAttr "tabindex" 4] - , stringToHtml " " + , passwordInput "password" ! size "20" ! intTabindex 4 + , " " , br - , label ! [thefor "password2"] << "Confirm Password:" + , Html5.label ! Html5.Attr.for "password2" $ "Confirm Password:" , br - , X.password "password2" ! [size "20", intAttr "tabindex" 5] - , stringToHtml " " + , passwordInput "password2" ! size "20" ! intTabindex 5 + , " " , br - , captcha - , textfield "destination" ! [thestyle "display: none;", value dest] - , submitField ! [intAttr "tabindex" 6]] + -- Workaround, as ReCaptcha does not work with BlazeHtml + , preEscapedToHtml (XHTML.renderHtmlFragment captcha) + , textfieldInput "destination" (fromString dest) ! Html5.Attr.style "display: none;" + , submitField ! intTabindex 6 + ] sharedValidation :: ValidationType @@ -349,27 +380,29 @@ loginForm :: String -> GititServerPart Html loginForm dest = do cfg <- getConfig base' <- getWikiBase - return $ gui (base' ++ "/_login") ! [identifier "loginForm"] << - fieldset << - [ label ! [thefor "username"] << "Username " - , textfield "username" ! [size "15", intAttr "tabindex" 1] - , stringToHtml " " - , label ! [thefor "password"] << "Password " - , X.password "password" ! [size "15", intAttr "tabindex" 2] - , stringToHtml " " - , textfield "destination" ! [thestyle "display: none;", value dest] - , submit "login" "Login" ! [intAttr "tabindex" 3] - ] +++ + return $ gui (fromString $ base' ++ "/_login") ! Html5.Attr.id "loginForm" $ + (fieldset $ mconcat + [ Html5.label ! Html5.Attr.for "username" $ "Username " + , textfieldInput' "username" ! size "15" ! intTabindex 1 + , " " + , Html5.label ! Html5.Attr.for "password" $ "Password " + , passwordInput "password" ! size "15" ! intTabindex 2 + , " " + , textfieldInput "destination" (fromString dest) ! Html5.Attr.style "display: none;" + , submitInput "login" "Login" ! intTabindex 3 + ]) <> (if disableRegistration cfg - then noHtml - else p << [ stringToHtml "If you do not have an account, " - , anchor ! [href $ base' ++ "/_register?" ++ - urlEncodeVars [("destination", encodeString dest)]] << "click here to get one." - ]) +++ + then mempty + else p $ mconcat + [ "If you do not have an account, " + , a ! href (fromString $ base' ++ "/_register?" ++ + urlEncodeVars [("destination", encodeString dest)]) $ "click here to get one." + ]) <> (if null (mailCommand cfg) - then noHtml - else p << [ stringToHtml "If you forgot your password, " - , anchor ! [href $ base' ++ "/_resetPassword"] << + then mempty + else p $ mconcat + [ "If you forgot your password, " + , a ! href (fromString $ base' ++ "/_resetPassword") $ "click here to get a new one." ]) @@ -396,8 +429,7 @@ loginUser params = do then do key <- newSession (sessionData uname) addCookie (MaxAge $ sessionTimeout cfg) (mkSessionCookie key) - seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++ - renderHtmlFragment (stringToHtml uname)) + seeOther (encUrl destination) $ toResponse $ p $ (fromString $ "Welcome, " ++ uname) else withMessages ["Invalid username or password."] loginUserForm @@ -412,7 +444,7 @@ logoutUser params = do delSession k expireCookie "sid" Nothing -> return () - seeOther (encUrl dest) $ toResponse "You have been logged out." + seeOther (encUrl dest) $ toResponse ("You have been logged out." :: String) registerUserForm :: Handler registerUserForm = registerForm >>= @@ -424,8 +456,8 @@ registerUserForm = registerForm >>= regAuthHandlers :: [Handler] regAuthHandlers = - [ dir "_register" $ method GET >> registerUserForm - , dir "_register" $ method POST >> withData registerUser + [ Network.Gitit.Server.dir "_register" $ Network.Gitit.Server.method GET >> registerUserForm + , Network.Gitit.Server.dir "_register" $ Network.Gitit.Server.method POST >> withData registerUser ] formAuthHandlers :: Bool -> [Handler] @@ -433,14 +465,14 @@ formAuthHandlers disableReg = (if disableReg then [] else regAuthHandlers) ++ - [ dir "_login" $ method GET >> loginUserForm - , dir "_login" $ method POST >> withData loginUser - , dir "_logout" $ method GET >> withData logoutUser - , dir "_resetPassword" $ method GET >> withData resetPasswordRequestForm - , dir "_resetPassword" $ method POST >> withData resetPasswordRequest - , dir "_doResetPassword" $ method GET >> withData resetPassword - , dir "_doResetPassword" $ method POST >> withData doResetPassword - , dir "_user" currentUser + [ Network.Gitit.Server.dir "_login" $ Network.Gitit.Server.method GET >> loginUserForm + , Network.Gitit.Server.dir "_login" $ Network.Gitit.Server.method POST >> withData loginUser + , Network.Gitit.Server.dir "_logout" $ Network.Gitit.Server.method GET >> withData logoutUser + , Network.Gitit.Server.dir "_resetPassword" $ Network.Gitit.Server.method GET >> withData resetPasswordRequestForm + , Network.Gitit.Server.dir "_resetPassword" $ Network.Gitit.Server.method POST >> withData resetPasswordRequest + , Network.Gitit.Server.dir "_doResetPassword" $ Network.Gitit.Server.method GET >> withData resetPassword + , Network.Gitit.Server.dir "_doResetPassword" $ Network.Gitit.Server.method POST >> withData doResetPassword + , Network.Gitit.Server.dir "_user" currentUser ] loginUserHTTP :: Params -> Handler @@ -454,9 +486,9 @@ logoutUserHTTP = unauthorized $ toResponse () -- will this work? httpAuthHandlers :: [Handler] httpAuthHandlers = - [ dir "_logout" logoutUserHTTP - , dir "_login" $ withData loginUserHTTP - , dir "_user" currentUser ] + [ Network.Gitit.Server.dir "_logout" logoutUserHTTP + , Network.Gitit.Server.dir "_login" $ withData loginUserHTTP + , Network.Gitit.Server.dir "_user" currentUser ] oauthGithubCallback :: GithubConfig -> GithubCallbackPars -- ^ Authentication code gained after authorization @@ -492,15 +524,15 @@ oauthGithubCallback ghConfig githubCallbackPars = githubAuthHandlers :: GithubConfig -> [Handler] githubAuthHandlers ghConfig = - [ dir "_logout" $ withData logoutUser - , dir "_login" $ withData $ loginGithubUser $ oAuth2 ghConfig - , dir "_loginFailure" $ githubLoginFailure - , dir "_githubCallback" $ withData $ oauthGithubCallback ghConfig - , dir "_user" currentUser ] + [ Network.Gitit.Server.dir "_logout" $ withData logoutUser + , Network.Gitit.Server.dir "_login" $ withData $ loginGithubUser $ oAuth2 ghConfig + , Network.Gitit.Server.dir "_loginFailure" $ githubLoginFailure + , Network.Gitit.Server.dir "_githubCallback" $ withData $ oauthGithubCallback ghConfig + , Network.Gitit.Server.dir "_user" currentUser ] githubLoginFailure :: Handler githubLoginFailure = withData $ \params -> - formattedPage (pageLayout (pMessages params)) noHtml >>= forbidden + formattedPage (pageLayout (pMessages params)) mempty >>= forbidden where pageLayout msgs = defaultPageLayout{ pgShowPageTools = False, @@ -534,8 +566,8 @@ loginRPXUser params = do Right u -> return u Left err -> error err liftIO $ logM "gitit.loginRPXUser" DEBUG $ "uid:" ++ show uid - -- We need to get an unique identifier for the user - -- The 'identifier' is always present but can be rather cryptic + -- We need to get an unique Html5.Attr.id for the user + -- The 'Html5.Attr.id' is always present but can be rather cryptic -- The 'verifiedEmail' is also unique and is a more readable choice -- so we use it if present. let userId = R.userIdentifier uid @@ -547,7 +579,7 @@ loginRPXUser params = do see $ fromJust $ rDestination params where prop pname info = lookup pname $ R.userData info - see url = seeOther (encUrl url) $ toResponse noHtml + see url = seeOther (encUrl url) $ toResponse (renderHtml mempty) -- The parameters passed by the RPX callback call. data RPars = RPars { rToken :: Maybe String @@ -564,9 +596,9 @@ instance FromData RPars where rpxAuthHandlers :: [Handler] rpxAuthHandlers = - [ dir "_logout" $ method GET >> withData logoutUser - , dir "_login" $ withData loginRPXUser - , dir "_user" currentUser ] + [ Network.Gitit.Server.dir "_logout" $ Network.Gitit.Server.method GET >> withData logoutUser + , Network.Gitit.Server.dir "_login" $ withData loginRPXUser + , Network.Gitit.Server.dir "_user" currentUser ] -- | Returns username of logged in user or null string if nobody logged in. currentUser :: Handler diff --git a/src/Network/Gitit/ContentTransformer.hs b/src/Network/Gitit/ContentTransformer.hs index 231f42f8e..1ffe63319 100644 --- a/src/Network/Gitit/ContentTransformer.hs +++ b/src/Network/Gitit/ContentTransformer.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {- Copyright (C) 2009 John MacFarlane , Anton van Straaten @@ -76,7 +77,6 @@ import Control.Monad.Except (throwError) import Data.Foldable (traverse_) import Data.List (stripPrefix) import Data.Maybe (isNothing, mapMaybe) -import Data.Semigroup ((<>)) import Network.Gitit.Cache (lookupCache, cacheContents) import Network.Gitit.Framework hiding (uriPath) import Network.Gitit.Layout @@ -93,9 +93,6 @@ import qualified Text.Pandoc.Builder as B import Text.HTML.SanitizeXSS (sanitizeBalance) import Skylighting hiding (Context) import Text.Pandoc hiding (MathML, WebTeX, MathJax) -import Text.XHtml hiding ( (), dir, method, password, rev ) -import Text.XHtml.Strict (stringToHtmlString) -import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml ) import URI.ByteString (Query(Query), URIRef(uriPath), laxURIParserOptions, parseURI, uriQuery) import qualified Data.Text as T @@ -104,6 +101,12 @@ import qualified Data.ByteString.Char8 as SC (pack, unpack) import qualified Data.ByteString.Lazy as L (toChunks, fromChunks) import qualified Data.FileStore as FS import qualified Text.Pandoc as Pandoc +import Data.String (IsString(fromString)) +import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml ) +import Text.Blaze.Html5 hiding (u, s, contents, source, html, title, map) +import Text.Blaze.Html5.Attributes hiding (id) +import qualified Text.Blaze.Html5 as Html5 +import qualified Text.Blaze.Html5.Attributes as Html5.Attr -- -- ContentTransformer runners @@ -195,7 +198,7 @@ preview = runPageTransformer $ contentsToPage >>= pageToWikiPandoc >>= pandocToHtml >>= - return . toResponse . renderHtmlFragment + return . toResponse . renderHtml -- | Applies pre-commit plugins to raw page source, possibly -- modifying it. @@ -332,6 +335,8 @@ pageToPandoc page' = do , ctxMeta = pageMeta page' } either (liftIO . E.throwIO) return $ readerFor (pageFormat page') (pageLHS page') (pageText page') +data WasRedirect = WasRedirect | WasNoRedirect + -- | Detects if the page is a redirect page and handles accordingly. The exact -- behaviour is as follows: -- @@ -374,56 +379,51 @@ handleRedirects page = case lookup "redirect" (pageMeta page) of where addMessage message = modifyContext $ \context -> context { ctxLayout = (ctxLayout context) - { pgMessages = pgMessages (ctxLayout context) ++ [message] + { pgMessages = pgMessages (ctxLayout context) ++ [renderHtml message] } } redirectedFrom source = do (url, html) <- processSource source - return $ concat - [ "Redirected from " - , html - , "" + return $ mconcat + [ "Redirected from ", + a ! href (url WasNoRedirect) ! title "Go to original page" $ html ] doubleRedirect source destination = do (url, html) <- processSource source (url', html') <- processDestination destination - return $ concat - [ "This page normally redirects to " - , html' - , ", but as you were already redirected from " - , html - , "" + return $ mconcat + [ "This page normally redirects to " + , a ! href (fromString $ url' WasRedirect) ! title "Continue to destination" $ html' + , ", but as you were already redirected from " + , a ! href (url WasNoRedirect) ! title "Go to original page" $ html , ", this was stopped to prevent a double-redirect." ] cancelledRedirect destination = do (url', html') <- processDestination destination - return $ concat - [ "This page redirects to " - , html' - , "." + return $ mconcat + [ "This page redirects to " + , a ! href (fromString $ url' WasRedirect) ! title "Continue to destination" $ html' ] processSource source = do base' <- getWikiBase - let url = stringToHtmlString $ base' ++ urlForPage source - let html = stringToHtmlString source + let url redir = fromString @AttributeValue $ + base' ++ urlForPage source ++ case redir of + WasNoRedirect -> "?redirect=no" + WasRedirect -> "" + let html = fromString @Html source return (url, html) processDestination destination = do base' <- getWikiBase let (page', fragment) = break (== '#') destination - let url = stringToHtmlString $ concat + let url redir = concat [ base' , urlForPage page' , fragment - ] - let html = stringToHtmlString page' + + ] ++ case redir of + WasNoRedirect -> "?redirect=no" + WasRedirect -> "" + let html = fromString @Html page' return (url, html) getSource = do cfg <- lift getConfig @@ -461,26 +461,25 @@ handleRedirects page = case lookup "redirect" (pageMeta page) of , urlForPage (pageName page) , "?redirect=yes" ] - lift $ seeOther url' $ withBody $ concat - [ "307 Redirect" - , "

You are being redirected.

" + lift $ seeOther url' $ withBody $ renderHtml $ docTypeHtml $ mconcat + [ Html5.head $ Html5.title "307 Redirect" + , Html5.body $ p $ mconcat [ + "You are being", + a ! href (fromString url') $ "redirected." + ] ] Just True -> fmap Left $ do (url', html') <- processDestination destination - lift $ ok $ withBody $ concat - [ "Redirecting to " - , html' - , "

Redirecting to " - , html' - , "...

" + lift $ ok $ withBody $ renderHtml $ docTypeHtml $ mconcat + [ Html5.head $ mconcat + [ Html5.title $ "Redirecting to" <> html' + , meta ! httpEquiv "refresh" ! content (fromString $ "0; url=" <> url' WasRedirect) + , script ! type_ "text/javascript" $ fromString $ "window.location=\"" <> url' WasRedirect <> "\"" + ], + Html5.body $ p $ mconcat + [ "Redirecting to " + , a ! href (fromString $ url' WasRedirect) $ html' + ] ] Just False -> do cancelledRedirect destination >>= addMessage @@ -505,7 +504,7 @@ pandocToHtml pandocContents = do case res of Right t -> return t Left e -> throwError $ PandocTemplateError $ T.pack e - return $ primHtml $ T.unpack . + return $ preEscapedToHtml @T.Text . (if xssSanitize cfg then sanitizeBalance else id) $ either E.throw id . runPure $ writeHtml5String def{ writerTemplate = Just compiledTemplate @@ -538,8 +537,7 @@ highlightSource (Just source) = do , traceOutput = False} l $ T.pack $ filter (/='\r') source of Left e -> fail (show e) - Right r -> return $ primHtml $ Blaze.renderHtml - $ formatHtmlBlock formatOpts r + Right r -> return $ formatHtmlBlock formatOpts r -- -- Plugin combinators @@ -603,11 +601,11 @@ wikiDivify :: Html -> ContentTransformer Html wikiDivify c = do categories <- liftM ctxCategories get base' <- lift getWikiBase - let categoryLink ctg = li (anchor ! [href $ base' ++ "/_category/" ++ ctg] << ctg) + let categoryLink ctg = li (a ! href (fromString $ base' ++ "/_category/" ++ ctg) $ fromString ctg) let htmlCategories = if null categories - then noHtml - else thediv ! [identifier "categoryList"] << ulist << map categoryLink categories - return $ thediv ! [identifier "wikipage"] << [c, htmlCategories] + then mempty + else Html5.div ! Html5.Attr.id "categoryList" $ ul $ foldMap categoryLink categories + return $ Html5.div ! Html5.Attr.id "wikipage" $ c <> htmlCategories -- | Adds page title to a Pandoc document. addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc diff --git a/src/Network/Gitit/Handlers.hs b/src/Network/Gitit/Handlers.hs index dfc75a006..337977ad0 100644 --- a/src/Network/Gitit/Handlers.hs +++ b/src/Network/Gitit/Handlers.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2008-9 John MacFarlane @@ -65,8 +66,6 @@ import Network.Gitit.Page (readCategories) import qualified Control.Exception as E import System.FilePath import Network.Gitit.State -import Text.XHtml hiding ( (), dir, method, password, rev ) -import qualified Text.XHtml as X ( method ) import Data.List (intercalate, intersperse, delete, nub, sortBy, find, isPrefixOf, inits, sort, (\\)) import Data.List.Split (wordsBy) import Data.Maybe (fromMaybe, mapMaybe, isJust, catMaybes) @@ -81,6 +80,13 @@ import Data.Time (getCurrentTime, addUTCTime) import Data.Time.Clock (diffUTCTime, UTCTime(..)) import Data.FileStore import System.Log.Logger (logM, Priority(..)) +import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml ) +import Text.Blaze.Html5 hiding (b, search, u, s, contents, source, html, title, map) +import Text.Blaze.Html5.Attributes hiding (span, id) +import qualified Text.Blaze.Html5 as Html5 hiding (search) +import qualified Text.Blaze.Html5.Attributes as Html5.Attr hiding (span) +import Data.String (IsString(fromString)) +import Prelude hiding (span) handleAny :: Handler handleAny = withData $ \(params :: Params) -> uriRest $ \uri -> @@ -94,7 +100,7 @@ handleAny = withData $ \(params :: Params) -> uriRest $ \uri -> case res of Right contents -> ignoreFilters >> -- don't compress (ok $ setContentType mimetype $ - (toResponse noHtml) {rsBody = contents}) + (toResponse (renderHtml mempty)) {rsBody = contents}) -- ugly hack Left NotFound -> mzero Left e -> error (show e) @@ -121,14 +127,14 @@ randomPage = do let newPage = pages !! (truncate (secs * 1000000) `mod` length pages) seeOther (base' ++ urlForPage newPage) $ toResponse $ - p << "Redirecting to a random page" + renderHtml $ p $ "Redirecting to a random page" discussPage :: Handler discussPage = do page <- getPage base' <- getWikiBase seeOther (base' ++ urlForPage (if isDiscussPage page then page else ('@':page))) $ - toResponse "Redirecting to discussion page" + toResponse ("Redirecting to discussion page" :: String) createPage :: Handler createPage = do @@ -140,42 +146,56 @@ createPage = do pgPageName = page , pgTabs = [] , pgTitle = "Create " ++ page ++ "?" - } $ - (p << stringToHtml - ("There is no page named '" ++ page ++ "'. You can:")) - +++ - (unordList $ - [ anchor ! - [href $ base' ++ "/_edit" ++ urlForPage page] << - ("Create the page '" ++ page ++ "'") - , anchor ! - [href $ base' ++ "/_search?" ++ - (urlEncodeVars [("patterns", page)])] << - ("Search for pages containing the text '" ++ - page ++ "'")]) + } + $ p $ mconcat + [ fromString + $ "There is no page named '" ++ page ++ "'. You can:" + , (ul $ mconcat + [ li $ a ! + href (fromString $ base' ++ "/_edit" ++ urlForPage page) + $ fromString ("Create the page '" ++ page ++ "'") + , li $ a ! + href (fromString $ base' ++ "/_search?" ++ + (urlEncodeVars [("patterns", page)])) + $ fromString ("Search for pages containing the text '" ++ + page ++ "'")]) + ] + +fileInput :: AttributeValue -> AttributeValue -> Html +fileInput nameAndId val = input ! type_ "file" ! Html5.Attr.id nameAndId ! name nameAndId ! value val +textfieldInput :: AttributeValue -> AttributeValue -> Html +textfieldInput nameAndId val = input ! type_ "text" ! Html5.Attr.id nameAndId ! name nameAndId ! value val +checkboxInput :: AttributeValue -> AttributeValue -> Html +checkboxInput nameAndId val = input ! type_ "checkbox" ! Html5.Attr.id nameAndId ! name nameAndId ! value val +submitInput :: AttributeValue -> AttributeValue -> Html +submitInput nameAndId val = input ! type_ "submit" ! Html5.Attr.id nameAndId ! name nameAndId ! value val uploadForm :: Handler uploadForm = withData $ \(params :: Params) -> do let origPath = pFilename params let wikiname = pWikiname params `orIfNull` takeFileName origPath let logMsg = pLogMsg params - let upForm = form ! [X.method "post", enctype "multipart/form-data"] << - fieldset << - [ p << [label ! [thefor "file"] << "File to upload:" + let upForm = Html5.form ! Html5.Attr.method "post" ! enctype "multipart/form-data" + $ fieldset $ mconcat + [ p $ mconcat + [ Html5.label ! for "file" $ "File to upload:" , br - , afile "file" ! [value origPath] ] - , p << [ label ! [thefor "wikiname"] << "Name on wiki, including extension" - , noscript << " (leave blank to use the same filename)" - , stringToHtml ":" + , fileInput "file" (fromString origPath) ] + , p $ mconcat + [ Html5.label ! for "wikiname" $ "Name on wiki, including extension" + , noscript $ " (leave blank to use the same filename)" + , ":" , br - , textfield "wikiname" ! [value wikiname] - , primHtmlChar "nbsp" - , checkbox "overwrite" "yes" - , label ! [thefor "overwrite"] << "Overwrite existing file" ] - , p << [ label ! [thefor "logMsg"] << "Description of content or changes:" + , textfieldInput "wikiname" (fromString wikiname) + , preEscapedString " " + , checkboxInput "overwrite" "yes" + , Html5.label ! for "overwrite" $ "Overwrite existing file" + ] + , p $ mconcat + [ Html5.label ! for "logMsg" $ "Description of content or changes:" , br - , textfield "logMsg" ! [size "60", value logMsg] - , submit "upload" "Upload" ] + , textfieldInput "logMsg" (fromString logMsg) ! size "60" + , submitInput "upload" "Upload" ] ] formattedPage defaultPageLayout{ pgMessages = pMessages params, @@ -227,13 +247,13 @@ uploadFile = withData $ \(params :: Params) -> do fileContents <- liftIO $ B.readFile filePath let len = B.length fileContents liftIO $ save fs wikiname (Author user email) logMsg fileContents - let contents = thediv << - [ h2 << ("Uploaded " ++ show len ++ " bytes") + let contents = Html5.div $ mconcat + [ h2 $ fromString ("Uploaded " ++ show len ++ " bytes") , if takeExtension wikiname `elem` imageExtensions - then p << "To add this image to a page, use:" +++ - pre << ("![alt text](/" ++ wikiname ++ ")") - else p << "To link to this resource from a page, use:" +++ - pre << ("[link label](/" ++ wikiname ++ ")") ] + then (p $ "To add this image to a page, use:") <> + (pre $ fromString ("![alt text](/" ++ wikiname ++ ")")) + else (p $ "To link to this resource from a page, use:") <> + (pre $ fromString ("[link label](/" ++ wikiname ++ ")")) ] formattedPage defaultPageLayout{ pgMessages = pMessages params, pgShowPageTools = False, @@ -255,10 +275,10 @@ goToPage = withData $ \(params :: Params) -> do base' <- getWikiBase case findPage exactMatch of Just m -> seeOther (base' ++ urlForPage m) $ toResponse - "Redirecting to exact match" + ("Redirecting to exact match" :: String) Nothing -> case findPage insensitiveMatch of Just m -> seeOther (base' ++ urlForPage m) $ toResponse - "Redirecting to case-insensitive match" + ("Redirecting to case-insensitive match" :: String) Nothing -> case findPage prefixMatch of Just m -> seeOther (base' ++ urlForPage m) $ toResponse $ "Redirecting" ++ @@ -297,22 +317,23 @@ searchResults = withData $ \(params :: Params) -> do then 100 else 0 let preamble = if null patterns - then h3 << ["Please enter a search term."] - else h3 << [ stringToHtml (show (length matches) ++ " matches found for ") - , thespan ! [identifier "pattern"] << unwords patterns] + then h3 $ "Please enter a search term." + else h3 $ mconcat + [ fromString (show (length matches) ++ " matches found for ") + , Html5.span ! Html5.Attr.id "pattern" $ fromString $ unwords patterns ] base' <- getWikiBase - let toMatchListItem (file, contents) = li << - [ anchor ! [href $ base' ++ urlForPage (dropExtension file)] << dropExtension file - , stringToHtml (" (" ++ show (length contents) ++ " matching lines)") - , stringToHtml " " - , anchor ! [href "#", theclass "showmatch", - thestyle "display: none;"] << if length contents > 0 + let toMatchListItem (file, contents) = li $ mconcat + [ a ! href (fromString $ base' ++ urlForPage (dropExtension file)) $ fromString $ dropExtension file + , fromString (" (" ++ show (length contents) ++ " matching lines)") + , " " + , a ! href "#" ! class_ "showmatch" ! + Html5.Attr.style "display: none;" $ if length contents > 0 then "[show matches]" else "" - , pre ! [theclass "matches"] << unlines contents] - let htmlMatches = preamble +++ - olist << map toMatchListItem - (reverse $ sortBy (comparing relevance) matches) + , pre ! class_ "matches" $ fromString $ unlines contents] + let htmlMatches = preamble <> + (ol $ foldMap toMatchListItem + (reverse $ sortBy (comparing relevance) matches)) formattedPage defaultPageLayout{ pgMessages = pMessages params, pgShowPageTools = False, @@ -332,47 +353,51 @@ showFileHistory = withData $ \(params :: Params) -> do file <- getPage showHistory file file params +intDataAttribute :: Tag -> Int -> Attribute +intDataAttribute tag = dataAttribute tag . fromString . show + showHistory :: String -> String -> Params -> Handler showHistory file page params = do fs <- getFileStore hist <- liftIO $ history fs [file] (TimeRange Nothing Nothing) (Just $ pLimit params) base' <- getWikiBase - let versionToHtml rev pos = li ! [theclass "difflink", intAttr "order" pos, - strAttr "revision" (revId rev), - strAttr "diffurl" (base' ++ "/_diff/" ++ page)] << - [ thespan ! [theclass "date"] << (show $ revDateTime rev) - , stringToHtml " (" - , thespan ! [theclass "author"] << anchor ! [href $ base' ++ "/_activity?" ++ - urlEncodeVars [("forUser", authorName $ revAuthor rev)]] << - (authorName $ revAuthor rev) - , stringToHtml "): " - , anchor ! [href (base' ++ urlForPage page ++ "?revision=" ++ revId rev)] << - thespan ! [theclass "subject"] << revDescription rev - , noscript << - ([ stringToHtml " [compare with " - , anchor ! [href $ base' ++ "/_diff" ++ urlForPage page ++ "?to=" ++ revId rev] << + let versionToHtml rev pos = li ! class_ "difflink" ! intDataAttribute "order" pos ! + dataAttribute "revision" (fromString $ revId rev) ! + dataAttribute "diffurl" (fromString $ base' ++ "/_diff/" ++ page) + $ mconcat + [ span ! class_ "date" $ (fromString $ show $ revDateTime rev) + , " (" + , span ! class_ "author" $ a ! href (fromString $ base' ++ "/_activity?" ++ + urlEncodeVars [("forUser", authorName $ revAuthor rev)]) $ + fromString (authorName $ revAuthor rev) + , "): " + , a ! href (fromString $ base' ++ urlForPage page ++ "?revision=" ++ revId rev) $ + span ! class_ "subject" $ fromString $ revDescription rev + , noscript $ mconcat + ([ " [compare with " + , a ! href (fromString $ base' ++ "/_diff" ++ urlForPage page ++ "?to=" ++ revId rev) $ "previous" ] ++ (if pos /= 1 - then [ primHtmlChar "nbsp" - , primHtmlChar "bull" - , primHtmlChar "nbsp" - , anchor ! [href $ base' ++ "/_diff" ++ urlForPage page ++ "?from=" ++ - revId rev] << "current" + then [ preEscapedString " " + , preEscapedString "•" + , preEscapedString " " + , a ! href (fromString $ base' ++ "/_diff" ++ urlForPage page ++ "?from=" ++ + revId rev) $ "current" ] else []) ++ - [stringToHtml "]"]) + ["]"]) ] let contents = if null hist - then noHtml - else ulist ! [theclass "history"] << + then mempty + else ul ! class_ "history" $ mconcat $ zipWith versionToHtml hist [length hist, (length hist - 1)..1] let more = if length hist == pLimit params - then anchor ! [href $ base' ++ "/_history" ++ urlForPage page - ++ "?limit=" ++ show (pLimit params + 100)] << + then a ! href (fromString $ base' ++ "/_history" ++ urlForPage page + ++ "?limit=" ++ show (pLimit params + 100)) $ "Show more..." - else noHtml + else mempty let tabs = if file == page -- source file, not wiki page then [ViewTab,HistoryTab] else pgTabs defaultPageLayout @@ -383,7 +408,7 @@ showHistory file page params = do pgTabs = tabs, pgSelectedTab = HistoryTab, pgTitle = ("Changes to " ++ page) - } $ contents +++ more + } $ contents <> more showActivity :: Handler showActivity = withData $ \(params :: Params) -> do @@ -406,31 +431,31 @@ showActivity = withData $ \(params :: Params) -> do fileFromChange (Deleted f) = f base' <- getWikiBase let fileAnchor revis file = if takeExtension file == "." ++ (defaultExtension cfg) - then anchor ! [href $ base' ++ "/_diff" ++ urlForPage (dropExtension file) ++ "?to=" ++ revis] << dropExtension file - else anchor ! [href $ base' ++ urlForPage file ++ "?revision=" ++ revis] << file - let filesFor changes revis = intersperse (stringToHtml " ") $ + then a ! href (fromString $ base' ++ "/_diff" ++ urlForPage (dropExtension file) ++ "?to=" ++ revis) $ fromString $ dropExtension file + else a ! href (fromString $ base' ++ urlForPage file ++ "?revision=" ++ revis) $ fromString file + let filesFor changes revis = intersperse " " $ map (fileAnchor revis . fileFromChange) changes - let heading = h1 << ("Recent changes by " ++ fromMaybe "all users" forUser) - let revToListItem rev = li << - [ thespan ! [theclass "date"] << (show $ revDateTime rev) - , stringToHtml " (" - , thespan ! [theclass "author"] << - anchor ! [href $ base' ++ "/_activity?" ++ - urlEncodeVars [("forUser", authorName $ revAuthor rev)]] << - (authorName $ revAuthor rev) - , stringToHtml "): " - , thespan ! [theclass "subject"] << revDescription rev - , stringToHtml " (" - , thespan ! [theclass "files"] << filesFor (revChanges rev) (revId rev) - , stringToHtml ")" + let heading = h1 $ fromString ("Recent changes by " ++ fromMaybe "all users" forUser) + let revToListItem rev = li $ mconcat + [ span ! class_ "date" $ fromString $ (show $ revDateTime rev) + , " (" + , span ! class_ "author" $ + a ! href (fromString $ base' ++ "/_activity?" ++ + urlEncodeVars [("forUser", authorName $ revAuthor rev)]) $ + fromString (authorName $ revAuthor rev) + , "): " + , span ! class_ "subject" $ fromString $ revDescription rev + , " (" + , span ! class_ "files" $ mconcat $ filesFor (revChanges rev) (revId rev) + , ")" ] - let contents = ulist ! [theclass "history"] << map revToListItem hist' + let contents = ul ! class_ "history" $ foldMap revToListItem hist' formattedPage defaultPageLayout{ pgMessages = pMessages params, pgShowPageTools = False, pgTabs = [], pgTitle = "Recent changes" - } (heading +++ contents) + } (heading <> contents) showPageDiff :: Handler showPageDiff = withData $ \(params :: Params) -> do @@ -484,17 +509,20 @@ getDiff :: FileStore -> FilePath -> Maybe RevisionId -> Maybe RevisionId -> IO Html getDiff fs file from to = do rawDiff <- diff fs file from to - let diffLineToHtml (Both xs _) = thespan << unlines xs - diffLineToHtml (First xs) = thespan ! [theclass "deleted"] << unlines xs - diffLineToHtml (Second xs) = thespan ! [theclass "added"] << unlines xs - return $ h2 ! [theclass "revision"] << - ("Changes from " ++ fromMaybe "beginning" from ++ - " to " ++ fromMaybe "current" to) +++ - pre ! [theclass "diff"] << map diffLineToHtml rawDiff + let diffLineToHtml (Both xs _) = span $ fromString $ unlines xs + diffLineToHtml (First xs) = span ! class_ "deleted" $ fromString $ unlines xs + diffLineToHtml (Second xs) = span ! class_ "added" $ fromString $ unlines xs + return $ h2 ! class_ "revision" $ + (fromString $ "Changes from " ++ fromMaybe "beginning" from ++ + " to " ++ fromMaybe "current" to) <> + (pre ! class_ "diff" $ foldMap diffLineToHtml rawDiff) editPage :: Handler editPage = withData editPage' +gui :: AttributeValue -> Html -> Html +gui act = Html5.form ! action act ! Html5.Attr.method "post" + editPage' :: Params -> Handler editPage' params = do let rev = pRevision params -- if this is set, we're doing a revert @@ -521,33 +549,33 @@ editPage' params = do let messages = pMessages params let logMsg = pLogMsg params let sha1Box = case mbRev of - Just r -> textfield "sha1" ! [thestyle "display: none", - value r] - Nothing -> noHtml - let readonly = if isJust (pRevision params) + Just r -> textfieldInput "sha1" (fromString r) ! Html5.Attr.style "display: none" + Nothing -> mempty + let readonly' = if isJust (pRevision params) -- disable editing of text box if it's a revert - then [strAttr "readonly" "yes", - strAttr "style" "color: gray"] - else [] + then (Html5.Attr.readonly "readonly") + <> Html5.Attr.style "color: gray" + else mempty base' <- getWikiBase - let editForm = gui (base' ++ urlForPage page) ! [identifier "editform"] << + let editForm = gui (fromString $ base' ++ urlForPage page) ! Html5.Attr.id "editform" + $ mconcat [ sha1Box - , textarea ! (readonly ++ [cols "80", name "editedText", - identifier "editedText"]) << raw + , textarea ! readonly' ! cols "80" ! name "editedText" ! + Html5.Attr.id "editedText" $ fromString raw , br - , label ! [thefor "logMsg"] << "Description of changes:" + , Html5.label ! for "logMsg" $ "Description of changes:" , br - , textfield "logMsg" ! (readonly ++ [value (logMsg `orIfNull` defaultSummary cfg) ]) - , submit "update" "Save" - , primHtmlChar "nbsp" - , submit "cancel" "Discard" - , primHtmlChar "nbsp" - , input ! [thetype "button", theclass "editButton", - identifier "previewButton", - strAttr "onClick" "updatePreviewPane();", - strAttr "style" "display: none;", - value "Preview" ] - , thediv ! [ identifier "previewpane" ] << noHtml + , textfieldInput "logMsg" (fromString $ logMsg `orIfNull` defaultSummary cfg) ! readonly' + , submitInput "update" "Save" + , preEscapedString " " + , submitInput "cancel" "Discard" + , preEscapedString " " + , input ! type_ "button" ! class_ "editButton" + ! Html5.Attr.id "previewButton" + ! onclick "updatePreviewPane();" + ! Html5.Attr.style "display: none;" + ! value "Preview" + , Html5.div ! Html5.Attr.id "previewpane" $ mempty ] let pgScripts' = ["preview.js"] let pgScripts'' = case mathMethod cfg of @@ -583,17 +611,17 @@ confirmDelete = do Left NotFound -> return "" Left e -> fail (show e) Left e -> fail (show e) - let confirmForm = gui "" << - [ p << "Are you sure you want to delete this page?" - , input ! [thetype "text", name "filetodelete", - strAttr "style" "display: none;", value fileToDelete] - , submit "confirm" "Yes, delete it!" - , stringToHtml " " - , submit "cancel" "No, keep it!" + let confirmForm = gui "" $ mconcat + [ p $ "Are you sure you want to delete this page?" + , input ! type_ "text" ! name "filetodelete" + ! Html5.Attr.style "display: none;" ! value (fromString fileToDelete) + , submitInput "confirm" "Yes, delete it!" + , " " + , submitInput "cancel" "No, keep it!" , br ] formattedPage defaultPageLayout{ pgTitle = "Delete " ++ page ++ "?" } $ if null fileToDelete - then ulist ! [theclass "messages"] << li << + then ul ! class_ "messages" $ li $ "There is no file or page by that name." else confirmForm @@ -613,8 +641,8 @@ deletePage = withData $ \(params :: Params) -> do then do fs <- getFileStore liftIO $ Data.FileStore.delete fs file author descrip - seeOther (base' ++ "/") $ toResponse $ p << "File deleted" - else seeOther (base' ++ urlForPage page) $ toResponse $ p << "Not deleted" + seeOther (base' ++ "/") $ toResponse $ p $ "File deleted" + else seeOther (base' ++ urlForPage page) $ toResponse $ p $ "Not deleted" updatePage :: Handler updatePage = withData $ \(params :: Params) -> do @@ -650,7 +678,7 @@ updatePage = withData $ \(params :: Params) -> do then return (Right ()) else E.throwIO e) case modifyRes of - Right () -> seeOther (base' ++ urlForPage page) $ toResponse $ p << "Page updated" + Right () -> seeOther (base' ++ urlForPage page) $ toResponse $ p $ "Page updated" Left (MergeInfo mergedWithRev conflicts mergedText) -> do let mergeMsg = "The page has been edited since you checked it out. " ++ "Changes from revision " ++ revId mergedWithRev ++ @@ -686,25 +714,25 @@ indexPage = do fileListToHtml :: String -> String -> String -> [Resource] -> Html fileListToHtml base' prefix ext files = let fileLink (FSFile f) | takeExtension f == "." ++ ext = - li ! [theclass "page" ] << - anchor ! [href $ base' ++ urlForPage (prefix ++ dropExtension f)] << - dropExtension f - fileLink (FSFile f) = li ! [theclass "upload"] << concatHtml - [ anchor ! [href $ base' ++ urlForPage (prefix ++ f)] << f - , anchor ! [href $ base' ++ "_delete" ++ urlForPage (prefix ++ f)] << "(delete)" + li ! class_ "page" $ + a ! href (fromString $ base' ++ urlForPage (prefix ++ dropExtension f)) $ + fromString $ dropExtension f + fileLink (FSFile f) = li ! class_ "upload" $ mconcat + [ a ! href (fromString $ base' ++ urlForPage (prefix ++ f)) $ fromString f + , a ! href (fromString $ base' ++ "_delete" ++ urlForPage (prefix ++ f)) $ "(delete)" ] fileLink (FSDirectory f) = - li ! [theclass "folder"] << - anchor ! [href $ base' ++ urlForPage (prefix ++ f) ++ "/"] << f + li ! class_ "folder" $ + a ! href (fromString $ base' ++ urlForPage (prefix ++ f) ++ "/") $ fromString f updirs = drop 1 $ inits $ splitPath $ '/' : prefix uplink = foldr (\d accum -> - concatHtml [ anchor ! [theclass "updir", - href $ if length d <= 1 + mconcat [ a ! class_ "updir" ! + href (fromString $ if length d <= 1 then base' ++ "/_index" else base' ++ - urlForPage (joinPath $ drop 1 d)] << - lastNote "fileListToHtml" d, accum]) noHtml updirs - in uplink +++ ulist ! [theclass "index"] << map fileLink files + urlForPage (joinPath $ drop 1 d)) $ + fromString $ lastNote "fileListToHtml" d, accum]) mempty updirs + in uplink <> (ul ! class_ "index" $ foldMap fileLink files) -- NOTE: The current implementation of categoryPage does not go via the -- filestore abstraction. That is bad, but can only be fixed if we add @@ -725,22 +753,22 @@ categoryPage = do then Just (f, categories \\ pcategories) else Nothing base' <- getWikiBase - let toMatchListItem file = li << - [ anchor ! [href $ base' ++ urlForPage (dropExtension file)] << dropExtension file ] - let toRemoveListItem cat = li << - [ anchor ! [href $ base' ++ + let toMatchListItem file = li $ + a ! href (fromString $ base' ++ urlForPage (dropExtension file)) $ fromString $ dropExtension file + let toRemoveListItem cat = li $ + a ! href (fromString $ base' ++ (if null (tail pcategories) then "/_categories" - else "/_category" ++ urlForPage (intercalate "," $ Data.List.delete cat pcategories)) ] - << ("-" ++ cat) ] - let toAddListItem cat = li << - [ anchor ! [href $ base' ++ - "/_category" ++ urlForPage (path' ++ "," ++ cat) ] - << ("+" ++ cat) ] - let matchList = ulist << map toMatchListItem (fst $ unzip matches) +++ - thediv ! [ identifier "categoryList" ] << - ulist << (++) (map toAddListItem (nub $ concat $ snd $ unzip matches)) - (map toRemoveListItem pcategories) + else "/_category" ++ urlForPage (intercalate "," $ Data.List.delete cat pcategories))) + $ fromString ("-" ++ cat) + let toAddListItem cat = li $ + a ! href (fromString $ base' ++ + "/_category" ++ urlForPage (path' ++ "," ++ cat)) + $ fromString ("+" ++ cat) + let matchList = ul $ foldMap toMatchListItem (fst $ unzip matches) <> + (Html5.div ! Html5.Attr.id "categoryList" $ + ul $ mconcat $ (++) (map toAddListItem (nub $ concat $ snd $ unzip matches)) + (map toRemoveListItem pcategories)) formattedPage defaultPageLayout{ pgPageName = categoryDescription, pgShowPageTools = False, @@ -758,9 +786,9 @@ categoryListPage = do categories <- liftIO $ liftM (nub . sort . concat) $ forM pages $ \f -> readCategories (repoPath f) base' <- getWikiBase - let toCatLink ctg = li << - [ anchor ! [href $ base' ++ "/_category" ++ urlForPage ctg] << ctg ] - let htmlMatches = ulist << map toCatLink categories + let toCatLink ctg = li $ + a ! href (fromString $ base' ++ "/_category" ++ urlForPage ctg) $ (fromString ctg) + let htmlMatches = ul $ foldMap toCatLink categories formattedPage defaultPageLayout{ pgPageName = "Categories", pgShowPageTools = False, diff --git a/src/Network/Gitit/Layout.hs b/src/Network/Gitit/Layout.hs index f835d4269..d42318587 100644 --- a/src/Network/Gitit/Layout.hs +++ b/src/Network/Gitit/Layout.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {- Copyright (C) 2009 John MacFarlane @@ -33,9 +35,11 @@ import Network.Gitit.State import Network.Gitit.Types import Network.HTTP (urlEncodeVars) import qualified Text.StringTemplate as T -import Text.XHtml hiding ( (), dir, method, password, rev ) -import Text.XHtml.Strict ( stringToHtmlString ) import Data.Maybe (isNothing) +import Text.Blaze.Html5 hiding (s, article, map) +import Text.Blaze.Html5.Attributes hiding (id) +import Data.String (IsString(fromString)) +import Text.Blaze.Html.Renderer.String (renderHtml) defaultPageLayout :: PageLayout defaultPageLayout = PageLayout @@ -78,19 +82,19 @@ filledPageTemplate base' cfg layout htmlContents templ = _ -> base' ++ "/js/" ++ x scripts = ["jquery-1.2.6.min.js", "jquery-ui-combined-1.6rc2.min.js", "footnotes.js"] ++ pgScripts layout - scriptLink x = script ! [src (prefixedScript x), - thetype "text/javascript"] << noHtml - javascriptlinks = renderHtmlFragment $ concatHtml $ map scriptLink scripts + scriptLink x = script ! src (fromString $ prefixedScript x) ! + type_ "text/javascript" $ mempty + javascriptlinks = renderHtml $ mconcat $ map scriptLink scripts article = if isDiscussPage page then drop 1 page else page discussion = '@':article tabli tab = if tab == pgSelectedTab layout - then li ! [theclass "selected"] + then li ! class_ "selected" else li tabs' = [x | x <- pgTabs layout, not (x == EditTab && page `elem` noEdit cfg)] - tabs = ulist ! [theclass "tabs"] << map (linkForTab tabli base' page rev) tabs' - setStrAttr attr = T.setAttribute attr . stringToHtmlString - setBoolAttr attr test = if test then T.setAttribute attr "true" else id + tabs = (ul ! class_ "tabs") $ foldMap (linkForTab tabli base' page rev) tabs' + setStrAttr attr = T.setAttribute attr . renderHtml . fromString @Html + setBoolAttr attr test = if test then T.setAttribute attr ("true"::[Char]) else id in T.setAttribute "base" base' . T.setAttribute "feed" (pgLinkToFeed layout) . setStrAttr "wikititle" (wikiTitle cfg) . @@ -111,10 +115,10 @@ filledPageTemplate base' cfg layout htmlContents templ = setBoolAttr "printable" (pgPrintable layout) . maybe id (T.setAttribute "revision") rev . (if null (pgTabs layout) then id else T.setAttribute "tabs" - (renderHtmlFragment tabs)) . + (renderHtml tabs)) . (\f x xs -> if null xs then x else f xs) (T.setAttribute "messages") id (pgMessages layout) . T.setAttribute "usecache" (useCache cfg) . - T.setAttribute "content" (renderHtmlFragment htmlContents) . + T.setAttribute "content" (renderHtml htmlContents) . setBoolAttr "wikiupload" ( uploadsAllowed cfg) $ templ @@ -123,32 +127,32 @@ filledPageTemplate base' cfg layout htmlContents templ = linkForTab :: (Tab -> Html -> Html) -> String -> String -> Maybe String -> Tab -> Html linkForTab tabli base' page _ HistoryTab = - tabli HistoryTab << anchor ! [href $ base' ++ "/_history" ++ urlForPage page] << "history" + tabli HistoryTab $ a ! href (fromString $ base' ++ "/_history" ++ urlForPage page) $ "history" linkForTab tabli _ _ _ DiffTab = - tabli DiffTab << anchor ! [href ""] << "diff" + tabli DiffTab $ a ! href "" $ "diff" linkForTab tabli base' page rev ViewTab = let origPage s = if isDiscussPage s then drop 1 s else s in if isDiscussPage page - then tabli DiscussTab << anchor ! - [href $ base' ++ urlForPage (origPage page)] << "page" - else tabli ViewTab << anchor ! - [href $ base' ++ urlForPage page ++ + then tabli DiscussTab $ a ! + href (fromString $ base' ++ urlForPage (origPage page)) $ "page" + else tabli ViewTab $ a ! + href (fromString $ base' ++ urlForPage page ++ case rev of Just r -> "?revision=" ++ r - Nothing -> ""] << "view" + Nothing -> "") $ "view" linkForTab tabli base' page _ DiscussTab = - tabli (if isDiscussPage page then ViewTab else DiscussTab) << - anchor ! [href $ base' ++ if isDiscussPage page then "" else "/_discuss" ++ - urlForPage page] << "discuss" + tabli (if isDiscussPage page then ViewTab else DiscussTab) $ + a ! href (fromString $ base' ++ if isDiscussPage page then "" else "/_discuss" ++ + urlForPage page) $ "discuss" linkForTab tabli base' page rev EditTab = - tabli EditTab << anchor ! - [href $ base' ++ "/_edit" ++ urlForPage page ++ + tabli EditTab $ a ! + href (fromString $ base' ++ "/_edit" ++ urlForPage page ++ case rev of Just r -> "?revision=" ++ r ++ "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ r)] - Nothing -> ""] << if isNothing rev + Nothing -> "") $ if isNothing rev then "edit" else "revert" diff --git a/src/Network/Gitit/Types.hs b/src/Network/Gitit/Types.hs index 57bdd76bb..4b95759cb 100644 --- a/src/Network/Gitit/Types.hs +++ b/src/Network/Gitit/Types.hs @@ -70,7 +70,6 @@ import Control.Monad.State (StateT, runStateT, get, modify) import Control.Monad (liftM, mplus) import System.Log.Logger (Priority(..)) import Text.Pandoc.Definition (Pandoc) -import Text.XHtml (Html) import qualified Data.Map as M import Data.Text (Text) import Data.List (intersect) @@ -85,6 +84,7 @@ import Network.Gitit.Server import Text.HTML.TagSoup.Entity (lookupEntity) import Data.Char (isSpace) import Network.OAuth.OAuth2 +import Text.Blaze.Html (Html) data PageType = Markdown | CommonMark