@@ -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,13 +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)
-#if MIN_VERSION_blaze_html(0,5,0)
-import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml )
-#else
-import Text.Blaze.Renderer.String as Blaze ( renderHtml )
-#endif
import URI.ByteString (Query(Query), URIRef(uriPath), laxURIParserOptions,
parseURI, uriQuery)
import qualified Data.Text as T
@@ -108,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
@@ -199,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.
@@ -336,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:
--
@@ -378,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
@@ -465,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
@@ -509,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
@@ -542,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
@@ -607,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