gitit 0.15.1.2 → 0.16
raw patch · 20 files changed
+485/−620 lines, 20 filesdep ~aesondep ~basedep ~blaze-htmlPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson, base, blaze-html, filestore, hoauth2, http-client-tls, network, pandoc, xml-conduit, zlib
API changes (from Hackage documentation)
- Network.Gitit.Authentication: instance GHC.Show.Show Network.Gitit.Authentication.RPars
- Network.Gitit.Authentication: instance Happstack.Server.RqData.FromData Network.Gitit.Authentication.RPars
- Network.Gitit.Authentication: rpxAuthHandlers :: [Handler]
- Network.Gitit.Interface: [rpxDomain] :: Config -> String
- Network.Gitit.Interface: [rpxKey] :: Config -> String
- Network.Gitit.Rpxnow: Identifier :: String -> [(String, String)] -> Identifier
- Network.Gitit.Rpxnow: [userData] :: Identifier -> [(String, String)]
- Network.Gitit.Rpxnow: [userIdentifier] :: Identifier -> String
- Network.Gitit.Rpxnow: authenticate :: String -> String -> IO (Either String Identifier)
- Network.Gitit.Rpxnow: data Identifier
- Network.Gitit.Rpxnow: instance GHC.Show.Show Network.Gitit.Rpxnow.Identifier
- Network.Gitit.Types: [rpxDomain] :: Config -> String
- Network.Gitit.Types: [rpxKey] :: Config -> String
- Network.Gitit.Types: [templatesPath] :: GititState -> FilePath
- Network.Gitit: reloadTemplates :: ServerPart Response
+ Network.Gitit: reloadTemplates :: Config -> ServerPart Response
- Network.Gitit.Compat.Except: data () => ExceptT e (m :: Type -> Type) a
+ Network.Gitit.Compat.Except: data ExceptT e (m :: Type -> Type) a
- Network.Gitit.Initialize: recompilePageTemplate :: IO ()
+ Network.Gitit.Initialize: recompilePageTemplate :: Config -> IO ()
- Network.Gitit.Interface: Config :: FilePath -> FileStoreType -> PageType -> String -> MathMethod -> Bool -> Bool -> (Handler -> Handler) -> AuthenticationLevel -> Handler -> FilePath -> Int -> FilePath -> FilePath -> Priority -> FilePath -> [String] -> Bool -> Integer -> Integer -> String -> Int -> Bool -> String -> [String] -> [String] -> String -> String -> Maybe (String, [String]) -> Bool -> Bool -> String -> String -> String -> String -> Bool -> Bool -> FilePath -> Map String String -> String -> String -> Text -> Bool -> String -> Bool -> String -> Integer -> Integer -> Maybe FilePath -> Bool -> Int -> GithubConfig -> Config
+ Network.Gitit.Interface: Config :: FilePath -> FileStoreType -> PageType -> String -> MathMethod -> Bool -> Bool -> (Handler -> Handler) -> AuthenticationLevel -> Handler -> FilePath -> Int -> FilePath -> FilePath -> Priority -> FilePath -> [String] -> Bool -> Integer -> Integer -> String -> Int -> Bool -> String -> [String] -> [String] -> String -> String -> Maybe (String, [String]) -> Bool -> Bool -> String -> String -> Bool -> Bool -> FilePath -> Map String String -> String -> String -> Text -> Bool -> String -> Bool -> String -> Integer -> Integer -> Maybe FilePath -> Bool -> Int -> GithubConfig -> Config
- Network.Gitit.Interface: data () => Request
+ Network.Gitit.Interface: data Request
- Network.Gitit.Interface: type PluginM = ReaderT PluginData (StateT Context IO)
+ Network.Gitit.Interface: type PluginM = ReaderT PluginData StateT Context IO
- Network.Gitit.Types: Config :: FilePath -> FileStoreType -> PageType -> String -> MathMethod -> Bool -> Bool -> (Handler -> Handler) -> AuthenticationLevel -> Handler -> FilePath -> Int -> FilePath -> FilePath -> Priority -> FilePath -> [String] -> Bool -> Integer -> Integer -> String -> Int -> Bool -> String -> [String] -> [String] -> String -> String -> Maybe (String, [String]) -> Bool -> Bool -> String -> String -> String -> String -> Bool -> Bool -> FilePath -> Map String String -> String -> String -> Text -> Bool -> String -> Bool -> String -> Integer -> Integer -> Maybe FilePath -> Bool -> Int -> GithubConfig -> Config
+ Network.Gitit.Types: Config :: FilePath -> FileStoreType -> PageType -> String -> MathMethod -> Bool -> Bool -> (Handler -> Handler) -> AuthenticationLevel -> Handler -> FilePath -> Int -> FilePath -> FilePath -> Priority -> FilePath -> [String] -> Bool -> Integer -> Integer -> String -> Int -> Bool -> String -> [String] -> [String] -> String -> String -> Maybe (String, [String]) -> Bool -> Bool -> String -> String -> Bool -> Bool -> FilePath -> Map String String -> String -> String -> Text -> Bool -> String -> Bool -> String -> Integer -> Integer -> Maybe FilePath -> Bool -> Int -> GithubConfig -> Config
- Network.Gitit.Types: GititState :: Sessions SessionData -> Map String User -> FilePath -> (PageLayout -> Html -> Handler) -> [Plugin] -> GititState
+ Network.Gitit.Types: GititState :: Sessions SessionData -> Map String User -> (PageLayout -> Html -> Handler) -> [Plugin] -> GititState
- Network.Gitit.Types: class (Monad m) => HasContext m
+ Network.Gitit.Types: class Monad m => HasContext (m :: Type -> Type)
- Network.Gitit.Types: type GititServerPart = ServerPartT (ReaderT WikiState IO)
+ Network.Gitit.Types: type GititServerPart = ServerPartT ReaderT WikiState IO
- Network.Gitit.Types: type PluginM = ReaderT PluginData (StateT Context IO)
+ Network.Gitit.Types: type PluginM = ReaderT PluginData StateT Context IO
Files
- CHANGES +32/−0
- README.markdown +4/−5
- data/default.conf +4/−16
- data/markup.HTML +1/−1
- data/markupHelp/HTML +1/−1
- data/static/js/MathMLinHTML.js +0/−76
- data/templates/page.st +5/−6
- gitit.cabal +15/−14
- gitit.hs +1/−1
- src/Network/Gitit.hs +3/−3
- src/Network/Gitit/Authentication.hs +118/−147
- src/Network/Gitit/Authentication/Github.hs +4/−0
- src/Network/Gitit/Config.hs +5/−9
- src/Network/Gitit/ContentTransformer.hs +61/−63
- src/Network/Gitit/Handlers.hs +195/−168
- src/Network/Gitit/Initialize.hs +3/−5
- src/Network/Gitit/Layout.hs +28/−24
- src/Network/Gitit/Rpxnow.hs +0/−75
- src/Network/Gitit/State.hs +0/−1
- src/Network/Gitit/Types.hs +5/−5
CHANGES view
@@ -1,3 +1,35 @@+Version 0.16 released 10 Jun 2026++ * Remove unnecessary templatesPath field in GititState (Profpatsch)+ [API change]. The templates are directly pulled out of the config+ and then never changed, so no reason to put the field in state.++ * Add Paths_gitit to autogen-modules in executable section.++ * Change Git repository location to HTTPS (Felix Yan).+ `git://` is no longer supported.++ * Remove RPXnow authentication (Profpatsch).++ * Move everything from xhtml to blaze & HTML5 (Profpatsch).++ * Fix Redirect `<meta>` header (Profpatsch).++ * Remove old MathMLinHTML.hs. Browsers support MathML now.++ * Remove deprecated projection media type in template.++ * Remove old comment workaround needed for IE6 in template.++ * Raise upper bound for zlib, network, aeson, http-client, hoauth2,+ pandoc, xml-conduit.++ * Require filestore >= 0.6.5.1 (#710).++ * Correct a typo in src/Network/Gitit/ContentTransformer.hs (Felix Yan).++ * Fix link & mention of highlighting-kate in README (#711).+ Version 0.15.1.2 released 27 Jan 2024 * Allow happstack-server 7.9.
README.markdown view
@@ -9,7 +9,7 @@ of markdown is used as a markup language, but reStructuredText, LaTeX, HTML, DocBook, or Emacs Org-mode markup can also be used. Gitit can be configured to display TeX math (using [texmath]) and-highlighted source code (using [highlighting-kate]).+highlighted source code (using [skylighting]). Other features include @@ -20,8 +20,7 @@ * TeX math -* syntax highlighting of source code files and code snippets (using- highlighting-kate)+* syntax highlighting of source code files and code snippets. * caching @@ -35,7 +34,7 @@ [mercurial]: http://mercurial.selenic.com/ [pandoc]: http://pandoc.org [Happstack]: http://happstack.com-[highlighting-kate]: http://johnmacfarlane.net/highlighting-kate/+[skylighting]: https://hackage.haskell.org/package/skylighting [texmath]: http://github.com/jgm/texmath/tree/master Getting started@@ -567,7 +566,7 @@ SetOutputFilter proxy-html ProxyPassReverse / ProxyHTMLURLMap / /wiki/- ProxyHTMLDocType "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.0 Strict//EN' 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'>" XHTML+ ProxyHTMLDocType html5 RequestHeader unset Accept-Encoding </Location>
data/default.conf view
@@ -33,10 +33,7 @@ # suppressed). 'generic' means that gitit will assume that # some form of authentication is in place that directly # sets REMOTE_USER to the name of the authenticated user-# (e.g. mod_auth_cas on apache). 'rpx' means that gitit-# will attempt to log in through https://rpxnow.com.-# This requires that 'rpx-domain', 'rpx-key', and 'base-url'-# be set below, and that 'curl' be in the system path.+# (e.g. mod_auth_cas on apache). # 'github' means that you are redirected to github website and # need to avail gitit to use your credential from there (github name and # email). Your email is used to identify you when you push your wiki data@@ -72,10 +69,8 @@ math: mathjax # specifies how LaTeX math is to be displayed. Possible values-# are MathML, raw, mathjax, and google. If mathml is selected,-# gitit will convert LaTeX math to MathML and link in a script,-# MathMLinHTML.js, that allows the MathML to be seen in Gecko browsers, IE +-# mathplayer, and Opera. In other browsers you may get a jumble of characters.+# are MathML, raw, mathjax, and google.+# If mathml is selected, gitit will convert LaTeX math to MathML. # If raw is selected, the LaTeX math will be displayed as raw LaTeX math. # If mathjax is selected, gitit will link to the remote mathjax script. # If google is selected, the google chart API is called to render the formula@@ -204,12 +199,6 @@ # access-question: What is the code given to you by Ms. X? # access-question-answers: RED DOG, red dog -rpx-domain:-rpx-key:-# Specifies the domain and key of your RPX account. The domain is-# just the prefix of the complete RPX domain, so if your full domain-# is 'https://foo.rpxnow.com/', use 'foo' as the value of rpx-domain.- mail-command: sendmail %s # specifies the command to use to send notification emails. # '%s' will be replaced by the destination email address.@@ -250,8 +239,7 @@ base-url: # the base URL of the wiki, to be used in constructing feed IDs-# and RPX token_urls.-# Set this if use-feed is 'yes' or authentication-method is 'rpx'.+# Set this if use-feed is 'yes'. absolute-urls: no # make wikilinks absolute with respect to the base-url.
data/markup.HTML view
@@ -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
data/markupHelp/HTML view
@@ -45,6 +45,6 @@ </dl> ~~~~~~~~ -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).
− data/static/js/MathMLinHTML.js
@@ -1,76 +0,0 @@-/* -March 19, 2004 MathHTML (c) Peter Jipsen http://www.chapman.edu/~jipsen--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or (at-your option) any later version.-This program is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -(at http://www.gnu.org/copyleft/gpl.html) for more details.-*/--function convertMath(node) {// for Gecko- if (node.nodeType==1) {- var newnode = - document.createElementNS("http://www.w3.org/1998/Math/MathML",- node.nodeName.toLowerCase());- for(var i=0; i < node.attributes.length; i++)- newnode.setAttribute(node.attributes[i].nodeName,- node.attributes[i].nodeValue);- for (var i=0; i<node.childNodes.length; i++) {- var st = node.childNodes[i].nodeValue;- if (st==null || st.slice(0,1)!=" " && st.slice(0,1)!="\n") - newnode.appendChild(convertMath(node.childNodes[i]));- }- return newnode;- }- else return node;-}--function convert() {- var mmlnode = document.getElementsByTagName("math");- var st,str,node,newnode;- for (var i=0; i<mmlnode.length; i++)- if (document.createElementNS!=null)- mmlnode[i].parentNode.replaceChild(convertMath(mmlnode[i]),mmlnode[i]);- else { // convert for IE- str = "";- node = mmlnode[i];- while (node.nodeName!="/MATH") {- st = node.nodeName.toLowerCase();- if (st=="#text") str += node.nodeValue;- else {- str += (st.slice(0,1)=="/" ? "</m:"+st.slice(1) : "<m:"+st);- if (st.slice(0,1)!="/") - for(var j=0; j < node.attributes.length; j++)- if (node.attributes[j].nodeValue!="italic" &&- node.attributes[j].nodeValue!="" &&- node.attributes[j].nodeValue!="inherit" &&- node.attributes[j].nodeValue!=undefined)- str += " "+node.attributes[j].nodeName+"="+- "\""+node.attributes[j].nodeValue+"\"";- str += ">";- }- node = node.nextSibling;- node.parentNode.removeChild(node.previousSibling);- }- str += "</m:math>";- newnode = document.createElement("span");- node.parentNode.replaceChild(newnode,node);- newnode.innerHTML = str;- }-}--if (document.createElementNS==null) {- document.write("<object id=\"mathplayer\"\- classid=\"clsid:32F66A20-7614-11D4-BD11-00104BD3F987\"></object>");- document.write("<?import namespace=\"m\" implementation=\"#mathplayer\"?>");-}-if(typeof window.addEventListener != 'undefined'){- window.addEventListener('load', convert, false);-}-if(typeof window.attachEvent != 'undefined') {- window.attachEvent('onload', convert);-}
data/templates/page.st view
@@ -1,6 +1,5 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html xmlns="http://www.w3.org/1999/xhtml">+<!DOCTYPE html>+<html> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" /> <meta name="viewport" content="width=device-width, initial-scale=1.0">@@ -12,17 +11,17 @@ $if(printable)$ <link href="$base$/css/print.css" rel="stylesheet" media="all" type= "text/css" /> $else$- <link href="$base$/css/custom.css" rel="stylesheet" media="screen, projection" type="text/css" />+ <link href="$base$/css/custom.css" rel="stylesheet" media="screen" type="text/css" /> <link href="$base$/css/print.css" rel="stylesheet" media="print" type= "text/css" /> $endif$- <!--[if IE]><link href="$base$/css/ie.css" rel="stylesheet" media="screen, projection" type="text/css" /><![endif]-->+ <link href="$base$/css/ie.css" rel="stylesheet" media="screen" type="text/css" /> </head> <body> <div id="doc3" class="yui-t1"> <div id="yui-main"> <div id="maincol" class="yui-b"> $userbox()$- $tabs$ + $tabs$ $content()$ $footer()$ </div>
gitit.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: gitit-version: 0.15.1.2+version: 0.16 build-type: Simple synopsis: Wiki using happstack, git or darcs, and pandoc. description: Gitit is a wiki backed by a git, darcs, or mercurial@@ -54,7 +54,7 @@ data/static/js/uploadForm.js, data/static/js/jquery-ui-combined-1.6rc2.min.js, data/static/js/jquery.hotkeys-0.7.9.min.js, data/static/js/preview.js, data/static/js/search.js,- data/static/js/MathMLinHTML.js, data/static/js/footnotes.js,+ data/static/js/footnotes.js, data/static/robots.txt, data/s5/default/blank.gif, data/s5/default/bodybg.gif,@@ -97,7 +97,7 @@ Source-repository head type: git- location: git://github.com/jgm/gitit.git+ location: https://github.com/jgm/gitit.git Flag plugins description: Compile in support for plugins. This will increase the size of@@ -115,7 +115,7 @@ Network.Gitit.Util, Network.Gitit.Server Network.Gitit.Cache, Network.Gitit.State, Network.Gitit.Handlers,- Network.Gitit.Plugins, Network.Gitit.Rpxnow,+ Network.Gitit.Plugins, Network.Gitit.Page, Network.Gitit.Feed, Network.Gitit.Compat.Except, Paths_gitit@@ -134,7 +134,7 @@ mtl, old-time, temporary,- pandoc >= 2.9 && < 2.20 || >= 3.0 && < 3.2,+ pandoc >= 2.9 && < 2.20 || >= 3.0 && < 3.11, pandoc-types >= 1.20 && < 1.24, skylighting >= 0.8.2.3 && < 0.15, bytestring,@@ -147,8 +147,8 @@ old-locale, time, recaptcha >= 0.1,- filestore >= 0.6.5 && < 0.7,- zlib >= 0.5 && < 0.7,+ filestore >= 0.6.5.1 && < 0.7,+ zlib >= 0.5 && < 0.8, url >= 2.1, happstack-server >= 7.5 && < 7.10, base64-bytestring >= 0.1,@@ -158,18 +158,18 @@ xml-types >= 0.3, xss-sanitize >= 0.3 && < 0.4, tagsoup >= 0.13 && < 0.15,- blaze-html >= 0.4 && < 0.10,+ blaze-html >= 0.5 && < 0.10, json >= 0.4 && < 0.12, uri-bytestring >= 0.2.3.3, split,- hoauth2 >= 2.3.0 && < 2.11,- xml-conduit >= 1.5 && < 1.10,+ hoauth2 >= 2.3.0 && < 2.16,+ xml-conduit >= 1.5 && < 1.11, http-conduit >= 2.1.6 && < 2.4,- http-client-tls >= 0.2.2 && < 0.4,- aeson >= 0.7 && < 2.3,+ http-client-tls >= 0.2.2 && < 0.5,+ aeson >= 0.7 && < 2.4, uuid >= 1.3 && < 1.4, network-uri >= 2.6,- network >= 2.6 && < 3.2,+ network >= 2.6 && < 3.3, network-bsd >= 2.8.1 && < 2.9, doctemplates >= 0.7.1 if flag(plugins)@@ -184,7 +184,7 @@ Executable gitit hs-source-dirs: . main-is: gitit.hs- build-depends: base >= 4.9 && < 5,+ build-depends: base >= 4.15 && < 5, gitit, mtl, hslogger,@@ -195,6 +195,7 @@ network-uri >= 2.6, network >= 2.6 other-modules: Paths_gitit+ autogen-modules: Paths_gitit default-extensions: CPP default-language: Haskell2010 ghc-options: -Wall -threaded -fno-warn-unused-do-bind
gitit.hs view
@@ -105,7 +105,7 @@ -- start the server simpleHTTPWithSocket sock serverConf $ msum [ wiki conf- , dir "_reloadTemplates" reloadTemplates+ , dir "_reloadTemplates" (reloadTemplates conf) ] data ExitOpt
src/Network/Gitit.hs view
@@ -210,9 +210,9 @@ ] -- | Recompiles the gitit templates.-reloadTemplates :: ServerPart Response-reloadTemplates = do- liftIO recompilePageTemplate+reloadTemplates :: Config -> ServerPart Response+reloadTemplates cfg = do+ liftIO $ recompilePageTemplate cfg ok $ toResponse "Page templates have been recompiled." -- | Converts a gitit Handler into a standard happstack ServerPart.
src/Network/Gitit/Authentication.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>, Henry Laxen <nadine.and.henry@pobox.com>@@ -24,7 +25,6 @@ module Network.Gitit.Authentication ( loginUserForm , formAuthHandlers , httpAuthHandlers- , rpxAuthHandlers , githubAuthHandlers) where import Network.Gitit.State@@ -35,24 +35,28 @@ 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 (unless, liftM) import Control.Monad.Trans (liftIO) import System.Exit import System.Log.Logger (logM, Priority(..)) import Data.Char (isAlphaNum, isAlpha) import qualified Data.Map as M import Data.List (stripPrefix)-import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)+import Data.Maybe (isJust, fromJust, fromMaybe) import Network.URL (exportURL, add_param, importURL) import Network.BSD (getHostName) import qualified Text.StringTemplate as T-import Network.HTTP (urlEncodeVars, urlDecode, urlEncode)+import Network.HTTP (urlEncodeVars) import Codec.Binary.UTF8.String (encodeString)+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 import Data.ByteString.UTF8 (toString)-import Network.Gitit.Rpxnow as R -- | 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 +90,33 @@ 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 +137,11 @@ 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 +197,7 @@ (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 +252,61 @@ "" -> 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 +378,29 @@ 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 +427,7 @@ 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 +442,7 @@ 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 +454,8 @@ 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 +463,14 @@ (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 +484,9 @@ 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 +522,15 @@ 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,@@ -508,65 +538,6 @@ pgTitle = "Login failure", pgMessages = msgs }---- Login using RPX (see RPX development docs at https://rpxnow.com/docs)-loginRPXUser :: RPars -- ^ The parameters passed by the RPX callback call (after authentication has taken place- -> Handler-loginRPXUser params = do- cfg <- getConfig- ref <- getReferer- let mtoken = rToken params- if isNothing mtoken- then do- let url = baseUrl cfg ++ "/_login?destination=" ++- fromMaybe ref (rDestination params)- if null (rpxDomain cfg)- then error "rpx-domain is not set."- else do- let rpx = "https://" ++ rpxDomain cfg ++- ".rpxnow.com/openid/v2/signin?token_url=" ++- urlEncode url- see rpx- else do -- We got an answer from RPX, this might also return an exception.- uid' :: Either String R.Identifier <- liftIO $- R.authenticate (rpxKey cfg) $ fromJust mtoken- uid <- case uid' of- 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- -- The 'verifiedEmail' is also unique and is a more readable choice- -- so we use it if present.- let userId = R.userIdentifier uid- let email = prop "verifiedEmail" uid- user <- liftIO $ mkUser (fromMaybe userId email) (fromMaybe "" email) "none"- updateGititState $ \s -> s { users = M.insert userId user (users s) }- key <- newSession (sessionData userId)- addCookie (MaxAge $ sessionTimeout cfg) (mkSessionCookie key)- see $ fromJust $ rDestination params- where- prop pname info = lookup pname $ R.userData info- see url = seeOther (encUrl url) $ toResponse noHtml---- The parameters passed by the RPX callback call.-data RPars = RPars { rToken :: Maybe String- , rDestination :: Maybe String }- deriving Show--instance FromData RPars where- fromData = do- vtoken <- liftM Just (look "token") `mplus` return Nothing- vDestination <- liftM (Just . urlDecode) (look "destination") `mplus`- return Nothing- return RPars { rToken = vtoken- , rDestination = vDestination }--rpxAuthHandlers :: [Handler]-rpxAuthHandlers =- [ dir "_logout" $ method GET >> withData logoutUser- , dir "_login" $ withData loginRPXUser- , dir "_user" currentUser ] -- | Returns username of logged in user or null string if nobody logged in. currentUser :: Handler
src/Network/Gitit/Authentication/Github.hs view
@@ -16,7 +16,11 @@ import qualified Data.ByteString.Lazy as BSL import qualified URI.ByteString as URI import Network.HTTP.Conduit+#if MIN_VERSION_hoauth2(2,15,0)+import Network.OAuth2+#else import Network.OAuth.OAuth2+#endif import Control.Monad (liftM, mplus, mzero) import Data.Maybe import Data.Aeson
src/Network/Gitit/Config.hs view
@@ -28,7 +28,7 @@ import Network.Gitit.Types import Network.Gitit.Server (mimeTypes) import Network.Gitit.Framework-import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers, githubAuthHandlers)+import Network.Gitit.Authentication (formAuthHandlers, httpAuthHandlers, githubAuthHandlers) import Network.Gitit.Util (parsePageType, readFileUTF8) import System.Log.Logger (logM, Priority(..)) import System.IO (hPutStrLn, stderr)@@ -42,7 +42,11 @@ import System.FilePath ((</>)) import Text.Pandoc hiding (ERROR, WARNING, MathJax, MathML, WebTeX, getDataFileName) import qualified Control.Exception as E+#if MIN_VERSION_hoauth2(2,15,0)+import Network.OAuth2 (OAuth2(..))+#else import Network.OAuth.OAuth2 (OAuth2(..))+#endif import URI.ByteString (parseURI, laxURIParserOptions) import qualified Data.ByteString.Char8 as BS import Network.Gitit.Compat.Except@@ -162,8 +166,6 @@ cfUseRecaptcha <- get "DEFAULT" "use-recaptcha" >>= readBool cfRecaptchaPublicKey <- get "DEFAULT" "recaptcha-public-key" cfRecaptchaPrivateKey <- get "DEFAULT" "recaptcha-private-key"- cfRPXDomain <- get "DEFAULT" "rpx-domain"- cfRPXKey <- get "DEFAULT" "rpx-key" cfCompressResponses <- get "DEFAULT" "compress-responses" >>= readBool cfUseCache <- get "DEFAULT" "use-cache" >>= readBool cfCacheDir <- get "DEFAULT" "cache-dir"@@ -195,8 +197,6 @@ "darcs" -> pure Darcs "mercurial" -> pure Mercurial x -> throwError $ "Unknown repository type: " ++ x- when (authMethod == "rpx" && cfRPXDomain == "") $- liftIO $ logM "gitit" WARNING "rpx-domain is not set" ghConfig <- extractGithubConfig cfgmap @@ -219,7 +219,6 @@ "form" -> withUserFromSession "github" -> withUserFromSession "http" -> withUserFromHTTPAuth- "rpx" -> withUserFromSession _ -> id , requireAuthentication = case map toLower cfRequireAuthentication of "none" -> Never@@ -231,7 +230,6 @@ "form" -> msum $ formAuthHandlers cfDisableRegistration "github" -> msum $ githubAuthHandlers ghConfig "http" -> msum httpAuthHandlers- "rpx" -> msum rpxAuthHandlers _ -> mzero , userFile = cfUserFile , sessionTimeout = cfSessionTimeout * 60 -- convert minutes -> seconds@@ -264,8 +262,6 @@ , useRecaptcha = cfUseRecaptcha , recaptchaPublicKey = cfRecaptchaPublicKey , recaptchaPrivateKey = cfRecaptchaPrivateKey- , rpxDomain = cfRPXDomain- , rpxKey = cfRPXKey , compressResponses = cfCompressResponses , useCache = cfUseCache , cacheDir = cfCacheDir
src/Network/Gitit/ContentTransformer.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>, Anton van Straaten <anton@appsolutions.com>@@ -76,7 +77,6 @@ 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 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.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 @@ contentsToPage >>= pageToWikiPandoc >>= pandocToHtml >>=- return . toResponse . renderHtmlFragment+ return . toResponse . renderHtml -- | Applies pre-commit plugins to raw page source, possibly -- modifying it.@@ -336,6 +335,8 @@ , 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: --@@ -362,7 +363,7 @@ -- the redirect parameter set to @\"yes\"@. -- -- 2. If the @redirect@ parameter is set to \"yes\", then redirect to the--- destination specificed in the metadata. This uses a client-side (meta+-- destination specified in the metadata. This uses a client-side (meta -- refresh + javascript backup) redirect to make sure the referer is set to -- this URL. --@@ -378,56 +379,51 @@ 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 <a href=\""- , url- , "?redirect=no\" title=\"Go to original page\">"- , html- , "</a>"+ 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 <a href=\""- , url'- , "\" title=\"Continue to destination\">"- , html'- , "</a>, but as you were already redirected from <a href=\""- , url- , "?redirect=no\" title=\"Go to original page\">"- , html- , "</a>"+ 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 <a href=\""- , url'- , "\" title=\"Continue to destination\">"- , html'- , "</a>."+ 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 @@ , urlForPage (pageName page) , "?redirect=yes" ]- lift $ seeOther url' $ withBody $ concat- [ "<!doctype html><html><head><title>307 Redirect"- , "</title></head><body><p>You are being <a href=\""- , stringToHtmlString url'- , "\">redirected</a>.</body></p></html>"+ 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- [ "<!doctype html><html><head><title>Redirecting to "- , html'- , "</title><meta http-equiv=\"refresh\" contents=\"0; url="- , url'- , "\" /><script type=\"text/javascript\">window.location=\""- , url'- , "\"</script></head><body><p>Redirecting to <a href=\""- , url'- , "\">"- , html'- , "</a>...</p></body></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 @@ 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@@ -520,7 +515,11 @@ MathJax u -> Pandoc.MathJax $ T.pack u RawTeX -> Pandoc.PlainMath , writerTableOfContents = toc+#if MIN_VERSION_pandoc(3,8,0)+ , writerHighlightMethod = Skylighting pygments+#else , writerHighlightStyle = Just pygments+#endif , writerExtensions = if bird then enableExtension Ext_literate_haskell $ writerExtensions def@@ -542,8 +541,7 @@ , 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 +605,11 @@ 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@@ -629,7 +627,7 @@ conf <- lift getConfig updateLayout $ \l -> case mathMethod conf of- MathML -> addScripts l ["MathMLinHTML.js"]+ MathML -> l WebTeX _ -> l MathJax u -> addScripts l [u] RawTeX -> l
src/Network/Gitit/Handlers.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2008-9 John MacFarlane <jgm@berkeley.edu> @@ -65,8 +66,6 @@ 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.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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ pgTabs = tabs, pgSelectedTab = HistoryTab, pgTitle = ("Changes to " ++ page)- } $ contents +++ more+ } $ contents <> more showActivity :: Handler showActivity = withData $ \(params :: Params) -> do@@ -406,31 +431,31 @@ 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 @@ -> 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,37 +549,36 @@ 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- MathML -> "MathMLinHTML.js" : pgScripts' MathJax url -> url : pgScripts' _ -> pgScripts' formattedPage defaultPageLayout{@@ -583,17 +610,17 @@ 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 +640,8 @@ 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 +677,7 @@ 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 +713,25 @@ 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 +752,22 @@ 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 +785,9 @@ 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,
src/Network/Gitit/Initialize.hs view
@@ -63,15 +63,13 @@ updateGititState $ \s -> s { sessions = Sessions M.empty , users = users'- , templatesPath = templatesDir conf , renderPage = defaultRenderPage templ , plugins = plugins' } -- | Recompile the page template.-recompilePageTemplate :: IO ()-recompilePageTemplate = do- tempsDir <- queryGititState templatesPath- ct <- compilePageTemplate tempsDir+recompilePageTemplate :: Config -> IO ()+recompilePageTemplate cfg = do+ ct <- compilePageTemplate (templatesDir cfg) updateGititState $ \st -> st{renderPage = defaultRenderPage ct} --- | Compile a master page template named @page.st@ in the directory specified.
src/Network/Gitit/Layout.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu> @@ -33,9 +35,11 @@ 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 @@ _ -> 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 @@ 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 @@ 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"
− src/Network/Gitit/Rpxnow.hs
@@ -1,75 +0,0 @@--- Modified from Michael Snoyman's BSD3 authenticate-0.0.1--- and http-wget-0.0.1.--- Facilitates authentication with "http://rpxnow.com/".--module Network.Gitit.Rpxnow- ( Identifier (..)- , authenticate- ) where--import Text.JSON-import Data.Maybe (isJust, fromJust)-import System.Process-import System.Exit-import System.IO-import Network.HTTP (urlEncodeVars)---- | Make a post request with parameters to the URL and return a response.-curl :: String -- ^ URL- -> [(String, String)] -- ^ Post parameters- -> IO (Either String String) -- ^ Response body-curl url params = do- (Nothing, Just hout, Just herr, phandle) <- createProcess $ (proc "curl"- [url, "-d", urlEncodeVars params]- ) { std_out = CreatePipe, std_err = CreatePipe }- exitCode <- waitForProcess phandle- case exitCode of- ExitSuccess -> hGetContents hout >>= return . Right- _ -> hGetContents herr >>= return . Left------ | Information received from Rpxnow after a valid login.-data Identifier = Identifier- { userIdentifier :: String- , userData :: [(String, String)]- }- deriving Show---- | Attempt to log a user in.-authenticate :: String -- ^ API key given by RPXNOW.- -> String -- ^ Token passed by client.- -> IO (Either String Identifier)-authenticate apiKey token = do- body <- curl- "https://rpxnow.com/api/v2/auth_info"- [ ("apiKey", apiKey)- , ("token", token)- ]- case body of- Left s -> return $ Left $ "Unable to connect to rpxnow: " ++ s- Right b ->- case decode b >>= getObject of- Error s -> return $ Left $ "Not a valid JSON response: " ++ s- Ok o ->- case valFromObj "stat" o of- Error _ -> return $ Left "Missing 'stat' field"- Ok "ok" -> return $ resultToEither $ parseProfile o- Ok stat -> return $ Left $ "Login not accepted: " ++ stat--parseProfile :: JSObject JSValue -> Result Identifier-parseProfile v = do- profile <- valFromObj "profile" v >>= getObject- ident <- valFromObj "identifier" profile- let pairs = fromJSObject profile- pairs' = filter (\(k, _) -> k /= "identifier") pairs- pairs'' = map fromJust . filter isJust . map takeString $ pairs'- return $ Identifier ident pairs''--takeString :: (String, JSValue) -> Maybe (String, String)-takeString (k, JSString v) = Just (k, fromJSString v)-takeString _ = Nothing--getObject :: JSValue -> Result (JSObject JSValue)-getObject (JSObject o) = return o-getObject _ = fail "Not an object"
src/Network/Gitit/State.hs view
@@ -39,7 +39,6 @@ gititstate :: IORef GititState gititstate = unsafePerformIO $ newIORef GititState { sessions = undefined , users = undefined- , templatesPath = undefined , renderPage = undefined , plugins = undefined }
src/Network/Gitit/Types.hs view
@@ -70,7 +70,6 @@ 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)@@ -84,7 +83,12 @@ import Network.Gitit.Server import Text.HTML.TagSoup.Entity (lookupEntity) import Data.Char (isSpace)+#if MIN_VERSION_hoauth2(2,15,0)+import Network.OAuth2+#else import Network.OAuth.OAuth2+#endif+import Text.Blaze.Html (Html) data PageType = Markdown | CommonMark@@ -175,9 +179,6 @@ useRecaptcha :: Bool, recaptchaPublicKey :: String, recaptchaPrivateKey :: String,- -- | RPX domain and key- rpxDomain :: String,- rpxKey :: String, -- | Should responses be compressed? compressResponses :: Bool, -- | Should responses be cached?@@ -263,7 +264,6 @@ data GititState = GititState { sessions :: Sessions SessionData, users :: M.Map String User,- templatesPath :: FilePath, renderPage :: PageLayout -> Html -> Handler, plugins :: [Plugin] }