gitit 0.11.1.1 → 0.12

raw patch · 45 files changed

+5584/−5579 lines, 45 filesdep +gititdep ~HTTPdep ~basedep ~hsloggerPVP ok

version bump matches the API change (PVP)

Dependencies added: gitit

Dependency ranges changed: HTTP, base, hslogger, network, url, utf8-string

API changes (from Hackage documentation)

Files

• CHANGES +8/−0
• Network/Gitit.hs +0/−224
• Network/Gitit/Authentication.hs +0/−541
• Network/Gitit/Authentication/Github.hs +0/−128
• Network/Gitit/Cache.hs +0/−87
• Network/Gitit/Compat/Except.hs +0/−36
• Network/Gitit/Config.hs +0/−346
• Network/Gitit/ContentTransformer.hs +0/−757
• Network/Gitit/Export.hs +0/−314
• Network/Gitit/Feed.hs +0/−175
• Network/Gitit/Framework.hs +0/−358
• Network/Gitit/Handlers.hs +0/−815
• Network/Gitit/Initialize.hs +0/−224
• Network/Gitit/Interface.hs +0/−176
• Network/Gitit/Layout.hs +0/−170
• Network/Gitit/Page.hs +0/−201
• Network/Gitit/Plugins.hs +0/−92
• Network/Gitit/Rpxnow.hs +0/−81
• Network/Gitit/Server.hs +0/−63
• Network/Gitit/State.hs +0/−139
• Network/Gitit/Types.hs +0/−489
• Network/Gitit/Util.hs +0/−110
• README.markdown +11/−27
• gitit.cabal +39/−26
• src/Network/Gitit.hs +224/−0
• src/Network/Gitit/Authentication.hs +541/−0
• src/Network/Gitit/Authentication/Github.hs +128/−0
• src/Network/Gitit/Cache.hs +87/−0
• src/Network/Gitit/Compat/Except.hs +36/−0
• src/Network/Gitit/Config.hs +346/−0
• src/Network/Gitit/ContentTransformer.hs +757/−0
• src/Network/Gitit/Export.hs +314/−0
• src/Network/Gitit/Feed.hs +175/−0
• src/Network/Gitit/Framework.hs +358/−0
• src/Network/Gitit/Handlers.hs +815/−0
• src/Network/Gitit/Initialize.hs +224/−0
• src/Network/Gitit/Interface.hs +176/−0
• src/Network/Gitit/Layout.hs +170/−0
• src/Network/Gitit/Page.hs +201/−0
• src/Network/Gitit/Plugins.hs +92/−0
• src/Network/Gitit/Rpxnow.hs +81/−0
• src/Network/Gitit/Server.hs +63/−0
• src/Network/Gitit/State.hs +139/−0
• src/Network/Gitit/Types.hs +489/−0
• src/Network/Gitit/Util.hs +110/−0

@@ -1,3 +1,11 @@+Version 0.12 released 19 Aug 2015++  * Export all modules.+  * Make executable builds depend on the library in cabal file.+  * Moved library files to src directory.+  * Added stack.yaml.+  * Updated README with stack install instructions.+ Version 0.11.1.1 released 14 Aug 2015    * Fixed Network.Gitit.Initialize so it compiles with older pandoc (#506).

@@ -1,224 +0,0 @@-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- | Functions for embedding a gitit wiki into a Happstack application.--The following is a minimal standalone wiki program:--> import Network.Gitit-> import Happstack.Server.SimpleHTTP->-> main = do->   conf <- getDefaultConfig->   createStaticIfMissing conf->   createTemplateIfMissing conf->   createRepoIfMissing conf->   initializeGititState conf->   simpleHTTP nullConf{port = 5001} $ wiki conf--Here is a more complex example, which serves different wikis-under different paths, and uses a custom authentication scheme:--> import Network.Gitit-> import Control.Monad-> import Text.XHtml hiding (dir)-> import Happstack.Server.SimpleHTTP->-> type WikiSpec = (String, FileStoreType, PageType)->-> wikis = [ ("markdownWiki", Git, Markdown)->         , ("latexWiki", Darcs, LaTeX) ]->-> -- custom authentication-> myWithUser :: Handler -> Handler-> myWithUser handler = do->   -- replace the following with a function that retrieves->   -- the logged in user for your happstack app:->   user <- return "testuser"->   localRq (setHeader "REMOTE_USER" user) handler->-> myAuthHandler = msum->   [ dir "_login"  $ seeOther "/your/login/url"  $ toResponse ()->   , dir "_logout" $ seeOther "/your/logout/url" $ toResponse () ]->-> handlerFor :: Config -> WikiSpec -> ServerPart Response-> handlerFor conf (path', fstype, pagetype) = dir path' $->   wiki conf{ repositoryPath = path'->            , repositoryType = fstype->            , defaultPageType = pagetype}->-> indexPage :: ServerPart Response-> indexPage = ok $ toResponse $->   (p << "Wiki index") +++->   ulist << map (\(path', _, _) -> li << hotlink (path' ++ "/") << path') wikis->-> main = do->   conf <- getDefaultConfig->   let conf' = conf{authHandler = myAuthHandler, withUser = myWithUser}->   forM wikis $ \(path', fstype, pagetype) -> do->     let conf'' = conf'{ repositoryPath = path'->                       , repositoryType = fstype->                       , defaultPageType = pagetype->                       }->     createStaticIfMissing conf''->     createRepoIfMissing conf''->   createTemplateIfMissing conf'->   initializeGititState conf'->   simpleHTTP nullConf{port = 5001} $->     (nullDir >> indexPage) `mplus` msum (map (handlerFor conf') wikis)---}--module Network.Gitit (-                     -- * Wiki handlers-                       wiki-                     , reloadTemplates-                     , runHandler-                     -- * Initialization-                     , module Network.Gitit.Initialize-                     -- * Configuration-                     , module Network.Gitit.Config-                     , loginUserForm-                     -- * Types-                     , module Network.Gitit.Types-                     -- * Tools for building handlers-                     , module Network.Gitit.Framework-                     , module Network.Gitit.Layout-                     , module Network.Gitit.ContentTransformer-                     , module Network.Gitit.Page-                     , getFileStore-                     , getUser-                     , getConfig-                     , queryGititState-                     , updateGititState-                     )-where-import Network.Gitit.Types-import Network.Gitit.Server-import Network.Gitit.Framework-import Network.Gitit.Handlers-import Network.Gitit.Initialize-import Network.Gitit.Config-import Network.Gitit.Layout-import Network.Gitit.State-        (getFileStore, getUser, getConfig, queryGititState, updateGititState)-import Network.Gitit.ContentTransformer-import Network.Gitit.Page-import Network.Gitit.Authentication (loginUserForm)-import Paths_gitit (getDataFileName)-import Control.Monad.Reader-import Prelude hiding (readFile)-import qualified Data.ByteString.Char8 as B-import System.FilePath ((</>))-import System.Directory (getTemporaryDirectory)-import Safe---- | Happstack handler for a gitit wiki.-wiki :: Config -> ServerPart Response-wiki conf = do-  tempDir <- liftIO getTemporaryDirectory-  let maxSize = fromIntegral $ maxUploadSize conf-  decodeBody $ defaultBodyPolicy tempDir maxSize maxSize maxSize-  let static = staticDir conf-  defaultStatic <- liftIO $ getDataFileName $ "data" </> "static"-  -- if file not found in staticDir, we check also in the data/static-  -- directory, which contains defaults-  let staticHandler = withExpiresHeaders $-        serveDirectory' static `mplus` serveDirectory' defaultStatic-  let debugHandler' = msum [debugHandler | debugMode conf]-  let handlers = debugHandler' `mplus` authHandler conf `mplus`-                 authenticate ForRead (msum wikiHandlers)-  let fs = filestoreFromConfig conf-  let ws = WikiState { wikiConfig = conf, wikiFileStore = fs }-  if compressResponses conf-     then compressedResponseFilter-     else return ""-  staticHandler `mplus` runHandler ws (withUser conf handlers)---- | Like 'serveDirectory', but if file is not found, fail instead of--- returning a 404 error.-serveDirectory' :: FilePath -> ServerPart Response-serveDirectory' p = do-  rq <- askRq-  resp' <- serveDirectory EnableBrowsing [] p-  if rsCode resp' == 404 || lastNote "fileServeStrict'" (rqUri rq) == '/'-     then mzero  -- pass through if not found or directory index-     else-       -- turn off compresion filter unless it's text-       case getHeader "Content-Type" resp' of-            Just ct | B.pack "text/" `B.isPrefixOf` ct -> return resp'-            _ -> ignoreFilters >> return resp'--wikiHandlers :: [Handler]-wikiHandlers =-  [ -- redirect /wiki -> /wiki/ when gitit is being served at /wiki-    -- so that relative wikilinks on the page will work properly:-    guardBareBase >> getWikiBase >>= \b -> movedPermanently (b ++ "/") (toResponse ())-  , dir "_activity" showActivity-  , dir "_go"       goToPage-  , method GET >> dir "_search"   searchResults-  , dir "_upload"   $  do guard =<< return . uploadsAllowed =<< getConfig-                          msum [ method GET  >> authenticate ForModify uploadForm-                                 , method POST >> authenticate ForModify uploadFile ]-  , dir "_random"   $ method GET  >> randomPage-  , dir "_index"    indexPage-  , dir "_feed"     feedHandler-  , dir "_category" categoryPage-  , dir "_categories" categoryListPage-  , dir "_expire"     expireCache-  , dir "_showraw"  $ msum-      [ showRawPage-      , guardPath isSourceCode >> showFileAsText ]-  , dir "_history"  $ msum-      [ showPageHistory-      , guardPath isSourceCode >> showFileHistory ]-  , dir "_edit" $ authenticate ForModify (unlessNoEdit editPage showPage)-  , dir "_diff" $ msum-      [ showPageDiff-      , guardPath isSourceCode >> showFileDiff ]-  , dir "_discuss" discussPage-  , dir "_delete" $ msum-      [ method GET  >>-          authenticate ForModify (unlessNoDelete confirmDelete showPage)-      , method POST >>-          authenticate ForModify (unlessNoDelete deletePage showPage) ]-  , dir "_preview" preview-  , guardIndex >> indexPage-  , guardCommand "export" >> exportPage-  , method POST >> guardCommand "cancel" >> showPage-  , method POST >> guardCommand "update" >>-      authenticate ForModify (unlessNoEdit updatePage showPage)-  , showPage-  , guardPath isSourceCode >> method GET >> showHighlightedSource-  , handleAny-  , notFound =<< (guardPath isPage >> createPage)-  ]---- | Recompiles the gitit templates.-reloadTemplates :: ServerPart Response-reloadTemplates = do-  liftIO recompilePageTemplate-  ok $ toResponse "Page templates have been recompiled."---- | Converts a gitit Handler into a standard happstack ServerPart.-runHandler :: WikiState -> Handler -> ServerPart Response-runHandler = mapServerPartT . unpackReaderT--unpackReaderT :: s -> UnWebT (ReaderT s IO) a -> UnWebT IO a-unpackReaderT st uw = runReaderT uw st-

@@ -1,541 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,-                   Henry Laxen <nadine.and.henry@pobox.com>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Handlers for registering and authenticating users.--}--module Network.Gitit.Authentication ( loginUserForm-                                    , formAuthHandlers-                                    , httpAuthHandlers-                                    , rpxAuthHandlers-                                    , githubAuthHandlers) where--import Network.Gitit.State-import Network.Gitit.Types-import Network.Gitit.Framework-import Network.Gitit.Layout-import Network.Gitit.Server-import Network.Gitit.Util-import Network.Gitit.Authentication.Github-import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)-import Text.XHtml hiding ( (</>), dir, method, password, rev )-import qualified Text.XHtml as X ( password )-import System.Process (readProcessWithExitCode)-import Control.Monad (unless, liftM, mplus)-import Control.Monad.Trans (liftIO)-import System.Exit-import System.Log.Logger (logM, Priority(..))-import Data.Char (isAlphaNum, isAlpha)-import qualified Data.Map as M-import Text.Pandoc.Shared (substitute)-import Data.Maybe (isJust, fromJust, isNothing, 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 Codec.Binary.UTF8.String (encodeString)-import Data.ByteString.UTF8 (toString)-import Network.Gitit.Rpxnow as R--data ValidationType = Register-                    | ResetPassword-                    deriving (Show,Read)--registerUser :: Params -> Handler-registerUser params = do-  result' <- sharedValidation Register params-  case result' of-    Left errors -> registerForm >>=-          formattedPage defaultPageLayout{-                          pgMessages = errors,-                          pgShowPageTools = False,-                          pgTabs = [],-                          pgTitle = "Register for an account"-                          }-    Right (uname, email, pword) -> do-       user <- liftIO $ mkUser uname email pword-       addUser uname user-       loginUser params{ pUsername = uname,-                         pPassword = pword,-                         pEmail = email }--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]]-  cfg <- getConfig-  let contents = if null (mailCommand cfg)-                    then p << "Sorry, password reset not available."-                    else passwordForm-  formattedPage defaultPageLayout{-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgTitle = "Reset your password" }-                contents--resetPasswordRequest :: Params -> Handler-resetPasswordRequest params = do-  let uname = pUsername params-  mbUser <- getUser uname-  let errors = case mbUser of-        Nothing -> ["Unknown user. Please re-register " ++-                    "or press the Back button to try again."]-        Just u  -> ["Since you did not register with " ++-                   "an email address, we can't reset your password." |-                    null (uEmail u) ]-  if null errors-    then do-      let response =-            p << [ stringToHtml "An email has been sent to "-                 , bold $ stringToHtml . uEmail $ fromJust mbUser-                 , br-                 , stringToHtml-                   "Please click on the enclosed link to reset your password."-                 ]-      sendReregisterEmail (fromJust mbUser)-      formattedPage defaultPageLayout{-                      pgShowPageTools = False,-                      pgTabs = [],-                      pgTitle = "Resetting your password"-                      }-                    response-    else registerForm >>=-         formattedPage defaultPageLayout{-                         pgMessages = errors,-                         pgShowPageTools = False,-                         pgTabs = [],-                         pgTitle = "Register for an account"-                         }--resetLink :: String -> User -> String-resetLink base' user =-  exportURL $  foldl add_param-    (fromJust . importURL $ base' ++ "/_doResetPassword")-    [("username", uUsername user), ("reset_code", take 20 (pHashed (uPassword user)))]--sendReregisterEmail :: User -> GititServerPart ()-sendReregisterEmail user = do-  cfg <- getConfig-  hostname <- liftIO getHostName-  base' <- getWikiBase-  let messageTemplate = T.newSTMP $ resetPasswordMessage cfg-  let filledTemplate = T.render .-                       T.setAttribute "username" (uUsername user) .-                       T.setAttribute "useremail" (uEmail user) .-                       T.setAttribute "hostname" hostname .-                       T.setAttribute "port" (show $ portNumber cfg) .-                       T.setAttribute "resetlink" (resetLink base' user) $-                       messageTemplate-  let (mailcommand:args) = words $ substitute "%s" (uEmail user)-                                   (mailCommand cfg)-  (exitCode, _pOut, pErr) <- liftIO $ readProcessWithExitCode mailcommand args-                                      filledTemplate-  liftIO $ logM "gitit" WARNING $ "Sent reset password email to " ++ uUsername user ++-                         " at " ++ uEmail user-  unless (exitCode == ExitSuccess) $-    liftIO $ logM "gitit" WARNING $ mailcommand ++ " failed. " ++ pErr--validateReset :: Params -> (User -> Handler) -> Handler-validateReset params postValidate = do-  let uname = pUsername params-  user <- getUser uname-  let knownUser = isJust user-  let resetCodeMatches = take 20 (pHashed (uPassword (fromJust user))) ==-                           pResetCode params-  let errors = case (knownUser, resetCodeMatches) of-                     (True, True)   -> []-                     (True, False)  -> ["Your reset code is invalid"]-                     (False, _)     -> ["User " ++-                       renderHtmlFragment (stringToHtml uname) ++-                       " is not known"]-  if null errors-     then postValidate (fromJust user)-     else registerForm >>=-          formattedPage defaultPageLayout{-                          pgMessages = errors,-                          pgShowPageTools = False,-                          pgTabs = [],-                          pgTitle = "Register for an account"-                          }--resetPassword :: Params -> Handler-resetPassword params = validateReset params $ \user ->-  resetPasswordForm (Just user) >>=-  formattedPage defaultPageLayout{-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgTitle = "Reset your registration info"-                  }--doResetPassword :: Params -> Handler-doResetPassword params = validateReset params $ \user -> do-  result' <- sharedValidation ResetPassword params-  case result' of-    Left errors ->-      resetPasswordForm (Just user) >>=-          formattedPage defaultPageLayout{-                          pgMessages = errors,-                          pgShowPageTools = False,-                          pgTabs = [],-                          pgTitle = "Reset your registration info"-                          }-    Right (uname, email, pword) -> do-       user' <- liftIO $ mkUser uname email pword-       adjustUser uname user'-       liftIO $ logM "gitit" WARNING $-            "Successfully reset password and email for " ++ uUsername user'-       loginUser params{ pUsername = uname,-                         pPassword = pword,-                         pEmail = email }--registerForm :: GititServerPart Html-registerForm = sharedForm Nothing--resetPasswordForm :: Maybe User -> GititServerPart Html-resetPasswordForm = sharedForm  -- synonym for now--sharedForm :: Maybe User -> GititServerPart Html-sharedForm mbUser = withData $ \params -> do-  cfg <- getConfig-  dest <- case pDestination params of-                ""  -> getReferer-                x   -> return x-  let accessQ = case mbUser of-            Just _ -> noHtml-            Nothing -> case accessQuestion cfg of-                      Nothing          -> noHtml-                      Just (prompt, _) -> label ! [thefor "accessCode"] << prompt +++ br +++-                                          X.password "accessCode" ! [size "15", intAttr "tabindex" 1]-                                          +++ br-  let captcha = if useRecaptcha cfg-                   then captchaFields (recaptchaPublicKey cfg) Nothing-                   else noHtml-  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-  let submitField = case mbUser of-                      Nothing    -> submit "register" "Register"-                      Just _     -> submit "resetPassword" "Reset Password"--  return $ gui "" ! [identifier "loginForm"] << fieldset <<-            [ accessQ-            , userNameField-            , label ! [thefor "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"]-            , br-            , label ! [thefor "password"]-                    << ("Password (at least 6 characters," ++-                        " including at least one non-letter):")-            , br-            , X.password "password" ! [size "20", intAttr "tabindex" 4]-            , stringToHtml " "-            , br-            , label ! [thefor "password2"] << "Confirm Password:"-            , br-            , X.password "password2" ! [size "20", intAttr "tabindex" 5]-            , stringToHtml " "-            , br-            , captcha-            , textfield "destination" ! [thestyle "display: none;", value dest]-            , submitField ! [intAttr "tabindex" 6]]---sharedValidation :: ValidationType-                 -> Params-                 -> GititServerPart (Either [String] (String,String,String))-sharedValidation validationType params = do-  let isValidUsernameChar c = isAlphaNum c || c == ' '-  let isValidUsername u = length u >= 3 && all isValidUsernameChar u-  let isValidPassword pw = length pw >= 6 && not (all isAlpha pw)-  let accessCode = pAccessCode params-  let uname = pUsername params-  let pword = pPassword params-  let pword2 = pPassword2 params-  let email = pEmail params-  let fakeField = pFullName params-  let recaptcha = pRecaptcha params-  taken <- isUser uname-  cfg <- getConfig-  let optionalTests Register =-          [(taken, "Sorry, that username is already taken.")]-      optionalTests ResetPassword = []-  let isValidAccessCode = case validationType of-        ResetPassword -> True-        Register -> case accessQuestion cfg of-            Nothing           -> True-            Just (_, answers) -> accessCode `elem` answers-  let isValidEmail e = length (filter (=='@') e) == 1-  peer <- liftM (fst . rqPeer) askRq-  captchaResult <--    if useRecaptcha cfg-       then if null (recaptchaChallengeField recaptcha) ||-                 null (recaptchaResponseField recaptcha)-               -- no need to bother captcha.net in this case-               then return $ Left "missing-challenge-or-response"-               else liftIO $ do-                      mbIPaddr <- lookupIPAddr peer-                      let ipaddr = fromMaybe (error $ "Could not find ip address for " ++ peer)-                                   mbIPaddr-                      ipaddr `seq` validateCaptcha (recaptchaPrivateKey cfg)-                              ipaddr (recaptchaChallengeField recaptcha)-                              (recaptchaResponseField recaptcha)-       else return $ Right ()-  let (validCaptcha, captchaError) =-        case captchaResult of-              Right () -> (True, Nothing)-              Left err -> (False, Just err)-  let errors = validate $ optionalTests validationType ++-        [ (not isValidAccessCode, "Incorrect response to access prompt.")-        , (not (isValidUsername uname),-         "Username must be at least 3 charcaters, all letters or digits.")-        , (not (isValidPassword pword),-         "Password must be at least 6 characters, " ++-         "and must contain at least one non-letter.")-        , (not (null email) && not (isValidEmail email),-         "Email address appears invalid.")-        , (pword /= pword2,-        "Password does not match confirmation.")-        , (not validCaptcha,-        "Failed CAPTCHA (" ++ fromJust captchaError ++-        "). Are you really human?")-        , (not (null fakeField), -- fakeField is hidden in CSS (honeypot)-        "You do not seem human enough. If you're sure you are human, " ++-        "try turning off form auto-completion in your browser.")-        ]-  return $ if null errors then Right (uname, email, pword) else Left errors---- user authentication-loginForm :: String -> GititServerPart Html-loginForm dest = do-  cfg <- getConfig-  base' <- getWikiBase-  return $ gui (base' ++ "/_login") ! [identifier "loginForm"] <<-    fieldset <<-      [ label ! [thefor "username"] << "Username "-      , textfield "username" ! [size "15", intAttr "tabindex" 1]-      , stringToHtml " "-      , label ! [thefor "password"] << "Password "-      , X.password "password" ! [size "15", intAttr "tabindex" 2]-      , stringToHtml " "-      , textfield "destination" ! [thestyle "display: none;", value dest]-      , submit "login" "Login" ! [intAttr "tabindex" 3]-      ] +++-    p << [ stringToHtml "If you do not have an account, "-         , anchor ! [href $ 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"] <<-                     "click here to get a new one."-                 ]--loginUserForm :: Handler-loginUserForm = withData $ \params -> do-  dest <- case pDestination params of-                ""  -> getReferer-                x   -> return x-  loginForm dest >>=-    formattedPage defaultPageLayout{ pgShowPageTools = False,-                                     pgTabs = [],-                                     pgTitle = "Login",-                                     pgMessages = pMessages params-                                   }--loginUser :: Params -> Handler-loginUser params = do-  let uname = pUsername params-  let pword = pPassword params-  let destination = pDestination params-  allowed <- authUser uname pword-  cfg <- getConfig-  if allowed-    then do-      key <- newSession (sessionData uname)-      addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))-      seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++-        renderHtmlFragment (stringToHtml uname))-    else-      withMessages ["Invalid username or password."] loginUserForm--logoutUser :: Params -> Handler-logoutUser params = do-  let key = pSessionKey params-  dest <- case pDestination params of-                ""  -> getReferer-                x   -> return x-  case key of-       Just k  -> do-         delSession k-         expireCookie "sid"-       Nothing -> return ()-  seeOther (encUrl dest) $ toResponse "You have been logged out."--registerUserForm :: Handler-registerUserForm = registerForm >>=-    formattedPage defaultPageLayout{-                    pgShowPageTools = False,-                    pgTabs = [],-                    pgTitle = "Register for an account"-                    }--formAuthHandlers :: [Handler]-formAuthHandlers =-  [ dir "_register"  $ method GET >> registerUserForm-  , dir "_register"  $ method POST >> withData registerUser-  , 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-  ]--loginUserHTTP :: Params -> Handler-loginUserHTTP params = do-  base' <- getWikiBase-  let destination = pDestination params `orIfNull` (base' ++ "/")-  seeOther (encUrl destination) $ toResponse ()--logoutUserHTTP :: Handler-logoutUserHTTP = unauthorized $ toResponse ()  -- will this work?--httpAuthHandlers :: [Handler]-httpAuthHandlers =-  [ dir "_logout" logoutUserHTTP-  , dir "_login"  $ withData loginUserHTTP-  , dir "_user" currentUser ]--oauthGithubCallback :: GithubConfig-                   -> GithubCallbackPars                  -- ^ Authentication code gained after authorization-                   -> Handler-oauthGithubCallback ghConfig githubCallbackPars =-  withData $ \(sk :: Maybe SessionKey) ->-      do-        mbSd <- maybe (return Nothing) getSession sk-        mbGititState <- case mbSd of-                          Nothing    -> return Nothing-                          Just sd    -> return $ sessionGithubState sd-        let gititState = fromMaybe (error "No Github state found in session (is it the same domain?)") mbGititState-        mUser <- getGithubUser ghConfig githubCallbackPars gititState-        base' <- getWikiBase-        let destination = base' ++ "/"-        case mUser of-          Right user -> do-                     let userEmail = uEmail user-                     updateGititState $ \s -> s { users = M.insert userEmail user (users s) }-                     addUser (uUsername user) user-                     key <- newSession (sessionData userEmail)-                     cfg <- getConfig-                     addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))-                     seeOther (encUrl destination) $ toResponse ()-          Left err -> do-              liftIO $ logM "gitit" WARNING $ "Login Failed: " ++ ghUserMessage err ++ maybe "" (". Github response" ++) (ghDetails err)-              let url = destination ++ "?message=" ++ ghUserMessage err-              seeOther (encUrl url) $ toResponse ()--githubAuthHandlers :: GithubConfig-                   -> [Handler]-githubAuthHandlers ghConfig =-  [ dir "_logout" $ withData logoutUser-  , dir "_login" $ loginGithubUser $ oAuth2 ghConfig-  , dir "_githubCallback" $ withData $ oauthGithubCallback ghConfig-  , dir "_user" currentUser ]---- 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) (mkCookie "sid" (show 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-currentUser = do-  req <- askRq-  ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)

@@ -1,128 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}--module Network.Gitit.Authentication.Github ( loginGithubUser-                                           , getGithubUser-                                           , GithubCallbackPars-                                           , GithubLoginError-                                           , ghUserMessage-                                           , ghDetails) where--import Network.Gitit.Types-import Network.Gitit.Server-import Network.Gitit.State-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BSL-import Network.HTTP.Conduit-import Network.HTTP.Client.TLS-import Network.OAuth.OAuth2-import Control.Monad (liftM, mplus, mzero)-import Data.Maybe-import Data.Aeson-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding (encodeUtf8)-import Control.Applicative-import Control.Monad.Trans (liftIO)-import Data.UUID (toString)-import Data.UUID.V4 (nextRandom)-import qualified Control.Exception as E-import Prelude--loginGithubUser :: OAuth2 -> Handler-loginGithubUser githubKey = do-  state <- liftIO $ fmap toString nextRandom-  key <- newSession (sessionDataGithubState state)-  cfg <- getConfig-  addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))-  let usingOrg = isJust $ org $ githubAuth cfg-  let scopes = "user:email" ++ if usingOrg then ",read:org" else ""-  let url = authorizationUrl githubKey `appendQueryParam` [("state", BS.pack state), ("scope", BS.pack scopes)]-  seeOther (BS.unpack url) $ toResponse ("redirecting to github" :: String)--data GithubLoginError = GithubLoginError { ghUserMessage :: String-                                         , ghDetails :: Maybe String-                                         }--getGithubUser :: GithubConfig            -- ^ Oauth2 configuration (client secret)-              -> GithubCallbackPars      -- ^ Authentication code gained after authorization-              -> String                  -- ^ Github state, we expect the state we sent in loginGithubUser-              -> GititServerPart (Either GithubLoginError User) -- ^ user email and name (password 'none')-getGithubUser ghConfig githubCallbackPars githubState =-       withManagerSettings tlsManagerSettings getUserInternal-    where-    getUserInternal mgr =-        liftIO $ do-            let (Just state) = rState githubCallbackPars-            if state == githubState-              then do-                let (Just code) = rCode githubCallbackPars-                ifSuccess-                   "No access token found yet"-                   (fetchAccessToken mgr (oAuth2 ghConfig) (sToBS code))-                   (\at -> ifSuccess-                           "User Authentication failed"-                           (userInfo mgr at)-                           (\githubUser -> ifSuccess-                            ("No email for user " ++ unpack (gLogin githubUser) ++ " returned by Github")-                            (mailInfo mgr at)-                            (\githubUserMail -> do-                                       let gitLogin = gLogin githubUser-                                       user <- mkUser (unpack gitLogin)-                                                   (unpack $ email $ head githubUserMail)-                                                   "none"-                                       let mbOrg = org ghConfig-                                       case mbOrg of-                                             Nothing -> return $ Right user-                                             Just githuborg -> ifSuccess-                                                      ("Membership check of user " ++ unpack gitLogin ++  " to "  ++ unpack githuborg ++ " failed")-                                                      (orgInfo gitLogin githuborg mgr at)-                                                      (\_ -> return $ Right user))))-              else-                return $ Left $-                       GithubLoginError ("The state sent to github is not the same as the state received: " ++ state ++ ", but expected sent state: " ++  githubState)-                                        Nothing-    ifSuccess errMsg failableAction successAction  = E.catch-                                                 (do Right outcome <- failableAction-                                                     successAction outcome)-                                                 (\exception -> liftIO $ return $ Left $-                                                                GithubLoginError errMsg-                                                                                 (Just $ show (exception :: E.SomeException)))--data GithubCallbackPars = GithubCallbackPars { rCode :: Maybe String-                                             , rState :: Maybe String }-                          deriving Show--instance FromData GithubCallbackPars where-    fromData = do-         vCode <- liftM Just (look "code") `mplus` return Nothing-         vState <- liftM Just (look "state") `mplus` return Nothing-         return GithubCallbackPars {rCode = vCode, rState = vState}--userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser)-userInfo mgr token = authGetJSON mgr token "https://api.github.com/user"--mailInfo :: Manager -> AccessToken -> IO (OAuth2Result [GithubUserMail])-mailInfo mgr token = authGetJSON mgr token "https://api.github.com/user/emails"--orgInfo  :: Text -> Text -> Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString)-orgInfo gitLogin githubOrg mgr token = do-  let url  = "https://api.github.com/orgs/" `BS.append` encodeUtf8 githubOrg `BS.append` "/members/" `BS.append` encodeUtf8 gitLogin-  authGetBS mgr token url--data GithubUser = GithubUser { gLogin :: Text-                             } deriving (Show, Eq)--instance FromJSON GithubUser where-    parseJSON (Object o) = GithubUser-                           <$> o .: "login"-    parseJSON _ = mzero--data GithubUserMail = GithubUserMail { email :: Text-                             } deriving (Show, Eq)--instance FromJSON GithubUserMail where-    parseJSON (Object o) = GithubUserMail-                           <$> o .: "email"-    parseJSON _ = mzero--sToBS :: String -> BS.ByteString-sToBS = encodeUtf8 . pack

@@ -1,87 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions for maintaining user list and session state.--}--module Network.Gitit.Cache ( expireCachedFile-                           , lookupCache-                           , cacheContents )-where--import qualified Data.ByteString as B (ByteString, readFile, writeFile)-import System.FilePath-import System.Directory (doesFileExist, removeFile, createDirectoryIfMissing, getModificationTime)-import Data.Time.Clock (UTCTime)-#if MIN_VERSION_directory(1,2,0)-#else-import System.Time (ClockTime(..))-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-#endif-import Network.Gitit.State-import Network.Gitit.Types-import Control.Monad-import Control.Monad.Trans (liftIO)-import Text.Pandoc.UTF8 (encodePath)---- | Expire a cached file, identified by its filename in the filestore.--- If there is an associated exported PDF, expire it too.--- Returns () after deleting a file from the cache, fails if no cached file.-expireCachedFile :: String -> GititServerPart ()-expireCachedFile file = do-  cfg <- getConfig-  let target = encodePath $ cacheDir cfg </> file-  exists <- liftIO $ doesFileExist target-  when exists $ liftIO $ do-    liftIO $ removeFile target-    expireCachedPDF target (defaultExtension cfg)--expireCachedPDF :: String -> String -> IO ()-expireCachedPDF file ext = -  when (takeExtension file == "." ++ ext) $ do-    let pdfname = file ++ ".export.pdf"-    exists <- doesFileExist pdfname-    when exists $ removeFile pdfname--lookupCache :: String -> GititServerPart (Maybe (UTCTime, B.ByteString))-lookupCache file = do-  cfg <- getConfig-  let target = encodePath $ cacheDir cfg </> file-  exists <- liftIO $ doesFileExist target-  if exists-     then liftIO $ do-#if MIN_VERSION_directory(1,2,0)-       modtime <- getModificationTime target-#else-       TOD secs _ <- getModificationTime target-       let modtime = posixSecondsToUTCTime $ fromIntegral secs-#endif-       contents <- B.readFile target-       return $ Just (modtime, contents)-     else return Nothing--cacheContents :: String -> B.ByteString -> GititServerPart ()-cacheContents file contents = do-  cfg <- getConfig-  let target = encodePath $ cacheDir cfg </> file-  let targetDir = takeDirectory target-  liftIO $ do-    createDirectoryIfMissing True targetDir-    B.writeFile target contents-    expireCachedPDF target (defaultExtension cfg)

@@ -1,36 +0,0 @@-{-# LANGUAGE CPP #-}-module Network.Gitit.Compat.Except (-                                   ExceptT-                                 , Except-                                 , Error(..)-                                 , runExceptT-                                 , runExcept-                                 , MonadError-                                 , throwError-                                 , catchError )-       where--#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Except--class Error a where-  noMsg  :: a-  strMsg :: String -> a--  noMsg    = strMsg ""-  strMsg _ = noMsg--#else-import Control.Monad.Error-import Control.Monad.Identity (Identity, runIdentity)--type ExceptT = ErrorT--type Except s a = ErrorT s Identity a--runExceptT ::  ExceptT e m a -> m (Either e a)-runExceptT = runErrorT--runExcept :: ExceptT e Identity a -> Either e a-runExcept = runIdentity . runExceptT-#endif

@@ -1,346 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- | Functions for parsing command line options and reading the config file.--}--module Network.Gitit.Config ( getConfigFromFile-                            , getConfigFromFiles-                            , getDefaultConfig-                            , readMimeTypesFile )-where-import Network.Gitit.Types-import Network.Gitit.Server (mimeTypes)-import Network.Gitit.Framework-import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers, githubAuthHandlers)-import Network.Gitit.Util (parsePageType, readFileUTF8)-import System.Log.Logger (logM, Priority(..))-import qualified Data.Map as M-import Data.ConfigFile hiding (readfile)-import Data.List (intercalate)-import Data.Char (toLower, toUpper, isDigit)-import Data.Text (pack)-import Paths_gitit (getDataFileName)-import System.FilePath ((</>))-import Text.Pandoc hiding (MathML, WebTeX, MathJax)-import qualified Control.Exception as E-import Network.OAuth.OAuth2-import qualified Data.ByteString.Char8 as BS-import Network.Gitit.Compat.Except-import Control.Monad-import Control.Monad.Trans--#if MIN_VERSION_pandoc(1,14,0)-import Text.Pandoc.Error (handleError)-#else-handleError :: Pandoc -> Pandoc-handleError = id-#endif--forceEither :: Show e => Either e a -> a-forceEither = either (error . show) id---- | Get configuration from config file.-getConfigFromFile :: FilePath -> IO Config-getConfigFromFile fname = do-  cp <- getDefaultConfigParser-  readfile cp fname >>= extractConfig . forceEither---- | Get configuration from config files.-getConfigFromFiles :: [FilePath] -> IO Config-getConfigFromFiles fnames = do-  config <- getConfigParserFromFiles fnames-  extractConfig config--getConfigParserFromFiles :: [FilePath] ->-                            IO ConfigParser-getConfigParserFromFiles (fname:fnames) = do-  cp <- getConfigParserFromFiles fnames-  config <- readfile cp fname-  return $ forceEither config-getConfigParserFromFiles [] = getDefaultConfigParser---- | A version of readfile that treats the file as UTF-8.-readfile :: MonadError CPError m-          => ConfigParser-          -> FilePath-          -> IO (m ConfigParser)-readfile cp path' = do-  contents <- readFileUTF8 path'-  return $ readstring cp contents--extractConfig :: ConfigParser -> IO Config-extractConfig cp = do-  config' <- runExceptT $ do-      cfRepositoryType <- get cp "DEFAULT" "repository-type"-      cfRepositoryPath <- get cp "DEFAULT" "repository-path"-      cfDefaultPageType <- get cp "DEFAULT" "default-page-type"-      cfDefaultExtension <- get cp "DEFAULT" "default-extension"-      cfMathMethod <- get cp "DEFAULT" "math"-      cfMathjaxScript <- get cp "DEFAULT" "mathjax-script"-      cfShowLHSBirdTracks <- get cp "DEFAULT" "show-lhs-bird-tracks"-      cfRequireAuthentication <- get cp "DEFAULT" "require-authentication"-      cfAuthenticationMethod <- get cp "DEFAULT" "authentication-method"-      cfUserFile <- get cp "DEFAULT" "user-file"-      cfSessionTimeout <- get cp "DEFAULT" "session-timeout"-      cfTemplatesDir <- get cp "DEFAULT" "templates-dir"-      cfLogFile <- get cp "DEFAULT" "log-file"-      cfLogLevel <- get cp "DEFAULT" "log-level"-      cfStaticDir <- get cp "DEFAULT" "static-dir"-      cfPlugins <- get cp "DEFAULT" "plugins"-      cfTableOfContents <- get cp "DEFAULT" "table-of-contents"-      cfMaxUploadSize <- get cp "DEFAULT" "max-upload-size"-      cfMaxPageSize <- get cp "DEFAULT" "max-page-size"-      cfAddress <- get cp "DEFAULT" "address"-      cfPort <- get cp "DEFAULT" "port"-      cfDebugMode <- get cp "DEFAULT" "debug-mode"-      cfFrontPage <- get cp "DEFAULT" "front-page"-      cfNoEdit <- get cp "DEFAULT" "no-edit"-      cfNoDelete <- get cp "DEFAULT" "no-delete"-      cfDefaultSummary <- get cp "DEFAULT" "default-summary"-      cfAccessQuestion <- get cp "DEFAULT" "access-question"-      cfAccessQuestionAnswers <- get cp "DEFAULT" "access-question-answers"-      cfUseRecaptcha <- get cp "DEFAULT" "use-recaptcha"-      cfRecaptchaPublicKey <- get cp "DEFAULT" "recaptcha-public-key"-      cfRecaptchaPrivateKey <- get cp "DEFAULT" "recaptcha-private-key"-      cfRPXDomain <- get cp "DEFAULT" "rpx-domain"-      cfRPXKey <- get cp "DEFAULT" "rpx-key"-      cfCompressResponses <- get cp "DEFAULT" "compress-responses"-      cfUseCache <- get cp "DEFAULT" "use-cache"-      cfCacheDir <- get cp "DEFAULT" "cache-dir"-      cfMimeTypesFile <- get cp "DEFAULT" "mime-types-file"-      cfMailCommand <- get cp "DEFAULT" "mail-command"-      cfResetPasswordMessage <- get cp "DEFAULT" "reset-password-message"-      cfUseFeed <- get cp "DEFAULT" "use-feed"-      cfBaseUrl <- get cp "DEFAULT" "base-url"-      cfAbsoluteUrls <- get cp "DEFAULT" "absolute-urls"-      cfWikiTitle <- get cp "DEFAULT" "wiki-title"-      cfFeedDays <- get cp "DEFAULT" "feed-days"-      cfFeedRefreshTime <- get cp "DEFAULT" "feed-refresh-time"-      cfPDFExport <- get cp "DEFAULT" "pdf-export"-      cfPandocUserData <- get cp "DEFAULT" "pandoc-user-data"-      cfXssSanitize <- get cp "DEFAULT" "xss-sanitize"-      cfRecentActivityDays <- get cp "DEFAULT" "recent-activity-days"-      let (pt, lhs) = parsePageType cfDefaultPageType-      let markupHelpFile = show pt ++ if lhs then "+LHS" else ""-      markupHelpPath <- liftIO $ getDataFileName $ "data" </> "markupHelp" </> markupHelpFile-      markupHelpText <- liftM (writeHtmlString def . handleError .-                            readMarkdown def) $-                            liftIO $ readFileUTF8 markupHelpPath--      mimeMap' <- liftIO $ readMimeTypesFile cfMimeTypesFile-      let authMethod = map toLower cfAuthenticationMethod-      let stripTrailingSlash = reverse . dropWhile (=='/') . reverse-      let repotype' = case map toLower cfRepositoryType of-                        "git"       -> Git-                        "darcs"     -> Darcs-                        "mercurial" -> Mercurial-                        x           -> error $ "Unknown repository type: " ++ x-      when (authMethod == "rpx" && cfRPXDomain == "") $-         liftIO $ logM "gitit" WARNING "rpx-domain is not set"-      ghConfig <- extractGithubConfig cp--      return Config{-          repositoryPath       = cfRepositoryPath-        , repositoryType       = repotype'-        , defaultPageType      = pt-        , defaultExtension     = cfDefaultExtension-        , mathMethod           = case map toLower cfMathMethod of-                                      "jsmath"   -> JsMathScript-                                      "mathml"   -> MathML-                                      "mathjax"  -> MathJax cfMathjaxScript-                                      "google"   -> WebTeX "http://chart.apis.google.com/chart?cht=tx&chl="-                                      _          -> RawTeX-        , defaultLHS           = lhs-        , showLHSBirdTracks    = cfShowLHSBirdTracks-        , withUser             = case authMethod of-                                      "form"     -> withUserFromSession-                                      "github"   -> withUserFromSession-                                      "http"     -> withUserFromHTTPAuth-                                      "rpx"      -> withUserFromSession-                                      _          -> id-        , requireAuthentication = case map toLower cfRequireAuthentication of-                                       "none"    -> Never-                                       "modify"  -> ForModify-                                       "read"    -> ForRead-                                       _         -> ForModify--        , authHandler          = case authMethod of-                                      "form"     -> msum formAuthHandlers-                                      "github"   -> msum $ githubAuthHandlers ghConfig-                                      "http"     -> msum httpAuthHandlers-                                      "rpx"      -> msum rpxAuthHandlers-                                      _          -> mzero-        , userFile             = cfUserFile-        , sessionTimeout       = readNumber "session-timeout" cfSessionTimeout * 60  -- convert minutes -> seconds-        , templatesDir         = cfTemplatesDir-        , logFile              = cfLogFile-        , logLevel             = let levelString = map toUpper cfLogLevel-                                     levels = ["DEBUG", "INFO", "NOTICE", "WARNING", "ERROR",-                                               "CRITICAL", "ALERT", "EMERGENCY"]-                                 in  if levelString `elem` levels-                                        then read levelString-                                        else error $ "Invalid log-level.\nLegal values are: " ++ intercalate ", " levels-        , staticDir            = cfStaticDir-        , pluginModules        = splitCommaList cfPlugins-        , tableOfContents      = cfTableOfContents-        , maxUploadSize        = readSize "max-upload-size" cfMaxUploadSize-        , maxPageSize          = readSize "max-page-size" cfMaxPageSize-        , address              = cfAddress-        , portNumber           = readNumber "port" cfPort-        , debugMode            = cfDebugMode-        , frontPage            = cfFrontPage-        , noEdit               = splitCommaList cfNoEdit-        , noDelete             = splitCommaList cfNoDelete-        , defaultSummary       = cfDefaultSummary-        , accessQuestion       = if null cfAccessQuestion-                                    then Nothing-                                    else Just (cfAccessQuestion, splitCommaList cfAccessQuestionAnswers)-        , useRecaptcha         = cfUseRecaptcha-        , recaptchaPublicKey   = cfRecaptchaPublicKey-        , recaptchaPrivateKey  = cfRecaptchaPrivateKey-        , rpxDomain            = cfRPXDomain-        , rpxKey               = cfRPXKey-        , compressResponses    = cfCompressResponses-        , useCache             = cfUseCache-        , cacheDir             = cfCacheDir-        , mimeMap              = mimeMap'-        , mailCommand          = cfMailCommand-        , resetPasswordMessage = fromQuotedMultiline cfResetPasswordMessage-        , markupHelp           = markupHelpText-        , useFeed              = cfUseFeed-        , baseUrl              = stripTrailingSlash cfBaseUrl-        , useAbsoluteUrls      = cfAbsoluteUrls-        , wikiTitle            = cfWikiTitle-        , feedDays             = readNumber "feed-days" cfFeedDays-        , feedRefreshTime      = readNumber "feed-refresh-time" cfFeedRefreshTime-        , pdfExport            = cfPDFExport-        , pandocUserData       = if null cfPandocUserData-                                    then Nothing-                                    else Just cfPandocUserData-        , xssSanitize          = cfXssSanitize-        , recentActivityDays   = cfRecentActivityDays-        , githubAuth           = ghConfig-        }-  case config' of-        Left (ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e'-        Left e                  -> error (show e)-        Right c                 -> return c--extractGithubConfig ::  (Functor m, MonadError CPError m) => ConfigParser-                    -> m GithubConfig-extractGithubConfig cp = do-      cfOauthClientId <- getGithubProp "oauthClientId"-      cfOauthClientSecret <- getGithubProp "oauthClientSecret"-      cfOauthCallback <- getGithubProp "oauthCallback"-      cfOauthOAuthorizeEndpoint  <- getGithubProp "oauthOAuthorizeEndpoint"-      cfOauthAccessTokenEndpoint <- getGithubProp "oauthAccessTokenEndpoint"-      cfOrg <- if hasGithubProp "github-org"-                 then fmap Just (getGithubProp "github-org")-                 else return Nothing-      let cfgOAuth2 = OAuth2 { oauthClientId =  BS.pack cfOauthClientId-                          , oauthClientSecret =  BS.pack cfOauthClientSecret-                          , oauthCallback = Just $ BS.pack cfOauthCallback-                          , oauthOAuthorizeEndpoint = BS.pack cfOauthOAuthorizeEndpoint-                          , oauthAccessTokenEndpoint = BS.pack cfOauthAccessTokenEndpoint-                          }-      return $ githubConfig cfgOAuth2 $ fmap pack cfOrg-  where getGithubProp = get cp "Github"-        hasGithubProp = has_option cp "Github"--fromQuotedMultiline :: String -> String-fromQuotedMultiline = unlines . map doline . lines . dropWhile (`elem` " \t\n")-  where doline = dropWhile (`elem` " \t") . dropGt-        dropGt ('>':' ':xs) = xs-        dropGt ('>':xs) = xs-        dropGt x = x--readNumber :: (Num a, Read a) => String -> String -> a-readNumber _   x | all isDigit x = read x-readNumber opt _ = error $ opt ++ " must be a number."--readSize :: (Num a, Read a) => String -> String -> a-readSize opt x =-  case reverse x of-       ('K':_) -> readNumber opt (init x) * 1000-       ('M':_) -> readNumber opt (init x) * 1000000-       ('G':_) -> readNumber opt (init x) * 1000000000-       _       -> readNumber opt x--splitCommaList :: String -> [String]-splitCommaList l =-  let (first,rest) = break (== ',') l-      first' = lrStrip first-  in case rest of-         []     -> if null first' then [] else [first']-         (_:rs) -> first' : splitCommaList rs--lrStrip :: String -> String-lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace-    where isWhitespace = (`elem` " \t\n")--getDefaultConfigParser :: IO ConfigParser-getDefaultConfigParser = do-  cp <- getDataFileName "data/default.conf" >>= readfile emptyCP-  return $ forceEither cp---- | Returns the default gitit configuration.-getDefaultConfig :: IO Config-getDefaultConfig = getDefaultConfigParser >>= extractConfig---- | Read a file associating mime types with extensions, and return a--- map from extensions to types. Each line of the file consists of a--- mime type, followed by space, followed by a list of zero or more--- extensions, separated by spaces. Example: text/plain txt text-readMimeTypesFile :: FilePath -> IO (M.Map String String)-readMimeTypesFile f = E.catch-  (liftM (foldr (go . words)  M.empty . lines) $ readFileUTF8 f)-  handleMimeTypesFileNotFound-     where go []     m = m  -- skip blank lines-           go (x:xs) m = foldr (`M.insert` x) m xs-           handleMimeTypesFileNotFound (e :: E.SomeException) = do-             logM "gitit" WARNING $ "Could not read mime types file: " ++-               f ++ "\n" ++ show e ++ "\n" ++ "Using defaults instead."-             return mimeTypes--{---- | Ready collection of common mime types. (Copied from--- Happstack.Server.HTTP.FileServe.)-mimeTypes :: M.Map String String-mimeTypes = M.fromList-        [("xml","application/xml")-        ,("xsl","application/xml")-        ,("js","text/javascript")-        ,("html","text/html")-        ,("htm","text/html")-        ,("css","text/css")-        ,("gif","image/gif")-        ,("jpg","image/jpeg")-        ,("png","image/png")-        ,("txt","text/plain")-        ,("doc","application/msword")-        ,("exe","application/octet-stream")-        ,("pdf","application/pdf")-        ,("zip","application/zip")-        ,("gz","application/x-gzip")-        ,("ps","application/postscript")-        ,("rtf","application/rtf")-        ,("wav","application/x-wav")-        ,("hs","text/plain")]--}

@@ -1,757 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,-Anton van Straaten <anton@appsolutions.com>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions for content conversion.--}--module Network.Gitit.ContentTransformer-  (-  -- * ContentTransformer runners-    runPageTransformer-  , runFileTransformer-  -- * Gitit responders-  , showRawPage-  , showFileAsText-  , showPage-  , exportPage-  , showHighlightedSource-  , showFile-  , preview-  , applyPreCommitPlugins-  -- * Cache support for transformers-  , cacheHtml-  , cachedHtml-  -- * Content retrieval combinators-  , rawContents-  -- * Response-generating combinators-  , textResponse-  , mimeFileResponse-  , mimeResponse-  , exportPandoc-  , applyWikiTemplate-  -- * Content-type transformation combinators-  , pageToWikiPandoc-  , pageToPandoc-  , pandocToHtml-  , highlightSource-  -- * Content or context augmentation combinators-  , applyPageTransforms-  , wikiDivify-  , addPageTitleToPandoc-  , addMathSupport-  , addScripts-  -- * ContentTransformer context API-  , getFileName-  , getPageName-  , getLayout-  , getParams-  , getCacheable-  -- * Pandoc and wiki content conversion support-  , inlinesToURL-  , inlinesToString-  )-where--import qualified Control.Exception as E-import Control.Monad.State-import Control.Monad.Reader (ask)-import Data.Foldable (traverse_)-import Data.List (stripPrefix)-import Data.Maybe (isNothing, mapMaybe)-import Network.Gitit.Cache (lookupCache, cacheContents)-import Network.Gitit.Export (exportFormats)-import Network.Gitit.Framework hiding (uriPath)-import Network.Gitit.Layout-import Network.Gitit.Page (stringToPage)-import Network.Gitit.Server-import Network.Gitit.State-import Network.Gitit.Types-import Network.HTTP (urlDecode)-import Network.URI (isUnescapedInURI)-import Network.URL (encString)-import System.FilePath-import qualified Text.Pandoc.Builder as B-import Text.HTML.SanitizeXSS (sanitizeBalance)-import Text.Highlighting.Kate-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 qualified Data.Text as T-import qualified Data.Set as Set-import qualified Data.ByteString as S (concat)-import qualified Data.ByteString.Char8 as SC (unpack)-import qualified Data.ByteString.Lazy as L (toChunks, fromChunks)-import qualified Data.FileStore as FS-import qualified Text.Pandoc as Pandoc-import Text.URI (parseURI, URI(..), uriQueryItems)--#if MIN_VERSION_pandoc(1,14,0)-import Text.Pandoc.Error (handleError)-#else-handleError :: Pandoc -> Pandoc-handleError = id-#endif------ ContentTransformer runners-----runPageTransformer :: ToMessage a-               => ContentTransformer a-               -> GititServerPart a-runPageTransformer xform = withData $ \params -> do-  page <- getPage-  cfg <- getConfig-  evalStateT xform  Context{ ctxFile = pathForPage page (defaultExtension cfg)-                           , ctxLayout = defaultPageLayout{-                                             pgPageName = page-                                           , pgTitle = page-                                           , pgPrintable = pPrintable params-                                           , pgMessages = pMessages params-                                           , pgRevision = pRevision params-                                           , pgLinkToFeed = useFeed cfg }-                           , ctxCacheable = True-                           , ctxTOC = tableOfContents cfg-                           , ctxBirdTracks = showLHSBirdTracks cfg-                           , ctxCategories = []-                           , ctxMeta = [] }--runFileTransformer :: ToMessage a-               => ContentTransformer a-               -> GititServerPart a-runFileTransformer xform = withData $ \params -> do-  page <- getPage-  cfg <- getConfig-  evalStateT xform  Context{ ctxFile = id page-                           , ctxLayout = defaultPageLayout{-                                             pgPageName = page-                                           , pgTitle = page-                                           , pgPrintable = pPrintable params-                                           , pgMessages = pMessages params-                                           , pgRevision = pRevision params-                                           , pgLinkToFeed = useFeed cfg }-                           , ctxCacheable = True-                           , ctxTOC = tableOfContents cfg-                           , ctxBirdTracks = showLHSBirdTracks cfg-                           , ctxCategories = []-                           , ctxMeta = [] }---- | Converts a @ContentTransformer@ into a @GititServerPart@;--- specialized to wiki pages.--- runPageTransformer :: ToMessage a---                    => ContentTransformer a---                    -> GititServerPart a--- runPageTransformer = runTransformer pathForPage---- | Converts a @ContentTransformer@ into a @GititServerPart@;--- specialized to non-pages.--- runFileTransformer :: ToMessage a---                    => ContentTransformer a---                    -> GititServerPart a--- runFileTransformer = runTransformer id------- Gitit responders------- | Responds with raw page source.-showRawPage :: Handler-showRawPage = runPageTransformer rawTextResponse---- | Responds with raw source (for non-pages such as source--- code files).-showFileAsText :: Handler-showFileAsText = runFileTransformer rawTextResponse---- | Responds with rendered wiki page.-showPage :: Handler-showPage = runPageTransformer htmlViaPandoc---- | Responds with page exported into selected format.-exportPage :: Handler-exportPage = runPageTransformer exportViaPandoc---- | Responds with highlighted source code.-showHighlightedSource :: Handler-showHighlightedSource = runFileTransformer highlightRawSource---- | Responds with non-highlighted source code.-showFile :: Handler-showFile = runFileTransformer (rawContents >>= mimeFileResponse)---- | Responds with rendered page derived from form data.-preview :: Handler-preview = runPageTransformer $-          liftM (filter (/= '\r') . pRaw) getParams >>=-          contentsToPage >>=-          pageToWikiPandoc >>=-          pandocToHtml >>=-          return . toResponse . renderHtmlFragment---- | Applies pre-commit plugins to raw page source, possibly--- modifying it.-applyPreCommitPlugins :: String -> GititServerPart String-applyPreCommitPlugins = runPageTransformer . applyPreCommitTransforms------- Top level, composed transformers------- | Responds with raw source.-rawTextResponse :: ContentTransformer Response-rawTextResponse = rawContents >>= textResponse---- | Responds with a wiki page in the format specified--- by the @format@ parameter.-exportViaPandoc :: ContentTransformer Response-exportViaPandoc = rawContents >>=-                  maybe mzero return >>=-                  contentsToPage >>=-                  pageToWikiPandoc >>=-                  exportPandoc---- | Responds with a wiki page. Uses the cache when--- possible and caches the rendered page when appropriate.-htmlViaPandoc :: ContentTransformer Response-htmlViaPandoc = cachedHtml `mplus`-                  (rawContents >>=-                   maybe mzero return >>=-                   contentsToPage >>=-                   handleRedirects >>=-                   either return-                     (pageToWikiPandoc >=>-                      addMathSupport >=>-                      pandocToHtml >=>-                      wikiDivify >=>-                      applyWikiTemplate >=>-                      cacheHtml))---- | Responds with highlighted source code in a wiki--- page template.  Uses the cache when possible and--- caches the rendered page when appropriate.-highlightRawSource :: ContentTransformer Response-highlightRawSource =-  cachedHtml `mplus`-    (updateLayout (\l -> l { pgTabs = [ViewTab,HistoryTab] }) >>-     rawContents >>=-     highlightSource >>=-     applyWikiTemplate >>=-     cacheHtml)------- Cache support for transformers------- | Caches a response (actually just the response body) on disk,--- unless the context indicates that the page is not cacheable.-cacheHtml :: Response -> ContentTransformer Response-cacheHtml resp' = do-  params <- getParams-  file <- getFileName-  cacheable <- getCacheable-  cfg <- lift getConfig-  when (useCache cfg && cacheable && isNothing (pRevision params) && not (pPrintable params)) $-    lift $ cacheContents file $ S.concat $ L.toChunks $ rsBody resp'-  return resp'---- | Returns cached page if available, otherwise mzero.-cachedHtml :: ContentTransformer Response-cachedHtml = do-  file <- getFileName-  params <- getParams-  cfg <- lift getConfig-  if useCache cfg && not (pPrintable params) && isNothing (pRevision params)-     then do mbCached <- lift $ lookupCache file-             let emptyResponse = setContentType "text/html; charset=utf-8" . toResponse $ ()-             maybe mzero (\(_modtime, contents) -> lift . ok $ emptyResponse{rsBody = L.fromChunks [contents]}) mbCached-     else mzero------- Content retrieval combinators------- | Returns raw file contents.-rawContents :: ContentTransformer (Maybe String)-rawContents = do-  params <- getParams-  file <- getFileName-  fs <- lift getFileStore-  let rev = pRevision params-  liftIO $ E.catch (liftM Just $ FS.retrieve fs file rev)-               (\e -> if e == FS.NotFound then return Nothing else E.throwIO e)------- Response-generating combinators------- | Converts raw contents to a text/plain response.-textResponse :: Maybe String -> ContentTransformer Response-textResponse Nothing  = mzero  -- fail quietly if file not found-textResponse (Just c) = mimeResponse c "text/plain; charset=utf-8"---- | Converts raw contents to a response that is appropriate with--- a mime type derived from the page's extension.-mimeFileResponse :: Maybe String -> ContentTransformer Response-mimeFileResponse Nothing = error "Unable to retrieve file contents."-mimeFileResponse (Just c) =-  mimeResponse c =<< lift . getMimeTypeForExtension . takeExtension =<< getFileName--mimeResponse :: Monad m-             => String        -- ^ Raw contents for response body-             -> String        -- ^ Mime type-             -> m Response-mimeResponse c mimeType =-  return . setContentType mimeType . toResponse $ c---- | Converts Pandoc to response using format specified in parameters.-exportPandoc :: Pandoc -> ContentTransformer Response-exportPandoc doc = do-  params <- getParams-  page <- getPageName-  cfg <- lift getConfig-  let format = pFormat params-  case lookup format (exportFormats cfg) of-       Nothing     -> error $ "Unknown export format: " ++ format-       Just writer -> lift (writer page doc)---- | Adds the sidebar, page tabs, and other elements of the wiki page--- layout to the raw content.-applyWikiTemplate :: Html -> ContentTransformer Response-applyWikiTemplate c = do-  Context { ctxLayout = layout } <- get-  lift $ formattedPage layout c------- Content-type transformation combinators------- | Converts Page to Pandoc, applies page transforms, and adds page--- title.-pageToWikiPandoc :: Page -> ContentTransformer Pandoc-pageToWikiPandoc page' =-  pageToWikiPandoc' page' >>= addPageTitleToPandoc (pageTitle page')--pageToWikiPandoc' :: Page -> ContentTransformer Pandoc-pageToWikiPandoc' = applyPreParseTransforms >=>-                     pageToPandoc >=> applyPageTransforms---- | Converts source text to Pandoc using default page type.-pageToPandoc :: Page -> ContentTransformer Pandoc-pageToPandoc page' = do-  modifyContext $ \ctx -> ctx{ ctxTOC = pageTOC page'-                             , ctxCategories = pageCategories page'-                             , ctxMeta = pageMeta page' }-  return $ readerFor (pageFormat page') (pageLHS page') (pageText page')---- | Detects if the page is a redirect page and handles accordingly. The exact--- behaviour is as follows:------ If the page is /not/ a redirect page (the most common case), then check the--- referer to see if the client came to this page as a result of a redirect--- from another page. If so, then add a notice to the messages to notify the--- user that they were redirected from another page, and provide a link back--- to the original page, with an extra parameter to disable redirection--- (e.g., to allow the original page to be edited).------ If the page /is/ a redirect page, then check the query string for the--- @redirect@ parameter. This can modify the behaviour of the redirect as--- follows:------ 1. If the @redirect@ parameter is unset, then check the referer to see if---    client came to this page as a result of a redirect from another page. If---    so, then do not redirect, and add a notice to the messages explaining---    that this page is a redirect page, that would have redirected to the---    destination given in the metadata (and provide a link thereto), but this---    was stopped because a double-redirect was detected. This is a simple way---    to prevent cyclical redirects and other abuses enabled by redirects.---    redirect to the same page. If the client did /not/ come to this page as---    a result of a redirect, then redirect back to the same page, except with---    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---    refresh + javascript backup) redirect to make sure the referer is set to---    this URL.------ 3. If the @redirect@ parameter is set to \"no\", then do not redirect, but---    add a notice to the messages that this page /would/ have redirected to---    the destination given in the metadata had it not been disabled, and---    provide a link to the destination given in the metadata. This behaviour---    is the @revision@ parameter is present in the query string.-handleRedirects :: Page -> ContentTransformer (Either Response Page)-handleRedirects page = case lookup "redirect" (pageMeta page) of-    Nothing -> isn'tRedirect-    Just destination -> isRedirect destination-  where-    addMessage message = modifyContext $ \context -> context-        { ctxLayout = (ctxLayout context)-            { pgMessages = pgMessages (ctxLayout context) ++ [message]-            }-        }-    redirectedFrom source = do-        (url, html) <- processSource source-        return $ concat-            [ "Redirected from <a href=\""-            , url-            , "?redirect=no\" title=\"Go to original page\">"-            , html-            , "</a>"-            ]-    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>"-            , ", 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>."-            ]-    processSource source = do-        base' <- getWikiBase-        let url = stringToHtmlString $ base' ++ urlForPage source-        let html = stringToHtmlString source-        return (url, html)-    processDestination destination = do-        base' <- getWikiBase-        let (page', fragment) = break (== '#') destination-        let url = stringToHtmlString $ concat-             [ base'-             , urlForPage page'-             , fragment-             ]-        let html = stringToHtmlString page'-        return (url, html)-    getSource = do-        cfg <- lift getConfig-        base' <- getWikiBase-        request <- askRq-        return $ do-            uri <- getHeader "referer" request >>= parseURI . SC.unpack-            let params = uriQueryItems uri-            redirect' <- lookup "redirect" params-            guard $ redirect' == "yes"-            path' <- stripPrefix (base' ++ "/") (uriPath uri)-            let path'' = if null path' then frontPage cfg else urlDecode path'-            guard $ isPage path''-            return path''-    withBody = setContentType "text/html; charset=utf-8" . toResponse-    isn'tRedirect = do-        getSource >>= traverse_ (redirectedFrom >=> addMessage)-        return (Right page)-    isRedirect destination = do-        params <- getParams-        case maybe (pRedirect params) (\_ -> Just False) (pRevision params) of-             Nothing -> do-                source <- getSource-                case source of-                     Just source' -> do-                        doubleRedirect source' destination >>= addMessage-                        return (Right page)-                     Nothing -> fmap Left $ do-                        base' <- getWikiBase-                        let url' = concat-                             [ base'-                             , 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>"-                            ]-             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>"-                    ]-             Just False -> do-                cancelledRedirect destination >>= addMessage-                return (Right page)---- | Converts contents of page file to Page object.-contentsToPage :: String -> ContentTransformer Page-contentsToPage s = do-  cfg <- lift getConfig-  pn <- getPageName-  return $ stringToPage cfg pn s---- | Converts pandoc document to HTML.-pandocToHtml :: Pandoc -> ContentTransformer Html-pandocToHtml pandocContents = do-  base' <- lift getWikiBase-  toc <- liftM ctxTOC get-  bird <- liftM ctxBirdTracks get-  cfg <- lift getConfig-  return $ primHtml $ T.unpack .-           (if xssSanitize cfg then sanitizeBalance else id) . T.pack $-           writeHtmlString def{-                        writerStandalone = True-                      , writerTemplate = "$if(toc)$<div id=\"TOC\">\n$toc$\n</div>\n$endif$\n$body$"-                      , writerHTMLMathMethod =-                            case mathMethod cfg of-                                 MathML -> Pandoc.MathML Nothing-                                 WebTeX u -> Pandoc.WebTeX u-                                 MathJax u -> Pandoc.MathJax u-                                 _      -> JsMath (Just $ base' ++-                                                      "/js/jsMath/easy/load.js")-                      , writerTableOfContents = toc-                      , writerHighlight = True-                      , writerExtensions = if bird-                                              then Set.insert-                                                   Ext_literate_haskell-                                                   $ writerExtensions def-                                              else writerExtensions def-                      -- note: javascript obfuscation gives problems on preview-                      , writerEmailObfuscation = ReferenceObfuscation-                      } pandocContents---- | Returns highlighted source code.-highlightSource :: Maybe String -> ContentTransformer Html-highlightSource Nothing = mzero-highlightSource (Just source) = do-  file <- getFileName-  let formatOpts = defaultFormatOpts { numberLines = True, lineAnchors = True }-  case languagesByExtension $ takeExtension file of-        []    -> mzero-        (l:_) -> return $ primHtml $ Blaze.renderHtml-                        $ formatHtmlBlock formatOpts-                        $! highlightAs l $ filter (/='\r') source------- Plugin combinators-----getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]-getPageTransforms = liftM (mapMaybe pageTransform) $ queryGititState plugins-  where pageTransform (PageTransform x) = Just x-        pageTransform _                 = Nothing--getPreParseTransforms :: ContentTransformer [String -> PluginM String]-getPreParseTransforms = liftM (mapMaybe preParseTransform) $-                          queryGititState plugins-  where preParseTransform (PreParseTransform x) = Just x-        preParseTransform _                     = Nothing--getPreCommitTransforms :: ContentTransformer [String -> PluginM String]-getPreCommitTransforms = liftM (mapMaybe preCommitTransform) $-                          queryGititState plugins-  where preCommitTransform (PreCommitTransform x) = Just x-        preCommitTransform _                      = Nothing---- | @applyTransform a t@ applies the transform @t@ to input @a@.-applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a-applyTransform inp transform = do-  context <- get-  conf <- lift getConfig-  user <- lift getLoggedInUser-  fs <- lift getFileStore-  req <- lift askRq-  let pluginData = PluginData{ pluginConfig = conf-                             , pluginUser = user-                             , pluginRequest = req-                             , pluginFileStore = fs }-  (result', context') <- liftIO $ runPluginM (transform inp) pluginData context-  put context'-  return result'---- | Applies all the page transform plugins to a Pandoc document.-applyPageTransforms :: Pandoc -> ContentTransformer Pandoc-applyPageTransforms c = do-  xforms <- getPageTransforms-  foldM applyTransform c (wikiLinksTransform : xforms)---- | Applies all the pre-parse transform plugins to a Page object.-applyPreParseTransforms :: Page -> ContentTransformer Page-applyPreParseTransforms page' = getPreParseTransforms >>= foldM applyTransform (pageText page') >>=-                                (\t -> return page'{ pageText = t })---- | Applies all the pre-commit transform plugins to a raw string.-applyPreCommitTransforms :: String -> ContentTransformer String-applyPreCommitTransforms c = getPreCommitTransforms >>= foldM applyTransform c------- Content or context augmentation combinators------- | Puts rendered page content into a wikipage div, adding--- categories.-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 htmlCategories = if null categories-                          then noHtml-                          else thediv ! [identifier "categoryList"] << ulist << map categoryLink categories-  return $ thediv ! [identifier "wikipage"] << [c, htmlCategories]---- | Adds page title to a Pandoc document.-addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc-addPageTitleToPandoc title' (Pandoc _ blocks) = do-  updateLayout $ \layout -> layout{ pgTitle = title' }-  return $ if null title'-              then Pandoc nullMeta blocks-              else Pandoc (B.setMeta "title" (B.str title') nullMeta) blocks---- | Adds javascript links for math support.-addMathSupport :: a -> ContentTransformer a-addMathSupport c = do-  conf <- lift getConfig-  updateLayout $ \l ->-    case mathMethod conf of-         JsMathScript -> addScripts l ["jsMath/easy/load.js"]-         MathML       -> addScripts l ["MathMLinHTML.js"]-         WebTeX _     -> l-         MathJax u    -> addScripts l [u]-         RawTeX       -> l-  return c---- | Adds javascripts to page layout.-addScripts :: PageLayout -> [String] -> PageLayout-addScripts layout scriptPaths =-  layout{ pgScripts = scriptPaths ++ pgScripts layout }------- ContentTransformer context API-----getParams :: ContentTransformer Params-getParams = lift (withData return)--getFileName :: ContentTransformer FilePath-getFileName = liftM ctxFile get--getPageName :: ContentTransformer String-getPageName = liftM (pgPageName . ctxLayout) get--getLayout :: ContentTransformer PageLayout-getLayout = liftM ctxLayout get--getCacheable :: ContentTransformer Bool-getCacheable = liftM ctxCacheable get---- | Updates the layout with the result of applying f to the current layout-updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()-updateLayout f = do-  ctx <- get-  let l = ctxLayout ctx-  put ctx { ctxLayout = f l }------- Pandoc and wiki content conversion support-----readerFor :: PageType -> Bool -> String -> Pandoc-readerFor pt lhs =-  let defPS = def{ readerSmart = True-                 , readerExtensions = if lhs-                                         then Set.insert Ext_literate_haskell-                                              $ readerExtensions def-                                         else readerExtensions def-                 , readerParseRaw = True-                 }-  in handleError . case pt of-       RST        -> readRST defPS-       Markdown   -> readMarkdown defPS-#if MIN_VERSION_pandoc(1,14,0)-       CommonMark -> readCommonMark defPS-#else-       CommonMark -> error "CommonMark input requires pandoc 1.14"-#endif-       LaTeX      -> readLaTeX defPS-       HTML       -> readHtml defPS-       Textile    -> readTextile defPS-       Org        -> readOrg defPS-       DocBook    -> readDocBook defPS-       MediaWiki  -> readMediaWiki defPS--wikiLinksTransform :: Pandoc -> PluginM Pandoc-wikiLinksTransform pandoc-  = do cfg <- liftM pluginConfig ask -- Can't use askConfig from Interface due to circular dependencies.-       return (bottomUp (convertWikiLinks cfg) pandoc)---- | Convert links with no URL to wikilinks.-convertWikiLinks :: Config -> Inline -> Inline-convertWikiLinks cfg (Link ref ("", "")) | useAbsoluteUrls cfg =-  Link ref ("/" </> baseUrl cfg </> inlinesToURL ref, "Go to wiki page")-convertWikiLinks _cfg (Link ref ("", "")) =-  Link ref (inlinesToURL ref, "Go to wiki page")-convertWikiLinks _cfg x = x---- | Derives a URL from a list of Pandoc Inline elements.-inlinesToURL :: [Inline] -> String-inlinesToURL = encString False isUnescapedInURI . inlinesToString---- | Convert a list of inlines into a string.-inlinesToString :: [Inline] -> String-inlinesToString = concatMap go-  where go x = case x of-               Str s                   -> s-               Emph xs                 -> concatMap go xs-               Strong xs               -> concatMap go xs-               Strikeout xs            -> concatMap go xs-               Superscript xs          -> concatMap go xs-               Subscript xs            -> concatMap go xs-               SmallCaps xs            -> concatMap go xs-               Quoted DoubleQuote xs   -> '"' : (concatMap go xs ++ "\"")-               Quoted SingleQuote xs   -> '\'' : (concatMap go xs ++ "'")-               Cite _ xs               -> concatMap go xs-               Code _ s                -> s-               Space                   -> " "-               LineBreak               -> " "-               Math DisplayMath s      -> "$$" ++ s ++ "$$"-               Math InlineMath s       -> "$" ++ s ++ "$"-               RawInline (Format "tex") s -> s-               RawInline _ _           -> ""-               Link xs _               -> concatMap go xs-               Image xs _              -> concatMap go xs-               Note _                  -> ""-               Span _ xs               -> concatMap go xs-

@@ -1,314 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions for exporting wiki pages in various formats.--}--module Network.Gitit.Export ( exportFormats ) where-import Text.Pandoc hiding (HTMLMathMethod(..))-import qualified Text.Pandoc as Pandoc-import Text.Pandoc.PDF (makePDF)-import Text.Pandoc.SelfContained as SelfContained-import Text.Pandoc.Shared (readDataFileUTF8)-import Network.Gitit.Server-import Network.Gitit.Framework (pathForPage, getWikiBase)-import Network.Gitit.State (getConfig)-import Network.Gitit.Types-import Network.Gitit.Cache (cacheContents, lookupCache)-import Control.Monad.Trans (liftIO)-import Control.Monad (unless)-import Text.XHtml (noHtml)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Lazy.UTF8 (fromString, toString)-import System.FilePath ((</>), takeDirectory)-import Control.Exception (throwIO)-import System.Directory (doesFileExist)-import Text.HTML.SanitizeXSS-import Text.Pandoc.Writers.RTF (writeRTFWithEmbeddedImages)-import qualified Data.Text as T-import Data.List (isPrefixOf)-import Text.Highlighting.Kate (styleToCss, pygments)-import Paths_gitit (getDataFileName)--defaultRespOptions :: WriterOptions-defaultRespOptions = def { writerStandalone = True, writerHighlight = True }--respond :: String-        -> String-        -> (Pandoc -> IO L.ByteString)-        -> String-        -> Pandoc-        -> Handler-respond mimetype ext fn page doc = liftIO (fn doc) >>=-  ok . setContentType mimetype .-  (if null ext then id else setFilename (page ++ "." ++ ext)) .-  toResponseBS B.empty--respondX :: String -> String -> String-          -> (WriterOptions -> Pandoc -> IO L.ByteString)-          -> WriterOptions -> String -> Pandoc -> Handler-respondX templ mimetype ext fn opts page doc = do-  cfg <- getConfig-  template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) templ-  template <- case template' of-                  Right t  -> return t-                  Left e   -> liftIO $ throwIO e-  doc' <- if ext `elem` ["odt","pdf","beamer","epub","docx","rtf"]-             then fixURLs page doc-             else return doc-  respond mimetype ext (fn opts{writerTemplate = template-                               ,writerUserDataDir = pandocUserData cfg})-          page doc'--respondS :: String -> String -> String -> (WriterOptions -> Pandoc -> String)-          -> WriterOptions -> String -> Pandoc -> Handler-respondS templ mimetype ext fn =-  respondX templ mimetype ext (\o d -> return $ fromString $ fn o d)--respondSlides :: String -> HTMLSlideVariant -> String -> Pandoc -> Handler-respondSlides templ slideVariant page doc = do-    cfg <- getConfig-    base' <- getWikiBase-    let math = case mathMethod cfg of-                   MathML       -> Pandoc.MathML Nothing-                   WebTeX u     -> Pandoc.WebTeX u-                   JsMathScript -> Pandoc.JsMath-                                    (Just $ base' ++ "/js/jsMath/easy/load.js")-                   _            -> Pandoc.PlainMath-    let opts' = defaultRespOptions {-                     writerSlideVariant = slideVariant-                    ,writerIncremental = True-                    ,writerHtml5 = templ == "dzslides"-                    ,writerHTMLMathMethod = math}-    -- We sanitize the body only, to protect against XSS attacks.-    -- (Sanitizing the whole HTML page would strip out javascript-    -- needed for the slides.)  We then pass the body into the-    -- slide template using the 'body' variable.-    Pandoc meta blocks <- fixURLs page doc-    let body' = writeHtmlString opts'{writerStandalone = False}-                   (Pandoc meta blocks) -- just body-    let body'' = T.unpack-               $ (if xssSanitize cfg then sanitizeBalance else id)-               $ T.pack body'-    variables' <- if mathMethod cfg == MathML-                     then do-                        s <- liftIO $ readDataFileUTF8 (pandocUserData cfg)-                                  "MathMLinHTML.js"-                        return [("mathml-script", s)]-                     else return []-    template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) templ-    template <- case template' of-                     Right t  -> return t-                     Left e   -> liftIO $ throwIO e-    dzcore <- if templ == "dzslides"-                  then do-                    dztempl <- liftIO $ readDataFileUTF8 (pandocUserData cfg)-                           $ "dzslides" </> "template.html"-                    return $ unlines-                        $ dropWhile (not . isPrefixOf "<!-- {{{{ dzslides core")-                        $ lines dztempl-                  else return ""-    let opts'' = opts'{-                writerVariables =-                  ("body",body''):("dzslides-core",dzcore):("highlighting-css",pygmentsCss):variables'-               ,writerTemplate = template-               ,writerUserDataDir = pandocUserData cfg-               }-    let h = writeHtmlString opts'' (Pandoc meta [])-#if MIN_VERSION_pandoc(1,13,0)-    h' <- liftIO $ makeSelfContained opts'' h-#else-    h' <- liftIO $ makeSelfContained (pandocUserData cfg) h-#endif-    ok . setContentType "text/html;charset=UTF-8" .-      -- (setFilename (page ++ ".html")) .-      toResponseBS B.empty $ fromString h'--respondLaTeX :: String -> Pandoc -> Handler-respondLaTeX = respondS "latex" "application/x-latex" "tex"-  writeLaTeX defaultRespOptions--respondConTeXt :: String -> Pandoc -> Handler-respondConTeXt = respondS "context" "application/x-context" "tex"-  writeConTeXt defaultRespOptions---respondRTF :: String -> Pandoc -> Handler-respondRTF = respondX "rtf" "application/rtf" "rtf"-  (\o d -> fromString `fmap` writeRTFWithEmbeddedImages o d) defaultRespOptions--respondRST :: String -> Pandoc -> Handler-respondRST = respondS "rst" "text/plain; charset=utf-8" ""-  writeRST defaultRespOptions{writerReferenceLinks = True}--respondMarkdown :: String -> Pandoc -> Handler-respondMarkdown = respondS "markdown" "text/plain; charset=utf-8" ""-  writeMarkdown defaultRespOptions{writerReferenceLinks = True}--#if MIN_VERSION_pandoc(1,14,0)-respondCommonMark :: String -> Pandoc -> Handler-respondCommonMark = respondS "commonmark" "text/plain; charset=utf-8" ""-  writeCommonMark defaultRespOptions{writerReferenceLinks = True}-#endif--respondPlain :: String -> Pandoc -> Handler-respondPlain = respondS "plain" "text/plain; charset=utf-8" ""-  writePlain defaultRespOptions--respondMan :: String -> Pandoc -> Handler-respondMan = respondS "man" "text/plain; charset=utf-8" ""-  writeMan defaultRespOptions--respondTexinfo :: String -> Pandoc -> Handler-respondTexinfo = respondS "texinfo" "application/x-texinfo" "texi"-  writeTexinfo defaultRespOptions--respondDocbook :: String -> Pandoc -> Handler-respondDocbook = respondS "docbook" "application/docbook+xml" "xml"-  writeDocbook defaultRespOptions--respondOrg :: String -> Pandoc -> Handler-respondOrg = respondS "org" "text/plain; charset=utf-8" ""-  writeOrg defaultRespOptions--respondICML :: String -> Pandoc -> Handler-respondICML = respondS "icml" "application/xml; charset=utf-8" ""-  writeICML defaultRespOptions--respondTextile :: String -> Pandoc -> Handler-respondTextile = respondS "textile" "text/plain; charset=utf-8" ""-  writeTextile defaultRespOptions--respondAsciiDoc :: String -> Pandoc -> Handler-respondAsciiDoc = respondS "asciidoc" "text/plain; charset=utf-8" ""-  writeAsciiDoc defaultRespOptions--respondMediaWiki :: String -> Pandoc -> Handler-respondMediaWiki = respondS "mediawiki" "text/plain; charset=utf-8" ""-  writeMediaWiki defaultRespOptions--respondODT :: String -> Pandoc -> Handler-respondODT = respondX "opendocument" "application/vnd.oasis.opendocument.text"-              "odt" writeODT defaultRespOptions--respondEPUB :: String -> Pandoc -> Handler-respondEPUB = respondX "html" "application/epub+zip" "epub" writeEPUB-               defaultRespOptions--respondDocx :: String -> Pandoc -> Handler-respondDocx = respondX "native"-  "application/vnd.openxmlformats-officedocument.wordprocessingml.document"-  "docx" writeDocx defaultRespOptions--respondPDF :: Bool -> String -> Pandoc -> Handler-respondPDF useBeamer page old_pndc = fixURLs page old_pndc >>= \pndc -> do-  cfg <- getConfig-  unless (pdfExport cfg) $ error "PDF export disabled"-  let cacheName = pathForPage page (defaultExtension cfg) ++ ".export.pdf"-  cached <- if useCache cfg-               then lookupCache cacheName-               else return Nothing-  pdf' <- case cached of-            Just (_modtime, bs) -> return $ Right $ L.fromChunks [bs]-            Nothing -> do-              template' <- liftIO $ getDefaultTemplate (pandocUserData cfg)-                                  $ if useBeamer then "beamer" else "latex"-              template  <- liftIO $ either throwIO return template'-              let toc = tableOfContents cfg-              res <- liftIO $ makePDF "pdflatex" writeLaTeX-                         defaultRespOptions{writerTemplate = template-                                           ,writerSourceURL = Just $ baseUrl cfg-                                           ,writerTableOfContents = toc-                                           ,writerBeamer = useBeamer} pndc-              return res-  case pdf' of-       Left logOutput -> simpleErrorHandler ("PDF creation failed:\n"-                           ++ toString logOutput)-       Right pdfBS -> do-              case cached of-                Nothing ->-                     cacheContents cacheName $ B.concat . L.toChunks $ pdfBS-                _ -> return ()-              ok $ setContentType "application/pdf" $ setFilename (page ++ ".pdf") $-                        (toResponse noHtml) {rsBody = pdfBS}---- | When we create a PDF or ODT from a Gitit page, we need to fix the URLs of any--- images on the page. Those URLs will often be relative to the staticDir, but the--- PDF or ODT processor only understands paths relative to the working directory.------ Because the working directory will not in general be the root of the gitit instance--- at the time the Pandoc is fed to e.g. pdflatex, this function replaces the URLs of--- images in the staticDir with their correct absolute file path.-fixURLs :: String -> Pandoc -> GititServerPart Pandoc-fixURLs page pndc = do-    cfg <- getConfig-    defaultStatic <- liftIO $ getDataFileName $ "data" </> "static"--    let static = staticDir cfg-    let repoPath = repositoryPath cfg--    let go (Image ils (url, title)) = do-           fixedURL <- fixURL url-           return $ Image ils (fixedURL, title)-        go x                        = return x--        fixURL ('/':url) = resolve url-        fixURL url       = resolve $ takeDirectory page </> url--        resolve p = do-           sp <- doesFileExist $ static </> p-           dsp <- doesFileExist $ defaultStatic </> p-           return (if sp then static </> p-                   else (if dsp then defaultStatic </> p-                         else repoPath </> p))-    liftIO $ bottomUpM go pndc--exportFormats :: Config -> [(String, String -> Pandoc -> Handler)]-exportFormats cfg = if pdfExport cfg-                       then ("PDF", respondPDF False) :-                            ("Beamer", respondPDF True) :-                            rest-                       else rest-   where rest = [ ("LaTeX",     respondLaTeX)     -- (description, writer)-                , ("ConTeXt",   respondConTeXt)-                , ("Texinfo",   respondTexinfo)-                , ("reST",      respondRST)-                , ("Markdown",  respondMarkdown)-#if MIN_VERSION_pandoc(1,14,0)-                , ("CommonMark",respondCommonMark)-#endif-                , ("Plain text",respondPlain)-                , ("MediaWiki", respondMediaWiki)-                , ("Org-mode",  respondOrg)-                , ("ICML",      respondICML)-                , ("Textile",   respondTextile)-                , ("AsciiDoc",  respondAsciiDoc)-                , ("Man page",  respondMan)-                , ("DocBook",   respondDocbook)-                , ("DZSlides",  respondSlides "dzslides" DZSlides)-                , ("Slidy",     respondSlides "slidy" SlidySlides)-                , ("S5",        respondSlides "s5" S5Slides)-                , ("EPUB",      respondEPUB)-                , ("ODT",       respondODT)-                , ("DOCX",      respondDocx)-                , ("RTF",       respondRTF) ]--pygmentsCss :: String-pygmentsCss = styleToCss pygments

@@ -1,175 +0,0 @@-{--Copyright (C) 2009 Gwern Branwen <gwern0@gmail.com> and-John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}---- | Functions for creating Atom feeds for Gitit wikis and pages.--module Network.Gitit.Feed (FeedConfig(..), filestoreToXmlFeed) where--import Data.Time (UTCTime, formatTime, getCurrentTime, addUTCTime)-#if MIN_VERSION_time(1,5,0)-import Data.Time (defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-#endif-import Data.Foldable as F (concatMap)-import Data.List (intercalate, sortBy, nub)-import Data.Maybe (fromMaybe)-import Data.Ord (comparing)-import Network.URI (isUnescapedInURI, escapeURIString)-import System.FilePath (dropExtension, takeExtension, (<.>))-import Data.FileStore.Generic (Diff(..), diff)-import Data.FileStore.Types (history, retrieve, Author(authorName), Change(..),-         FileStore, Revision(..), TimeRange(..), RevisionId)-import Text.Atom.Feed (nullEntry, nullFeed, nullLink, nullPerson,-         Date, Entry(..), Feed(..), Link(linkRel), Generator(..),-         Person(personName), EntryContent(..), TextContent(TextString))-import Text.Atom.Feed.Export (xmlFeed)-import Text.XML.Light (ppTopElement, showContent, Content(..), Element(..), blank_element, QName(..), blank_name, CData(..), blank_cdata)-import Data.Version (showVersion)-import Paths_gitit (version)--data FeedConfig = FeedConfig {-    fcTitle    :: String-  , fcBaseUrl  :: String-  , fcFeedDays :: Integer- } deriving (Read, Show)--gititGenerator :: Generator-gititGenerator = Generator {genURI = Just "http://github.com/jgm/gitit"-                                   , genVersion = Just (showVersion version)-                                   , genText = "gitit"}--filestoreToXmlFeed :: FeedConfig -> FileStore -> Maybe FilePath -> IO String-filestoreToXmlFeed cfg f = fmap xmlFeedToString . generateFeed cfg gititGenerator f--xmlFeedToString :: Feed -> String-xmlFeedToString = ppTopElement . xmlFeed--generateFeed :: FeedConfig -> Generator -> FileStore -> Maybe FilePath -> IO Feed-generateFeed cfg generator fs mbPath = do-  now <- getCurrentTime-  revs <- changeLog (fcFeedDays cfg) fs mbPath now-  diffs <- mapM (getDiffs fs) revs-  let home = fcBaseUrl cfg ++ "/"-  -- TODO: 'nub . sort' `persons` - but no Eq or Ord instances!-      persons = map authorToPerson $ nub $ sortBy (comparing authorName) $ map revAuthor revs-      basefeed = generateEmptyfeed generator (fcTitle cfg) home mbPath persons (formatFeedTime now)-      revisions = map (revisionToEntry home) (zip revs diffs)-  return basefeed {feedEntries = revisions}---- | Get the last N days history.-changeLog :: Integer -> FileStore -> Maybe FilePath -> UTCTime -> IO [Revision]-changeLog days a mbPath now' = do-  let files = F.concatMap (\f -> [f, f <.> "page"]) mbPath-  let startTime = addUTCTime (fromIntegral $ -60 * 60 * 24 * days) now'-  rs <- history a files TimeRange{timeFrom = Just startTime, timeTo = Just now'}-          (Just 200) -- hard limit of 200 to conserve resources-  return $ sortBy (flip $ comparing revDateTime) rs--getDiffs :: FileStore -> Revision -> IO [(FilePath, [Diff [String]])]-getDiffs fs Revision{ revId = to, revDateTime = rd, revChanges = rv } = do-  revPair <- history fs [] (TimeRange Nothing $ Just rd) (Just 2)-  let from = if length revPair >= 2-                then Just $ revId $ revPair !! 1-                else Nothing-  diffs <- mapM (getDiff fs from (Just to)) rv-  return $ map filterPages $ zip (map getFP rv) diffs-  where getFP (Added fp) = fp-        getFP (Modified fp) = fp-        getFP (Deleted fp) = fp-        filterPages (fp, d) = case (reverse fp) of-                                   'e':'g':'a':'p':'.':x -> (reverse x, d)-                                   _ -> (fp, [])--getDiff :: FileStore -> Maybe RevisionId -> Maybe RevisionId -> Change -> IO [Diff [String]]-getDiff fs from _ (Deleted fp) = do-  contents <- retrieve fs fp from-  return [First $ lines contents]-getDiff fs from to (Modified fp) = diff fs fp from to-getDiff fs _ to (Added fp) = do-  contents <- retrieve fs fp to-  return [Second $ lines contents]--generateEmptyfeed :: Generator -> String ->String ->Maybe String -> [Person] -> Date -> Feed-generateEmptyfeed generator title home mbPath authors now =-  baseNull {feedAuthors = authors,-            feedGenerator = Just generator,-            feedLinks = [ (nullLink $ home ++ "_feed/" ++ escape (fromMaybe "" mbPath))-                           {linkRel = Just (Left "self")}]-            }-    where baseNull = nullFeed home (TextString title) now--revisionToEntry :: String -> (Revision, [(FilePath, [Diff [String]])]) -> Entry-revisionToEntry home (Revision{ revId = rid, revDateTime = rdt,-                               revAuthor = ra, revDescription = rd,-                               revChanges = rv}, diffs) =-  baseEntry{ entryContent = Just $ HTMLContent $ concat $ map showContent $ map diffFile diffs-           , entryAuthors = [authorToPerson ra], entryLinks = [ln] }-   where baseEntry = nullEntry url title (formatFeedTime rdt)-         url = home ++ escape (extract $ head rv) ++ "?revision=" ++ rid-         ln = (nullLink url) {linkRel = Just (Left "alternate")}-         title = TextString $ (takeWhile ('\n' /=) rd) ++ " - " ++ (intercalate ", " $ map show rv)--diffFile :: (FilePath, [Diff [String]]) -> Content-diffFile (fp, d) =-    enTag "div" $ header : text-  where-    header = enTag1 "h1" $ enText fp-    text = map (enTag1 "p") $ concat $ map diffLines d--diffLines :: Diff [String] -> [Content]-diffLines (First x) = map (enTag1 "s" . enText) x-diffLines (Second x) = map (enTag1 "b" . enText) x-diffLines (Both x _) = map enText x--enTag :: String -> [Content] -> Content-enTag tag content = Elem blank_element{ elName=blank_name{qName=tag}-				      , elContent=content-				      }-enTag1 :: String -> Content -> Content-enTag1 tag content = enTag tag [content]-enText :: String -> Content-enText content = Text blank_cdata{cdData=content}---- gitit is set up not to reveal registration emails-authorToPerson :: Author -> Person-authorToPerson ra = nullPerson {personName = authorName ra}---- TODO: replace with Network.URI version of shortcut if it ever is added-escape :: String -> String-escape = escapeURIString isUnescapedInURI--formatFeedTime :: UTCTime -> String-formatFeedTime = formatTime defaultTimeLocale "%FT%TZ"---- TODO: this boilerplate can be removed by changing Data.FileStore.Types to say--- data Change = Modified {extract :: FilePath} | Deleted {extract :: FilePath} | Added---                   {extract :: FilePath}--- so then it would be just 'escape (extract $ head rv)' without the 4 line definition-extract :: Change -> FilePath-extract x = dePage $ case x of {Modified n -> n; Deleted n -> n; Added n -> n}-          where dePage f = if takeExtension f == ".page" then dropExtension f else f---- TODO: figure out how to create diff links in a non-broken manner-{--diff :: String -> String -> Revision -> Link-diff home path' Revision{revId = rid} =-                        let n = nullLink (home ++ "_diff/" ++ escape path' ++ "?to=" ++ rid) -- ++ fromrev)-                        in n {linkRel = Just (Left "alternate")}--}

@@ -1,358 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>-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 for more details.-You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- | Useful functions for defining wiki handlers.--}--module Network.Gitit.Framework (-                               -- * Combinators for dealing with users-                                 withUserFromSession-                               , withUserFromHTTPAuth-                               , authenticateUserThat-                               , authenticate-                               , getLoggedInUser-                               -- * Combinators to exclude certain actions-                               , unlessNoEdit-                               , unlessNoDelete-                               -- * Guards for routing-                               , guardCommand-                               , guardPath-                               , guardIndex-                               , guardBareBase-                               -- * Functions to get info from the request-                               , getPath-                               , getPage-                               , getReferer-                               , getWikiBase-                               , uriPath-                               -- * Useful predicates-                               , isPage-                               , isPageFile-                               , isDiscussPage-                               , isDiscussPageFile-                               , isNotDiscussPageFile-                               , isSourceCode-                               -- * Combinators that change the request locally-                               , withMessages-                               -- * Miscellaneous-                               , urlForPage-                               , pathForPage-                               , getMimeTypeForExtension-                               , validate-                               , filestoreFromConfig-                               )-where-import Safe-import Network.Gitit.Server-import Network.Gitit.State-import Network.Gitit.Types-import Data.FileStore-import Data.Char (toLower)-import Control.Monad (mzero, liftM, unless)-import qualified Data.Map as M-import qualified Data.ByteString.UTF8 as UTF8-import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8-import Data.Maybe (fromJust, fromMaybe)-import Data.List (intercalate, isPrefixOf, isInfixOf)-import System.FilePath ((<.>), takeExtension, takeFileName)-import Text.Highlighting.Kate-import Text.ParserCombinators.Parsec-import Network.URL (decString, encString)-import Network.URI (isUnescapedInURI)-import Data.ByteString.Base64 (decodeLenient)-import Network.HTTP (urlEncodeVars)---- | Require a logged in user if the authentication level demands it.--- Run the handler if a user is logged in, otherwise redirect--- to login page.-authenticate :: AuthenticationLevel -> Handler -> Handler-authenticate = authenticateUserThat (const True)---- | Like 'authenticate', but with a predicate that the user must satisfy.-authenticateUserThat :: (User -> Bool) -> AuthenticationLevel -> Handler -> Handler-authenticateUserThat predicate level handler = do-  cfg <- getConfig-  if level <= requireAuthentication cfg-     then do-       mbUser <- getLoggedInUser-       rq <- askRq-       let url = rqUri rq ++ rqQuery rq-       case mbUser of-            Nothing   -> tempRedirect ("/_login?" ++ urlEncodeVars [("destination", url)]) $ toResponse ()-            Just u    -> if predicate u-                            then handler-                            else error "Not authorized."-     else handler---- | Run the handler after setting @REMOTE_USER@ with the user from--- the session.-withUserFromSession :: Handler -> Handler-withUserFromSession handler = withData $ \(sk :: Maybe SessionKey) -> do-  mbSd <- maybe (return Nothing) getSession sk-  cfg <- getConfig-  mbUser <- case mbSd of-            Nothing    -> return Nothing-            Just sd    -> do-              addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show $ fromJust sk))  -- refresh timeout-              case sessionUser sd of-                Nothing -> return Nothing-                Just user -> getUser user-  let user = maybe "" uUsername mbUser-  localRq (setHeader "REMOTE_USER" user) handler---- | Run the handler after setting @REMOTE_USER@ from the "authorization"--- header.  Works with simple HTTP authentication or digest authentication.-withUserFromHTTPAuth :: Handler -> Handler-withUserFromHTTPAuth handler = do-  req <- askRq-  let user = case getHeader "authorization" req of-              Nothing         -> ""-              Just authHeader -> case parse pAuthorizationHeader "" (UTF8.toString authHeader) of-                                  Left _  -> ""-                                  Right u -> u-  localRq (setHeader "REMOTE_USER" user) handler---- | Returns @Just@ logged in user or @Nothing@.-getLoggedInUser :: GititServerPart (Maybe User)-getLoggedInUser = do-  req <- askRq-  case maybe "" UTF8.toString (getHeader "REMOTE_USER" req) of-        "" -> return Nothing-        u  -> do-          mbUser <- getUser u-          case mbUser of-               Just user -> return $ Just user-               Nothing   -> return $ Just User{uUsername = u, uEmail = "", uPassword = undefined}--pAuthorizationHeader :: GenParser Char st String-pAuthorizationHeader = try pBasicHeader <|> pDigestHeader--pDigestHeader :: GenParser Char st String-pDigestHeader = do-  _ <- string "Digest username=\""-  result' <- many (noneOf "\"")-  _ <- char '"'-  return result'--pBasicHeader :: GenParser Char st String-pBasicHeader = do-  _ <- string "Basic "-  result' <- many (noneOf " \t\n")-  return $ takeWhile (/=':') $ UTF8.toString-         $ decodeLenient $ UTF8.fromString result'---- | @unlessNoEdit responder fallback@ runs @responder@ unless the--- page has been designated not editable in configuration; in that--- case, runs @fallback@.-unlessNoEdit :: Handler-             -> Handler-             -> Handler-unlessNoEdit responder fallback = withData $ \(params :: Params) -> do-  cfg <- getConfig-  page <- getPage-  if page `elem` noEdit cfg-     then withMessages ("Page is locked." : pMessages params) fallback-     else responder---- | @unlessNoDelete responder fallback@ runs @responder@ unless the--- page has been designated not deletable in configuration; in that--- case, runs @fallback@.-unlessNoDelete :: Handler-               -> Handler-               -> Handler-unlessNoDelete responder fallback = withData $ \(params :: Params) -> do-  cfg <- getConfig-  page <- getPage-  if page `elem` noDelete cfg-     then withMessages ("Page cannot be deleted." : pMessages params) fallback-     else responder---- | Returns the current path (subtracting initial commands like @\/_edit@).-getPath :: ServerMonad m => m String-getPath = liftM (intercalate "/" . rqPaths) askRq---- | Returns the current page name (derived from the path).-getPage :: GititServerPart String-getPage = do-  conf <- getConfig-  path' <- getPath-  if null path'-     then return (frontPage conf)-     else if isPage path'-             then return path'-             else mzero  -- fail if not valid page name---- | Returns the contents of the "referer" header.-getReferer :: ServerMonad m => m String-getReferer = do-  req <- askRq-  base' <- getWikiBase-  return $ case getHeader "referer" req of-                 Just r  -> case UTF8.toString r of-                                 ""  -> base'-                                 s   -> s-                 Nothing -> base'---- | Returns the base URL of the wiki in the happstack server.--- So, if the wiki handlers are behind a @dir 'foo'@, getWikiBase will--- return @\/foo/@.  getWikiBase doesn't know anything about HTTP--- proxies, so if you use proxies to map a gitit wiki to @\/foo/@,--- you'll still need to follow the instructions in README.-getWikiBase :: ServerMonad m => m String-getWikiBase = do-  path' <- getPath-  uri' <- liftM (fromJust . decString True . rqUri) askRq-  case calculateWikiBase path' uri' of-       Just b    -> return b-       Nothing   -> error $ "Could not getWikiBase: (path, uri) = " ++ show (path',uri')---- | The pure core of 'getWikiBase'.-calculateWikiBase :: String -> String -> Maybe String-calculateWikiBase path' uri' =-  let revpaths = reverse . filter (not . null) $ splitOn '/' path'-      revuris  = reverse . filter (not . null) $ splitOn '/' uri'-  in  if revpaths `isPrefixOf` revuris-         then let revbase = drop (length revpaths) revuris-                  -- a path like _feed is not part of the base...-                  revbase' = case revbase of-                             (x:xs) | startsWithUnderscore x -> xs-                             xs                              -> xs-                  base'    = intercalate "/" $ reverse revbase'-              in  Just $ if null base' then "" else '/' : base'-          else Nothing--startsWithUnderscore :: String -> Bool-startsWithUnderscore ('_':_) = True-startsWithUnderscore _ = False--splitOn :: Eq a => a -> [a] -> [[a]]-splitOn c cs =-  let (next, rest) = break (==c) cs-  in case rest of-         []     -> [next]-         (_:rs) -> next : splitOn c rs---- | Returns path portion of URI, without initial @\/@.--- Consecutive spaces are collapsed.  We don't want to distinguish--- @Hi There@ and @Hi  There@.-uriPath :: String -> String-uriPath = unwords . words . drop 1 . takeWhile (/='?')--isPage :: String -> Bool-isPage "" = False-isPage ('_':_) = False-isPage s = all (`notElem` "*?") s && not (".." `isInfixOf` s) && not ("/_" `isInfixOf` s)--- for now, we disallow @*@ and @?@ in page names, because git filestore--- does not deal with them properly, and darcs filestore disallows them.--isPageFile :: FilePath -> GititServerPart Bool-isPageFile f = do-  cfg <- getConfig-  return $ takeExtension f == "." ++ (defaultExtension cfg)--isDiscussPage :: String -> Bool-isDiscussPage ('@':xs) = isPage xs-isDiscussPage _ = False--isDiscussPageFile :: FilePath -> GititServerPart Bool-isDiscussPageFile ('@':xs) = isPageFile xs-isDiscussPageFile _ = return False--isNotDiscussPageFile :: FilePath -> GititServerPart Bool-isNotDiscussPageFile ('@':_) = return False-isNotDiscussPageFile _ = return True--isSourceCode :: String -> Bool-isSourceCode path' =-  let langs = languagesByFilename $ takeFileName path'-      ext = takeExtension path'-  in  not (null langs || ext == ".svg" || ext == ".eps")-                         -- allow svg or eps to be served as image---- | Returns encoded URL path for the page with the given name, relative to--- the wiki base.-urlForPage :: String -> String-urlForPage page = '/' : encString False isUnescapedInURI page---- | Returns the filestore path of the file containing the page's source.-pathForPage :: String -> String -> FilePath-pathForPage page ext = page <.> ext---- | Retrieves a mime type based on file extension.-getMimeTypeForExtension :: String -> GititServerPart String-getMimeTypeForExtension ext = do-  mimes <- liftM mimeMap getConfig-  return $ fromMaybe "application/octet-stream"-    (M.lookup (dropWhile (== '.') $ map toLower ext) mimes)---- | Simple helper for validation of forms.-validate :: [(Bool, String)]   -- ^ list of conditions and error messages-         -> [String]           -- ^ list of error messages-validate = foldl go []-   where go errs (condition, msg) = if condition then msg:errs else errs--guardCommand :: String -> GititServerPart ()-guardCommand command = withData $ \(com :: Command) ->-  case com of-       Command (Just c) | c == command -> return ()-       _                               -> mzero--guardPath :: (String -> Bool) -> GititServerPart ()-guardPath pred' = guardRq (pred' . rqUri)---- | Succeeds if path is an index path:  e.g. @\/foo\/bar/@.-guardIndex :: GititServerPart ()-guardIndex = do-  base <- getWikiBase-  uri' <- liftM rqUri askRq-  let localpath = drop (length base) uri'-  unless (length localpath > 1 && lastNote "guardIndex" uri' == '/')-    mzero---- Guard against a path like @\/wiki@ when the wiki is being--- served at @\/wiki@.-guardBareBase :: GititServerPart ()-guardBareBase = do-  base' <- getWikiBase-  uri' <- liftM rqUri askRq-  unless (not (null base') && base' == uri')-    mzero---- | Runs a server monad in a local context after setting--- the "message" request header.-withMessages :: ServerMonad m => [String] -> m a -> m a-withMessages messages handler = do-  req <- askRq-  let inps = filter (\(n,_) -> n /= "message") $ rqInputsQuery req-  let newInp msg = ("message", Input {-                              inputValue = Right-                                         $ LazyUTF8.fromString msg-                            , inputFilename = Nothing-                            , inputContentType = ContentType {-                                    ctType = "text"-                                  , ctSubtype = "plain"-                                  , ctParameters = [] }-                            })-  localRq (\rq -> rq{ rqInputsQuery = map newInp messages ++ inps }) handler---- | Returns a filestore object derived from the--- repository path and filestore type specified in configuration.-filestoreFromConfig :: Config -> FileStore-filestoreFromConfig conf =-  case repositoryType conf of-         Git       -> gitFileStore       $ repositoryPath conf-         Darcs     -> darcsFileStore     $ repositoryPath conf-         Mercurial -> mercurialFileStore $ repositoryPath conf

@@ -1,815 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{--Copyright (C) 2008-9 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Handlers for wiki functions.--}--module Network.Gitit.Handlers (-                        handleAny-                      , debugHandler-                      , randomPage-                      , discussPage-                      , createPage-                      , showActivity-                      , goToPage-                      , searchResults-                      , uploadForm-                      , uploadFile-                      , indexPage-                      , categoryPage-                      , categoryListPage-                      , preview-                      , showRawPage-                      , showFileAsText-                      , showPageHistory-                      , showFileHistory-                      , showPage-                      , showPageDiff-                      , showFileDiff-                      , exportPage-                      , updatePage-                      , editPage-                      , deletePage-                      , confirmDelete-                      , showHighlightedSource-                      , expireCache-                      , feedHandler-                      )-where-import Safe-import Network.Gitit.Server-import Network.Gitit.Framework-import Network.Gitit.Layout-import Network.Gitit.Types-import Network.Gitit.Feed (filestoreToXmlFeed, FeedConfig(..))-import Network.Gitit.Util (orIfNull)-import Network.Gitit.Cache (expireCachedFile, lookupCache, cacheContents)-import Network.Gitit.ContentTransformer (showRawPage, showFileAsText, showPage,-        exportPage, showHighlightedSource, preview, applyPreCommitPlugins)-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)-import Data.Ord (comparing)-import Data.Char (toLower, isSpace)-import Control.Monad.Reader-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString as S-import Network.HTTP (urlEncodeVars)-import Data.Time (getCurrentTime, addUTCTime)-import Data.Time.Clock (diffUTCTime, UTCTime(..))-import Data.FileStore-import System.Log.Logger (logM, Priority(..))--handleAny :: Handler-handleAny = withData $ \(params :: Params) -> uriRest $ \uri ->-  let path' = uriPath uri-  in  do fs <- getFileStore-         let rev = pRevision params-         mimetype <- getMimeTypeForExtension-                      (takeExtension path')-         res <- liftIO $ E.try-                (retrieve fs path' rev :: IO B.ByteString)-         case res of-                Right contents -> ignoreFilters >>  -- don't compress-                                  (ok $ setContentType mimetype $-                                    (toResponse noHtml) {rsBody = contents})-                                    -- ugly hack-                Left NotFound  -> mzero-                Left e         -> error (show e)--debugHandler :: Handler-debugHandler = withData $ \(params :: Params) -> do-  req <- askRq-  liftIO $ logM "gitit" DEBUG (show req)-  page <- getPage-  liftIO $ logM "gitit" DEBUG $ "Page = '" ++ page ++ "'\n" ++-              show params-  mzero--randomPage :: Handler-randomPage = do-  fs <- getFileStore-  base' <- getWikiBase-  prunedFiles <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile-  let pages = map dropExtension prunedFiles-  if null pages-     then error "No pages found!"-     else do-       secs <- liftIO (fmap utctDayTime getCurrentTime)-       let newPage = pages !!-                     (truncate (secs * 1000000) `mod` length pages)-       seeOther (base' ++ urlForPage newPage) $ toResponse $-         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"--createPage :: Handler-createPage = do-  page <- getPage-  base' <- getWikiBase-  case page of-       ('_':_) -> mzero   -- don't allow creation of _index, etc.-       _       -> formattedPage defaultPageLayout{-                                      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 ++ "'")])--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:"-              , br-              , afile "file" ! [value origPath] ]-       , p << [ label ! [thefor "wikiname"] << "Name on wiki, including extension"-              , noscript << " (leave blank to use the same filename)"-              , stringToHtml ":"-              , 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:"-              , br-              , textfield "logMsg" ! [size "60", value logMsg]-              , submit "upload" "Upload" ]-       ]-  formattedPage defaultPageLayout{-                   pgMessages = pMessages params,-                   pgScripts = ["uploadForm.js"],-                   pgShowPageTools = False,-                   pgTabs = [],-                   pgTitle = "Upload a file"} upForm--uploadFile :: Handler-uploadFile = withData $ \(params :: Params) -> do-  let origPath = pFilename params-  let filePath = pFilePath params-  let wikiname = normalise-                 $ dropWhile (=='/')-                 $ pWikiname params `orIfNull` takeFileName origPath-  let logMsg = pLogMsg params-  cfg <- getConfig-  wPF <- isPageFile wikiname-  mbUser <- getLoggedInUser-  (user, email) <- case mbUser of-                        Nothing -> return ("Anonymous", "")-                        Just u  -> return (uUsername u, uEmail u)-  let overwrite = pOverwrite params-  fs <- getFileStore-  exists <- liftIO $ E.catch (latest fs wikiname >> return True) $ \e ->-                      if e == NotFound-                         then return False-                         else E.throwIO e >> return True-  let inStaticDir = staticDir cfg `isPrefixOf` (repositoryPath cfg </> wikiname)-  let inTemplatesDir = templatesDir cfg `isPrefixOf` (repositoryPath cfg </> wikiname)-  let dirs' = splitDirectories $ takeDirectory wikiname-  let imageExtensions = [".png", ".jpg", ".gif"]-  let errors = validate-                 [ (null . filter (not . isSpace) $ logMsg,-                    "Description cannot be empty.")-                 , (".." `elem` dirs', "Wikiname cannot contain '..'")-                 , (null origPath, "File not found.")-                 , (inStaticDir,  "Destination is inside static directory.")-                 , (inTemplatesDir,  "Destination is inside templates directory.")-                 , (not overwrite && exists, "A file named '" ++ wikiname ++-                    "' already exists in the repository: choose a new name " ++-                    "or check the box to overwrite the existing file.")-                 , (wPF,-                    "This file extension is reserved for wiki pages.")-                 ]-  if null errors-     then do-       expireCachedFile wikiname `mplus` return ()-       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")-             , 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 ++ ")") ]-       formattedPage defaultPageLayout{-                       pgMessages = pMessages params,-                       pgShowPageTools = False,-                       pgTabs = [],-                       pgTitle = "Upload successful"}-                     contents-     else withMessages errors uploadForm--goToPage :: Handler-goToPage = withData $ \(params :: Params) -> do-  let gotopage = pGotoPage params-  fs <- getFileStore-  pruned_files <- liftIO (index fs) >>= filterM isPageFile-  let allPageNames = map dropExtension pruned_files-  let findPage f = find f allPageNames-  let exactMatch f = gotopage == f-  let insensitiveMatch f = (map toLower gotopage) == (map toLower f)-  let prefixMatch f = (map toLower gotopage) `isPrefixOf` (map toLower f)-  base' <- getWikiBase-  case findPage exactMatch of-       Just m  -> seeOther (base' ++ urlForPage m) $ toResponse-                     "Redirecting to exact match"-       Nothing -> case findPage insensitiveMatch of-                       Just m  -> seeOther (base' ++ urlForPage m) $ toResponse-                                    "Redirecting to case-insensitive match"-                       Nothing -> case findPage prefixMatch of-                                       Just m  -> seeOther (base' ++ urlForPage m) $-                                                  toResponse $ "Redirecting" ++-                                                    " to partial match"-                                       Nothing -> searchResults--searchResults :: Handler-searchResults = withData $ \(params :: Params) -> do-  let patterns = pPatterns params `orIfNull` [pGotoPage params]-  fs <- getFileStore-  matchLines <- if null patterns-                   then return []-                   else liftIO $ E.catch (search fs SearchQuery{-                                                  queryPatterns = patterns-                                                , queryWholeWords = True-                                                , queryMatchAll = True-                                                , queryIgnoreCase = True })-                                       -- catch error, because newer versions of git-                                       -- return 1 on no match, and filestore <=0.3.3-                                       -- doesn't handle this properly:-                                       (\(_ :: FileStoreError)  -> return [])-  let contentMatches = map matchResourceName matchLines-  allPages <- liftIO (index fs) >>= filterM isPageFile-  let slashToSpace = map (\c -> if c == '/' then ' ' else c)-  let inPageName pageName' x = x `elem` (words $ slashToSpace $ dropExtension pageName')-  let matchesPatterns pageName' = not (null patterns) &&-       all (inPageName (map toLower pageName')) (map (map toLower) patterns)-  let pageNameMatches = filter matchesPatterns allPages-  prunedFiles <- filterM isPageFile (contentMatches ++ pageNameMatches)-  let allMatchedFiles = nub $ prunedFiles-  let matchesInFile f =  mapMaybe (\x -> if matchResourceName x == f-                                            then Just (matchLine x)-                                            else Nothing) matchLines-  let matches = map (\f -> (f, matchesInFile f)) allMatchedFiles-  let relevance (f, ms) = length ms + if f `elem` pageNameMatches-                                         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]-  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-                                                     then "[show matches]"-                                                     else ""-        , pre ! [theclass "matches"] << unlines contents]-  let htmlMatches = preamble +++-                    olist << map toMatchListItem-                             (reverse $ sortBy (comparing relevance) matches)-  formattedPage defaultPageLayout{-                  pgMessages = pMessages params,-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgScripts = ["search.js"],-                  pgTitle = "Search results"}-                htmlMatches--showPageHistory :: Handler-showPageHistory = withData $ \(params :: Params) -> do-  page <- getPage-  cfg <- getConfig-  showHistory (pathForPage page $ defaultExtension cfg) page params--showFileHistory :: Handler-showFileHistory = withData $ \(params :: Params) -> do-  file <- getPage-  showHistory file file params--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] <<-                  "previous" ] ++-             (if pos /= 1-                  then [ primHtmlChar "nbsp"-                       , primHtmlChar "bull"-                       , primHtmlChar "nbsp"-                       , anchor ! [href $ base' ++ "/_diff" ++ urlForPage page ++ "?from=" ++-                                  revId rev] << "current"-                       ]-                  else []) ++-             [stringToHtml "]"])-        ]-  let contents = if null hist-                    then noHtml-                    else ulist ! [theclass "history"] <<-                           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)] <<-                                 "Show more..."-                else noHtml-  let tabs = if file == page  -- source file, not wiki page-                then [ViewTab,HistoryTab]-                else pgTabs defaultPageLayout-  formattedPage defaultPageLayout{-                   pgPageName = page,-                   pgMessages = pMessages params,-                   pgScripts = ["dragdiff.js"],-                   pgTabs = tabs,-                   pgSelectedTab = HistoryTab,-                   pgTitle = ("Changes to " ++ page)-                   } $ contents +++ more--showActivity :: Handler-showActivity = withData $ \(params :: Params) -> do-  cfg <- getConfig-  currTime <- liftIO getCurrentTime-  let defaultDaysAgo = fromIntegral (recentActivityDays cfg)-  let daysAgo = addUTCTime (defaultDaysAgo * (-60) * 60 * 24) currTime-  let since = case pSince params of-                   Nothing -> Just daysAgo-                   Just t  -> Just t-  let forUser = pForUser params-  fs <- getFileStore-  hist <- liftIO $ history fs [] (TimeRange since Nothing)-                     (Just $ pLimit params)-  let hist' = case forUser of-                   Nothing -> hist-                   Just u  -> filter (\r -> authorName (revAuthor r) == u) hist-  let fileFromChange (Added f)    = f-      fileFromChange (Modified f) = f-      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 " ") $-        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 contents = ulist ! [theclass "history"] << map revToListItem hist'-  formattedPage defaultPageLayout{-                  pgMessages = pMessages params,-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgTitle = "Recent changes"-                  } (heading +++ contents)--showPageDiff :: Handler-showPageDiff = withData $ \(params :: Params) -> do-  page <- getPage-  cfg <- getConfig-  showDiff (pathForPage page $ defaultExtension cfg) page params--showFileDiff :: Handler-showFileDiff = withData $ \(params :: Params) -> do-  page <- getPage-  showDiff page page params--showDiff :: String -> String -> Params -> Handler-showDiff file page params = do-  let from = pFrom params-  let to = pTo params-  -- 'to' or 'from' must be given-  when (from == Nothing && to == Nothing) mzero-  fs <- getFileStore-  -- if 'to' is not specified, defaults to current revision-  -- if 'from' is not specified, defaults to revision immediately before 'to'-  from' <- case (from, to) of-              (Just _, _)        -> return from-              (Nothing, Nothing) -> return from-              (Nothing, Just t)  -> do-                pageHist <- liftIO $ history fs [file]-                                     (TimeRange Nothing Nothing)-                                     Nothing-                let (_, upto) = break (\r -> idsMatch fs (revId r) t)-                                  pageHist-                return $ if length upto >= 2-                            -- immediately preceding revision-                            then Just $ revId $ upto !! 1-                            else Nothing-  result' <- liftIO $ E.try $ getDiff fs file from' to-  case result' of-       Left NotFound  -> mzero-       Left e         -> liftIO $ E.throwIO e-       Right htmlDiff -> formattedPage defaultPageLayout{-                                          pgPageName = page,-                                          pgRevision = from' `mplus` to,-                                          pgMessages = pMessages params,-                                          pgTabs = DiffTab :-                                                   pgTabs defaultPageLayout,-                                          pgSelectedTab = DiffTab,-                                          pgTitle = page-                                          }-                                       htmlDiff--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--editPage :: Handler-editPage = withData editPage'--editPage' :: Params -> Handler-editPage' params = do-  let rev = pRevision params  -- if this is set, we're doing a revert-  fs <- getFileStore-  page <- getPage-  cfg <- getConfig-  let getRevisionAndText = E.catch-        (do c <- liftIO $ retrieve fs (pathForPage page $ defaultExtension cfg) rev-            -- even if pRevision is set, we return revId of latest-            -- saved version (because we're doing a revert and-            -- we don't want gitit to merge the changes with the-            -- latest version)-            r <- liftIO $ latest fs (pathForPage page $ defaultExtension cfg) >>= revision fs-            return (Just $ revId r, c))-        (\e -> if e == NotFound-                  then return (Nothing, "")-                  else E.throwIO e)-  (mbRev, raw) <- case pEditedText params of-                         Nothing -> liftIO getRevisionAndText-                         Just t  -> let r = if null (pSHA1 params)-                                               then Nothing-                                               else Just (pSHA1 params)-                                    in return (r, t)-  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)-                    -- disable editing of text box if it's a revert-                    then [strAttr "readonly" "yes",-                          strAttr "style" "color: gray"]-                    else []-  base' <- getWikiBase-  let editForm = gui (base' ++ urlForPage page) ! [identifier "editform"] <<-                   [ sha1Box-                   , textarea ! (readonly ++ [cols "80", name "editedText",-                                  identifier "editedText"]) << raw-                   , br-                   , label ! [thefor "logMsg"] << "Description of changes:"-                   , br-                   , textfield "logMsg" ! (readonly ++ [value logMsg])-                   , 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-                   ]-  let pgScripts' = ["preview.js"]-  let pgScripts'' = case mathMethod cfg of-       JsMathScript -> "jsMath/easy/load.js" : pgScripts'-       MathML       -> "MathMLinHTML.js" : pgScripts'-       MathJax url  -> url : pgScripts'-       _            -> pgScripts'-  formattedPage defaultPageLayout{-                  pgPageName = page,-                  pgMessages = messages,-                  pgRevision = rev,-                  pgShowPageTools = False,-                  pgShowSiteNav = False,-                  pgMarkupHelp = Just $ markupHelp cfg,-                  pgSelectedTab = EditTab,-                  pgScripts = pgScripts'',-                  pgTitle = ("Editing " ++ page)-                  } editForm--confirmDelete :: Handler-confirmDelete = do-  page <- getPage-  fs <- getFileStore-  cfg <- getConfig-  -- determine whether there is a corresponding page, and if not whether there-  -- is a corresponding file-  pageTest <- liftIO $ E.try $ latest fs (pathForPage page $ defaultExtension cfg)-  fileToDelete <- case pageTest of-                       Right _        -> return $ pathForPage page $ defaultExtension cfg -- a page-                       Left  NotFound -> do-                         fileTest <- liftIO $ E.try $ latest fs page-                         case fileTest of-                              Right _       -> return page  -- a source file-                              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!"-        , br ]-  formattedPage defaultPageLayout{ pgTitle = "Delete " ++ page ++ "?" } $-    if null fileToDelete-       then ulist ! [theclass "messages"] << li <<-            "There is no file or page by that name."-       else confirmForm--deletePage :: Handler-deletePage = withData $ \(params :: Params) -> do-  page <- getPage-  cfg <- getConfig-  let file = pFileToDelete params-  mbUser <- getLoggedInUser-  (user, email) <- case mbUser of-                        Nothing -> return ("Anonymous", "")-                        Just u  -> return (uUsername u, uEmail u)-  let author = Author user email-  let descrip = "Deleted using web interface."-  base' <- getWikiBase-  if pConfirm params && (file == page || file == page <.> (defaultExtension cfg))-     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"--updatePage :: Handler-updatePage = withData $ \(params :: Params) -> do-  page <- getPage-  cfg <- getConfig-  mbUser <- getLoggedInUser-  (user, email) <- case mbUser of-                        Nothing -> return ("Anonymous", "")-                        Just u  -> return (uUsername u, uEmail u)-  editedText <- case pEditedText params of-                     Nothing -> error "No body text in POST request"-                     Just b  -> applyPreCommitPlugins b-  let logMsg = pLogMsg params `orIfNull` defaultSummary cfg-  let oldSHA1 = pSHA1 params-  fs <- getFileStore-  base' <- getWikiBase-  if null . filter (not . isSpace) $ logMsg-     then withMessages ["Description cannot be empty."] editPage-     else do-       when (length editedText > fromIntegral (maxPageSize cfg)) $-          error "Page exceeds maximum size."-       -- check SHA1 in case page has been modified, merge-       modifyRes <- if null oldSHA1-                       then liftIO $ create fs (pathForPage page $ defaultExtension cfg)-                                       (Author user email) logMsg editedText >>-                                     return (Right ())-                       else do-                         expireCachedFile (pathForPage page $ defaultExtension cfg) `mplus` return ()-                         liftIO $ E.catch (modify fs (pathForPage page $ defaultExtension cfg)-                                            oldSHA1 (Author user email) logMsg-                                            editedText)-                                     (\e -> if e == Unchanged-                                               then return (Right ())-                                               else E.throwIO e)-       case modifyRes of-            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 ++-                      " have been merged into your edits below. " ++-                      if conflicts-                         then "Please resolve conflicts and Save."-                         else "Please review and Save."-               editPage' $-                 params{ pEditedText = Just mergedText,-                         pSHA1       = revId mergedWithRev,-                         pMessages   = [mergeMsg] }--indexPage :: Handler-indexPage = do-  path' <- getPath-  base' <- getWikiBase-  cfg <- getConfig-  let ext = defaultExtension cfg-  let prefix' = if null path' then "" else path' ++ "/"-  fs <- getFileStore-  listing <- liftIO $ directory fs prefix'-  let isNotDiscussionPage (FSFile f) = isNotDiscussPageFile f-      isNotDiscussionPage (FSDirectory _) = return True-  prunedListing <- filterM isNotDiscussionPage listing-  let htmlIndex = fileListToHtml base' prefix' ext prunedListing-  formattedPage defaultPageLayout{-                  pgPageName = prefix',-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgScripts = [],-                  pgTitle = "Contents"} htmlIndex--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)"-        ]-      fileLink (FSDirectory f) =-        li ! [theclass "folder"] <<-          anchor ! [href $ base' ++ urlForPage (prefix ++ f) ++ "/"] << f-      updirs = drop 1 $ inits $ splitPath $ '/' : prefix-      uplink = foldr (\d accum ->-                  concatHtml [ anchor ! [theclass "updir",-                                         href $ 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---- NOTE:  The current implementation of categoryPage does not go via the--- filestore abstraction.  That is bad, but can only be fixed if we add--- more sophisticated searching options to filestore.-categoryPage :: Handler-categoryPage = do-  path' <- getPath-  cfg <- getConfig-  let pcategories = wordsBy (==',') path'-  let repoPath = repositoryPath cfg-  let categoryDescription = "Category: " ++ (intercalate " + " pcategories)-  fs <- getFileStore-  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile-  matches <- liftM catMaybes $-             forM pages $ \f -> do-               categories <- liftIO $ readCategories $ repoPath </> f-               return $ if all ( `elem` categories) pcategories-                           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' ++-        (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) -  formattedPage defaultPageLayout{-                  pgPageName = categoryDescription,-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgScripts = ["search.js"],-                  pgTitle = categoryDescription }-                matchList--categoryListPage :: Handler-categoryListPage = do-  cfg <- getConfig-  let repoPath = repositoryPath cfg-  fs <- getFileStore-  pages <- liftIO (index fs) >>= filterM isPageFile >>= filterM isNotDiscussPageFile-  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-  formattedPage defaultPageLayout{-                  pgPageName = "Categories",-                  pgShowPageTools = False,-                  pgTabs = [],-                  pgScripts = ["search.js"],-                  pgTitle = "Categories" } htmlMatches--expireCache :: Handler-expireCache = do-  page <- getPage-  cfg <- getConfig-  -- try it as a page first, then as an uploaded file-  expireCachedFile (pathForPage page $ defaultExtension cfg)-  expireCachedFile page-  ok $ toResponse ()--feedHandler :: Handler-feedHandler = do-  cfg <- getConfig-  when (not $ useFeed cfg) mzero-  base' <- getWikiBase-  feedBase <- if null (baseUrl cfg)  -- if baseUrl blank, try to get it from Host header-                 then do-                   mbHost <- getHost-                   case mbHost of-                        Nothing    -> error "Could not determine base URL"-                        Just hn    -> return $ "http://" ++ hn ++ base'-                 else case baseUrl cfg ++ base' of-                           w@('h':'t':'t':'p':'s':':':'/':'/':_) -> return w-                           x@('h':'t':'t':'p':':':'/':'/':_) -> return x-                           y                                 -> return $ "http://" ++ y-  let fc = FeedConfig{-              fcTitle = wikiTitle cfg-            , fcBaseUrl = feedBase-            , fcFeedDays = feedDays cfg }-  path' <- getPath     -- e.g. "foo/bar" if they hit /_feed/foo/bar-  let file = (path' `orIfNull` "_site") <.> "feed"-  let mbPath = if null path' then Nothing else Just path'-  -- first, check for a cached version that is recent enough-  now <- liftIO getCurrentTime-  let isRecentEnough t = truncate (diffUTCTime now t) < 60 * feedRefreshTime cfg-  mbCached <- lookupCache file-  case mbCached of-       Just (modtime, contents) | isRecentEnough modtime -> do-            let emptyResponse = setContentType "application/atom+xml; charset=utf-8" . toResponse $ ()-            ok $ emptyResponse{rsBody = B.fromChunks [contents]}-       _ -> do-            fs <- getFileStore-            resp' <- liftM toResponse $ liftIO (filestoreToXmlFeed fc fs mbPath)-            cacheContents file $ S.concat $ B.toChunks $ rsBody resp'-            ok . setContentType "application/atom+xml; charset=UTF-8" $ resp'

@@ -1,224 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>-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 for more details.-You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- | Functions for initializing a Gitit wiki.--}--module Network.Gitit.Initialize ( initializeGititState-                                , recompilePageTemplate-                                , compilePageTemplate-                                , createStaticIfMissing-                                , createRepoIfMissing-                                , createDefaultPages-                                , createTemplateIfMissing )-where-import System.FilePath ((</>), (<.>))-import Data.FileStore-import qualified Data.Map as M-import qualified Data.Set as Set-import Network.Gitit.Util (readFileUTF8)-import Network.Gitit.Types-import Network.Gitit.State-import Network.Gitit.Framework-import Network.Gitit.Plugins-import Network.Gitit.Layout (defaultRenderPage)-import Paths_gitit (getDataFileName)-import Control.Exception (throwIO, try)-import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)-import Control.Monad (unless, forM_, liftM)-import Text.Pandoc-import System.Log.Logger (logM, Priority(..))-import qualified Text.StringTemplate as T--#if MIN_VERSION_pandoc(1,14,0)-import Text.Pandoc.Error (handleError)-#else-handleError :: Pandoc -> Pandoc-handleError = id-#endif---- | Initialize Gitit State.-initializeGititState :: Config -> IO ()-initializeGititState conf = do-  let userFile' = userFile conf-      pluginModules' = pluginModules conf-  plugins' <- loadPlugins pluginModules'--  userFileExists <- doesFileExist userFile'-  users' <- if userFileExists-               then liftM (M.fromList . read) $ readFileUTF8 userFile'-               else return M.empty--  templ <- compilePageTemplate (templatesDir conf)--  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-  updateGititState $ \st -> st{renderPage = defaultRenderPage ct}----- | Compile a master page template named @page.st@ in the directory specified.-compilePageTemplate :: FilePath -> IO (T.StringTemplate String)-compilePageTemplate tempsDir = do-  defaultGroup <- getDataFileName ("data" </> "templates") >>= T.directoryGroup-  customExists <- doesDirectoryExist tempsDir-  combinedGroup <--    if customExists-       -- default templates from data directory will be "shadowed"-       -- by templates from the user's template dir-       then do customGroup <- T.directoryGroup tempsDir-               return $ T.mergeSTGroups customGroup defaultGroup-       else do logM "gitit" WARNING $ "Custom template directory not found"-               return defaultGroup-  case T.getStringTemplate "page" combinedGroup of-        Just t    -> return t-        Nothing   -> error "Could not get string template"---- | Create templates dir if it doesn't exist.-createTemplateIfMissing :: Config -> IO ()-createTemplateIfMissing conf' = do-  templateExists <- doesDirectoryExist (templatesDir conf')-  unless templateExists $ do-    createDirectoryIfMissing True (templatesDir conf')-    templatePath <- getDataFileName $ "data" </> "templates"-    -- templs <- liftM (filter (`notElem` [".",".."])) $-    --  getDirectoryContents templatePath-    -- Copy footer.st, since this is the component users-    -- are most likely to want to customize:-    forM_ ["footer.st"] $ \t -> do-      copyFile (templatePath </> t) (templatesDir conf' </> t)-      logM "gitit" WARNING $ "Created " ++ (templatesDir conf' </> t)---- | Create page repository unless it exists.-createRepoIfMissing :: Config -> IO ()-createRepoIfMissing conf = do-  let fs = filestoreFromConfig conf-  repoExists <- try (initialize fs) >>= \res ->-    case res of-         Right _               -> do-           logM "gitit" WARNING $ "Created repository in " ++ repositoryPath conf-           return False-         Left RepositoryExists -> return True-         Left e                -> throwIO e >> return False-  unless repoExists $ createDefaultPages conf--createDefaultPages :: Config -> IO ()-createDefaultPages conf = do-    let fs = filestoreFromConfig conf-        pt = defaultPageType conf-        toPandoc = handleError . readMarkdown def{ readerSmart = True }-        defOpts = def{ writerStandalone = False-                     , writerHTMLMathMethod = JsMath-                              (Just "/js/jsMath/easy/load.js")-                     , writerExtensions = if showLHSBirdTracks conf-                                             then Set.insert-                                                  Ext_literate_haskell-                                                  $ writerExtensions def-                                             else writerExtensions def-                     }-        -- note: we convert this (markdown) to the default page format-        converter = case pt of-                       Markdown   -> id-                       LaTeX      -> writeLaTeX defOpts . toPandoc-                       HTML       -> writeHtmlString defOpts . toPandoc-                       RST        -> writeRST defOpts . toPandoc-                       Textile    -> writeTextile defOpts . toPandoc-                       Org        -> writeOrg defOpts . toPandoc-                       DocBook    -> writeDocbook defOpts . toPandoc-                       MediaWiki  -> writeMediaWiki defOpts . toPandoc-#if MIN_VERSION_pandoc(1,14,0)-                       CommonMark -> writeCommonMark defOpts . toPandoc-#else-                       CommonMark -> error "CommonMark support requires pandoc >= 1.14"-#endif--    welcomepath <- getDataFileName $ "data" </> "FrontPage" <.> "page"-    welcomecontents <- liftM converter $ readFileUTF8 welcomepath-    helppath <- getDataFileName $ "data" </> "Help" <.> "page"-    helpcontentsInitial <- liftM converter $ readFileUTF8 helppath-    markuppath <- getDataFileName $ "data" </> "markup" <.> show pt-    helpcontentsMarkup <- liftM converter $ readFileUTF8  markuppath-    let helpcontents = helpcontentsInitial ++ "\n\n" ++ helpcontentsMarkup-    usersguidepath <- getDataFileName "README.markdown"-    usersguidecontents <- liftM converter $ readFileUTF8 usersguidepath-    -- include header in case user changes default format:-    let header = "---\nformat: " ++-          show pt ++ (if defaultLHS conf then "+lhs" else "") ++-          "\n...\n\n"-    -- add front page, help page, and user's guide-    let auth = Author "Gitit" ""-    createIfMissing fs (frontPage conf <.> defaultExtension conf) auth "Default front page"-      $ header ++ welcomecontents-    createIfMissing fs ("Help" <.> defaultExtension conf) auth "Default help page"-      $ header ++ helpcontents-    createIfMissing fs ("Gitit User's Guide" <.> defaultExtension conf) auth "User's guide (README)"-      $ header ++ usersguidecontents--createIfMissing :: FileStore -> FilePath -> Author -> Description -> String -> IO ()-createIfMissing fs p a comm cont = do-  res <- try $ create fs p a comm cont-  case res of-       Right _ -> logM "gitit" WARNING ("Added " ++ p ++ " to repository")-       Left ResourceExists -> return ()-       Left e              -> throwIO e >> return ()---- | Create static directory unless it exists.-createStaticIfMissing :: Config -> IO ()-createStaticIfMissing conf = do-  let staticdir = staticDir conf-  staticExists <- doesDirectoryExist staticdir-  unless staticExists $ do--    let cssdir = staticdir </> "css"-    createDirectoryIfMissing True cssdir-    cssDataDir <- getDataFileName $ "data" </> "static" </> "css"-    -- cssFiles <- liftM (filter (\f -> takeExtension f == ".css")) $ getDirectoryContents cssDataDir-    forM_ ["custom.css"] $ \f -> do-      copyFile (cssDataDir </> f) (cssdir </> f)-      logM "gitit" WARNING $ "Created " ++ (cssdir </> f)--    {--    let icondir = staticdir </> "img" </> "icons"-    createDirectoryIfMissing True icondir-    iconDataDir <- getDataFileName $ "data" </> "static" </> "img" </> "icons"-    iconFiles <- liftM (filter (\f -> takeExtension f == ".png")) $ getDirectoryContents iconDataDir-    forM_ iconFiles $ \f -> do-      copyFile (iconDataDir </> f) (icondir </> f)-      logM "gitit" WARNING $ "Created " ++ (icondir </> f)-    -}--    logopath <- getDataFileName $ "data" </> "static" </> "img" </> "logo.png"-    createDirectoryIfMissing True $ staticdir </> "img"-    copyFile logopath $ staticdir </> "img" </> "logo.png"-    logM "gitit" WARNING $ "Created " ++ (staticdir </> "img" </> "logo.png")--    {--    let jsdir = staticdir </> "js"-    createDirectoryIfMissing True jsdir-    jsDataDir <- getDataFileName $ "data" </> "static" </> "js"-    javascripts <- liftM (filter (`notElem` [".", ".."])) $ getDirectoryContents jsDataDir-    forM_ javascripts $ \f -> do-      copyFile (jsDataDir </> f) (jsdir </> f)-      logM "gitit" WARNING $ "Created " ++ (jsdir </> f)-    -}-

@@ -1,176 +0,0 @@-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- | Interface for plugins.--A plugin is a Haskell module that is dynamically loaded by gitit.--There are three kinds of plugins: 'PageTransform's,-'PreParseTransform's, and 'PreCommitTransform's. These plugins differ-chiefly in where they are applied. 'PreCommitTransform' plugins are-applied just before changes to a page are saved and may transform-the raw source that is saved. 'PreParseTransform' plugins are applied-when a page is viewed and may alter the raw page source before it-is parsed as a 'Pandoc' document. Finally, 'PageTransform' plugins-modify the 'Pandoc' document that results after a page's source is-parsed, but before it is converted to HTML:-->                 +--------------------------+->                 | edited text from browser |->                 +--------------------------+->                              ||         <----  PreCommitTransform plugins->                              \/->                              ||         <----  saved to repository->                              \/->              +---------------------------------+->              | raw page source from repository |->              +---------------------------------+->                              ||         <----  PreParseTransform plugins->                              \/->                              ||         <----  markdown or RST reader->                              \/->                     +-----------------+->                     | Pandoc document |->                     +-----------------+->                              ||         <---- PageTransform plugins->                              \/->                   +---------------------+->                   | new Pandoc document |->                   +---------------------+->                              ||         <---- HTML writer->                              \/->                   +----------------------+->                   | HTML version of page |->                   +----------------------+--Note that 'PreParseTransform' and 'PageTransform' plugins do not alter-the page source stored in the repository. They only affect what is-visible on the website.  Only 'PreCommitTransform' plugins can-alter what is stored in the repository.--Note also that 'PreParseTransform' and 'PageTransform' plugins will-not be run when the cached version of a page is used.  Plugins can-use the 'doNotCache' command to prevent a page from being cached,-if their behavior is sensitive to things that might change from-one time to another (such as the time or currently logged-in user).--You can use the helper functions 'mkPageTransform' and 'mkPageTransformM'-to create 'PageTransform' plugins from a transformation of any-of the basic types used by Pandoc (for example, @Inline@, @Block@,-@[Inline]@, even @String@). Here is a simple (if silly) example:--> -- Deprofanizer.hs-> module Deprofanizer (plugin) where->-> -- This plugin replaces profane words with "XXXXX".->-> import Network.Gitit.Interface-> import Data.Char (toLower)->-> plugin :: Plugin-> plugin = mkPageTransform deprofanize->-> deprofanize :: Inline -> Inline-> deprofanize (Str x) | isBadWord x = Str "XXXXX"-> deprofanize x                     = x->-> isBadWord :: String -> Bool-> isBadWord x = (map toLower x) `elem` ["darn", "blasted", "stinker"]-> -- there are more, but this is a family program--Further examples can be found in the @plugins@ directory in-the source distribution.  If you have installed gitit using Cabal,-you can also find them in the directory-@CABALDIR\/share\/gitit-X.Y.Z\/plugins@, where @CABALDIR@ is the cabal-install directory and @X.Y.Z@ is the version number of gitit.---}--module Network.Gitit.Interface ( Plugin(..)-                               , PluginM-                               , mkPageTransform-                               , mkPageTransformM-                               , Config(..)-                               , Request(..)-                               , User(..)-                               , Context(..)-                               , PageType(..)-                               , PageLayout(..)-                               , askConfig-                               , askUser-                               , askRequest-                               , askFileStore-                               , askMeta-                               , doNotCache-                               , getContext-                               , modifyContext-                               , inlinesToURL-                               , inlinesToString-                               , liftIO-                               , withTempDir-                               , module Text.Pandoc.Definition-                               , module Text.Pandoc.Generic-                               )-where-import Text.Pandoc.Definition-import Text.Pandoc.Generic-import Data.Data-import Network.Gitit.Types-import Network.Gitit.ContentTransformer-import Network.Gitit.Util (withTempDir)-import Network.Gitit.Server (Request(..))-import Control.Monad.Reader (ask)-import Control.Monad.Trans (liftIO)-import Control.Monad (liftM)-import Data.FileStore (FileStore)---- | Returns the current wiki configuration.-askConfig :: PluginM Config-askConfig = liftM pluginConfig ask---- | Returns @Just@ the logged in user, or @Nothing@ if nobody is logged in.-askUser :: PluginM (Maybe User)-askUser = liftM pluginUser ask---- | Returns the complete HTTP request.-askRequest :: PluginM Request-askRequest = liftM pluginRequest ask---- | Returns the wiki filestore.-askFileStore :: PluginM FileStore-askFileStore = liftM pluginFileStore ask---- | Returns the page meta data-askMeta :: PluginM [(String, String)]-askMeta = liftM ctxMeta getContext---- | Indicates that the current page or file is not to be cached.-doNotCache :: PluginM ()-doNotCache = modifyContext (\ctx -> ctx{ ctxCacheable = False })---- | Lifts a function from @a -> a@ (for example, @Inline -> Inline@,--- @Block -> Block@, @[Inline] -> [Inline]@, or @String -> String@)--- to a 'PageTransform' plugin.-mkPageTransform :: Data a => (a -> a) -> Plugin-mkPageTransform fn = PageTransform $ return . bottomUp fn---- | Monadic version of 'mkPageTransform'.--- Lifts a function from @a -> m a@ to a 'PageTransform' plugin.-mkPageTransformM :: Data a => (a -> PluginM a) -> Plugin-mkPageTransformM =  PageTransform . bottomUpM-

@@ -1,170 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions and data structures for wiki page layout.--}--module Network.Gitit.Layout ( defaultPageLayout-                            , defaultRenderPage-                            , formattedPage-                            , filledPageTemplate-                            , uploadsAllowed-                            )-where-import Network.Gitit.Server-import Network.Gitit.Framework-import Network.Gitit.State-import Network.Gitit.Types-import Network.Gitit.Export (exportFormats)-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, isJust, fromJust)--defaultPageLayout :: PageLayout-defaultPageLayout = PageLayout-  { pgPageName       = ""-  , pgRevision       = Nothing-  , pgPrintable      = False-  , pgMessages       = []-  , pgTitle          = ""-  , pgScripts        = []-  , pgShowPageTools  = True-  , pgShowSiteNav    = True-  , pgMarkupHelp     = Nothing-  , pgTabs           = [ViewTab, EditTab, HistoryTab, DiscussTab]-  , pgSelectedTab    = ViewTab-  , pgLinkToFeed     = False-  }---- | Returns formatted page-formattedPage :: PageLayout -> Html -> Handler-formattedPage layout htmlContents = do-  renderer <- queryGititState renderPage-  renderer layout htmlContents---- | Given a compiled string template, returns a page renderer.-defaultRenderPage :: T.StringTemplate String -> PageLayout -> Html -> Handler-defaultRenderPage templ layout htmlContents = do-  cfg <- getConfig-  base' <- getWikiBase-  ok . setContentType "text/html; charset=utf-8" . toResponse . T.render .-       filledPageTemplate base' cfg layout htmlContents $ templ---- | Returns a page template with gitit variables filled in.-filledPageTemplate :: String -> Config -> PageLayout -> Html ->-                      T.StringTemplate String -> T.StringTemplate String-filledPageTemplate base' cfg layout htmlContents templ =-  let rev  = pgRevision layout-      page = pgPageName layout-      prefixedScript x = case x of-                           'h':'t':'t':'p':_  -> x-                           _                  -> 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-      article = if isDiscussPage page then drop 1 page else page-      discussion = '@':article-      tabli tab = if tab == pgSelectedTab layout-                     then li ! [theclass "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-  in               T.setAttribute "base" base' .-                   T.setAttribute "feed" (pgLinkToFeed layout) .-                   setStrAttr "wikititle" (wikiTitle cfg) .-                   setStrAttr "pagetitle" (pgTitle layout) .-                   T.setAttribute "javascripts" javascriptlinks .-                   setStrAttr "pagename" page .-                   setStrAttr "articlename" article .-                   setStrAttr "discussionname" discussion .-                   setStrAttr "pageUrl" (urlForPage page) .-                   setStrAttr "articleUrl" (urlForPage article) .-                   setStrAttr "discussionUrl" (urlForPage discussion) .-                   setBoolAttr "ispage" (isPage page) .-                   setBoolAttr "isarticlepage" (isPage page && not (isDiscussPage page)) .-                   setBoolAttr "isdiscusspage" (isDiscussPage page) .-                   setBoolAttr "pagetools" (pgShowPageTools layout) .-                   setBoolAttr "sitenav" (pgShowSiteNav layout) .-                   maybe id (T.setAttribute "markuphelp") (pgMarkupHelp layout) .-                   setBoolAttr "printable" (pgPrintable layout) .-                   maybe id (T.setAttribute "revision") rev .-                   T.setAttribute "exportbox"-                       (renderHtmlFragment $  exportBox base' cfg page rev) .-                   (if null (pgTabs layout) then id else T.setAttribute "tabs"-                       (renderHtmlFragment 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) .-                   setBoolAttr "wikiupload" ( uploadsAllowed cfg) $-                   templ---exportBox :: String -> Config -> String -> Maybe String -> Html-exportBox base' cfg page rev | not (isSourceCode page) =-  gui (base' ++ urlForPage page) ! [identifier "exportbox"] <<-    ([ textfield "revision" ! [thestyle "display: none;",-         value (fromJust rev)] | isJust rev ] ++-     [ select ! [name "format"] <<-         map ((\f -> option ! [value f] << f) . fst) (exportFormats cfg)-     , primHtmlChar "nbsp"-     , submit "export" "Export" ])-exportBox _ _ _ _ = noHtml---- auxiliary functions:--linkForTab :: (Tab -> Html -> Html) -> String -> String -> Maybe String -> Tab -> Html-linkForTab tabli base' page _ HistoryTab =-  tabli HistoryTab << anchor ! [href $ base' ++ "/_history" ++ urlForPage page] << "history"-linkForTab tabli _ _ _ DiffTab =-  tabli DiffTab << anchor ! [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 ++-                      case rev of-                           Just r  -> "?revision=" ++ r-                           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"-linkForTab tabli base' page rev EditTab =-  tabli EditTab << anchor !-    [href $ base' ++ "/_edit" ++ urlForPage page ++-            case rev of-                  Just r   -> "?revision=" ++ r ++ "&" ++-                               urlEncodeVars [("logMsg", "Revert to " ++ r)]-                  Nothing  -> ""] << if isNothing rev-                                         then "edit"-                                         else "revert"--uploadsAllowed :: Config -> Bool-uploadsAllowed = (0 <) . maxUploadSize

@@ -1,201 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions for translating between Page structures and raw--  text strings.  The strings may begin with a metadata block,--  which looks like this (it is valid YAML):----  > -----  > title: Custom Title--  > format: markdown+lhs--  > toc: yes--  > categories: foo bar baz--  > ...----  This would tell gitit to use "Custom Title" as the displayed--  page title (instead of the page name), to interpret the page--  text as markdown with literate haskell, to include a table of--  contents, and to include the page in the categories foo, bar,--  and baz.----  The metadata block may be omitted entirely, and any particular line--  may be omitted. The categories in the @categories@ field should be--  separated by spaces. Commas will be treated as spaces.----  Metadata value fields may be continued on the next line, as long as--  it is nonblank and starts with a space character.----  Unrecognized metadata fields are simply ignored.--}--module Network.Gitit.Page ( stringToPage-                          , pageToString-                          , readCategories-                          )-where-import Network.Gitit.Types-import Network.Gitit.Util (trim, splitCategories, parsePageType)-import Text.ParserCombinators.Parsec-import Data.Char (toLower)-import Data.List (intercalate)-import Data.Maybe (fromMaybe)-import Data.ByteString.UTF8 (toString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import System.IO (withFile, Handle, IOMode(..))-import qualified Control.Exception as E-import System.IO.Error (isEOFError)-#if MIN_VERSION_base(4,5,0)-#else-import Codec.Binary.UTF8.String (encodeString)-#endif--parseMetadata :: String -> ([(String, String)], String)-parseMetadata raw =-  case parse pMetadataBlock "" raw of-    Left _           -> ([], raw)-    Right (ls, rest) -> (ls, rest)--pMetadataBlock :: GenParser Char st ([(String, String)], String)-pMetadataBlock = try $ do-  _ <- string "---"-  _ <- pBlankline-  ls <- manyTill pMetadataLine pMetaEnd-  skipMany pBlankline-  rest <- getInput-  return (ls, rest)--pMetaEnd :: GenParser Char st Char-pMetaEnd = try $ do-  string "..." <|> string "---"-  pBlankline--pBlankline :: GenParser Char st Char-pBlankline = try $ many (oneOf " \t") >> newline--pMetadataLine :: GenParser Char st (String, String)-pMetadataLine = try $ do-  first <- letter-  rest <- many (letter <|> digit <|> oneOf "-_")-  let ident = first:rest-  skipMany (oneOf " \t")-  _ <- char ':'-  rawval <- many $ noneOf "\n\r"-                 <|> (try $ newline >> notFollowedBy pBlankline >>-                            skipMany1 (oneOf " \t") >> return ' ')-  _ <- newline-  return (ident, trim rawval)---- | Read a string (the contents of a page file) and produce a Page--- object, using defaults except when overridden by metadata.-stringToPage :: Config -> String -> String -> Page-stringToPage conf pagename raw =-  let (ls, rest) = parseMetadata raw-      page' = Page { pageName        = pagename-                   , pageFormat      = defaultPageType conf-                   , pageLHS         = defaultLHS conf-                   , pageTOC         = tableOfContents conf-                   , pageTitle       = pagename-                   , pageCategories  = []-                   , pageText        = filter (/= '\r') rest-                   , pageMeta        = ls }-  in  foldr adjustPage page' ls--adjustPage :: (String, String) -> Page -> Page-adjustPage ("title", val) page' = page' { pageTitle = val }-adjustPage ("format", val) page' = page' { pageFormat = pt, pageLHS = lhs }-    where (pt, lhs) = parsePageType val-adjustPage ("toc", val) page' = page' {-  pageTOC = map toLower val `elem` ["yes","true"] }-adjustPage ("categories", val) page' =-   page' { pageCategories = splitCategories val ++ pageCategories page' }-adjustPage (_, _) page' = page'---- | Write a string (the contents of a page file) corresponding to--- a Page object, using explicit metadata only when needed.-pageToString :: Config -> Page -> String-pageToString conf page' =-  let pagename   = pageName page'-      pagetitle  = pageTitle page'-      pageformat = pageFormat page'-      pagelhs    = pageLHS page'-      pagetoc    = pageTOC page'-      pagecats   = pageCategories page'-      metadata   = filter-                       (\(k, _) -> not (k `elem`-                           ["title", "format", "toc", "categories"]))-                       (pageMeta page')-      metadata'  = (if pagename /= pagetitle-                       then "title: " ++ pagetitle ++ "\n"-                       else "") ++-                   (if pageformat /= defaultPageType conf ||-                          pagelhs /= defaultLHS conf-                       then "format: " ++-                            map toLower (show pageformat) ++-                            if pagelhs then "+lhs\n" else "\n"-                       else "") ++-                   (if pagetoc /= tableOfContents conf-                       then "toc: " ++-                            (if pagetoc then "yes" else "no") ++ "\n"-                       else "") ++-                   (if not (null pagecats)-                       then "categories: " ++ intercalate ", " pagecats ++ "\n"-                       else "") ++-                   (unlines (map (\(k, v) -> k ++ ": " ++ v) metadata))-  in (if null metadata' then "" else "---\n" ++ metadata' ++ "...\n\n")-        ++ pageText page'---- | Read categories from metadata strictly.-readCategories :: FilePath -> IO [String]-readCategories f =-#if MIN_VERSION_base(4,5,0)-  withFile f ReadMode $ \h ->-#else-  withFile (encodeString f) ReadMode $ \h ->-#endif-    E.catch (do fl <- B.hGetLine h-                if dashline fl-                   then do -- get rest of metadata-                     rest <- hGetLinesTill h dotline-                     let (md,_) = parseMetadata $ unlines $ "---":rest-                     return $ splitCategories $ fromMaybe ""-                            $ lookup "categories" md-                   else return [])-       (\e -> if isEOFError e then return [] else E.throwIO e)--dashline :: B.ByteString -> Bool-dashline x =-  case BC.unpack x of-       ('-':'-':'-':xs) | all (==' ') xs -> True-       _ -> False--dotline :: B.ByteString -> Bool-dotline x =-  case BC.unpack x of-       ('.':'.':'.':xs) | all (==' ') xs -> True-       _ -> False--hGetLinesTill :: Handle -> (B.ByteString -> Bool) -> IO [String]-hGetLinesTill h end = do-  next <- B.hGetLine h-  if end next-     then return [toString next]-     else do-       rest <- hGetLinesTill h end-       return (toString next:rest)

@@ -1,92 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions for loading plugins.--}--module Network.Gitit.Plugins ( loadPlugin, loadPlugins )-where-import Network.Gitit.Types-import System.FilePath (takeBaseName)-import Control.Monad (unless)-import System.Log.Logger (logM, Priority(..))-#ifdef _PLUGINS-import Data.List (isInfixOf, isPrefixOf)-import GHC-import GHC.Paths-import Unsafe.Coerce--loadPlugin :: FilePath -> IO Plugin-loadPlugin pluginName = do-  logM "gitit" WARNING ("Loading plugin '" ++ pluginName ++ "'...")-  runGhc (Just libdir) $ do-    dflags <- getSessionDynFlags-    setSessionDynFlags dflags-    defaultCleanupHandler dflags $ do-      -- initDynFlags-      unless ("Network.Gitit.Plugin." `isPrefixOf` pluginName)-        $ do-            addTarget =<< guessTarget pluginName Nothing-            r <- load LoadAllTargets-            case r of-              Failed -> error $ "Error loading plugin: " ++ pluginName-              Succeeded -> return ()-      let modName =-            if "Network.Gitit.Plugin" `isPrefixOf` pluginName-               then pluginName-               else if "Network/Gitit/Plugin/" `isInfixOf` pluginName-                       then "Network.Gitit.Plugin." ++ takeBaseName pluginName-                       else takeBaseName pluginName-#if MIN_VERSION_ghc(7,4,0)-      pr <- parseImportDecl "import Prelude"-      i <- parseImportDecl "import Network.Gitit.Interface"-      m <- parseImportDecl ("import " ++ modName)-      setContext [IIDecl m, IIDecl  i, IIDecl pr]-#else-      pr <- findModule (mkModuleName "Prelude") Nothing-      i <- findModule (mkModuleName "Network.Gitit.Interface") Nothing-      m <- findModule (mkModuleName modName) Nothing-#if MIN_VERSION_ghc(7,2,0)-      setContext [IIModule m, IIModule i, IIModule pr] []-#elif MIN_VERSION_ghc(7,0,0)-      setContext [] [(m, Nothing), (i, Nothing), (pr, Nothing)]-#else-      setContext [] [m, i, pr]-#endif-#endif-      value <- compileExpr (modName ++ ".plugin :: Plugin")-      let value' = (unsafeCoerce value) :: Plugin-      return value'--#else--loadPlugin :: FilePath -> IO Plugin-loadPlugin pluginName = do-  error $ "Cannot load plugin '" ++ pluginName ++-          "'. gitit was not compiled with plugin support."-  return undefined--#endif--loadPlugins :: [FilePath] -> IO [Plugin]-loadPlugins pluginNames = do-  plugins' <- mapM loadPlugin pluginNames-  unless (null pluginNames) $ logM "gitit" WARNING "Finished loading plugins."-  return plugins'-

@@ -1,81 +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 :: Monad m-     => String             -- ^ URL-     -> [(String, String)] -- ^ Post parameters-     -> IO (m 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 . return-        _           -> hGetContents herr >>= return . fail------ | 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 :: Monad m-             => String -- ^ API key given by RPXNOW.-             -> String -- ^ Token passed by client.-             -> IO (m Identifier)-authenticate apiKey token = do-    body <- curl-                "https://rpxnow.com/api/v2/auth_info"-                [ ("apiKey", apiKey)-                , ("token", token)-                ]-    case body of-        Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s-        Right b ->-          case decode b >>= getObject of-            Error s -> return $ fail $ "Not a valid JSON response: " ++ s-            Ok o ->-              case valFromObj "stat" o of-                Error _ -> return $ fail "Missing 'stat' field"-                Ok "ok" -> return $ parseProfile o-                Ok stat -> return $ fail $ "Login not accepted: " ++ stat--parseProfile :: Monad m => JSObject JSValue -> m Identifier-parseProfile v = do-    profile <- resultToMonad $ valFromObj "profile" v >>= getObject-    ident <- resultToMonad $ 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 :: Monad m => JSValue -> m (JSObject JSValue)-getObject (JSObject o) = return o-getObject _ = fail "Not an object"--resultToMonad :: Monad m => Result a -> m a-resultToMonad (Ok x) = return x-resultToMonad (Error s) = fail s

@@ -1,63 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{--Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Re-exports Happstack functions needed by gitit, including-   replacements for Happstack functions that don't handle UTF-8 properly, and-   new functions for setting headers and zipping contents and for looking up IP-   addresses.--}--module Network.Gitit.Server-          ( module Happstack.Server-          , withExpiresHeaders-          , setContentType-          , setFilename-          , lookupIPAddr-          , getHost-          , compressedResponseFilter-          )-where-import Happstack.Server-import Happstack.Server.Compression (compressedResponseFilter)-import Network.Socket (getAddrInfo, defaultHints, addrAddress)-import Control.Monad.Reader-import Data.ByteString.UTF8 as U hiding (lines)--withExpiresHeaders :: ServerMonad m => m Response -> m Response-withExpiresHeaders = liftM (setHeader "Cache-Control" "max-age=21600")--setContentType :: String -> Response -> Response-setContentType = setHeader "Content-Type"--setFilename :: String -> Response -> Response-setFilename = setHeader "Content-Disposition" . \fname -> "attachment; filename=\"" ++ fname ++ "\""---- IP lookup--lookupIPAddr :: String -> IO (Maybe String)-lookupIPAddr hostname = do-  addrs <- getAddrInfo (Just defaultHints) (Just hostname) Nothing-  if null addrs-     then return Nothing-     else return $ Just $ takeWhile (/=':') $ show $ addrAddress $ case addrs of -- head addrs-                                                                     [] -> error "lookupIPAddr, no addrs"-                                                                     (x:_) -> x-getHost :: ServerMonad m => m (Maybe String)-getHost = liftM (maybe Nothing (Just . U.toString)) $ getHeaderM "Host"

@@ -1,139 +0,0 @@-{--Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Functions for maintaining user list and session state.--}--module Network.Gitit.State where--import qualified Data.Map as M-import System.Random (randomRIO)-import Data.Digest.Pure.SHA (sha512, showDigest)-import qualified Data.ByteString.Lazy.UTF8 as L (fromString)-import Data.IORef-import System.IO.Unsafe (unsafePerformIO)-import Control.Monad.Reader-import Data.FileStore-import Data.List (intercalate)-import System.Log.Logger (Priority(..), logM)-import Network.Gitit.Types--gititstate :: IORef GititState-gititstate = unsafePerformIO $  newIORef  GititState { sessions = undefined-                                                     , users = undefined-                                                     , templatesPath = undefined-                                                     , renderPage = undefined-                                                     , plugins = undefined }--updateGititState :: MonadIO m => (GititState -> GititState) -> m ()-updateGititState fn = liftIO $! atomicModifyIORef gititstate $ \st -> (fn st, ())--queryGititState :: MonadIO m => (GititState -> a) -> m a-queryGititState fn = liftM fn $ liftIO $! readIORef gititstate--debugMessage :: String -> GititServerPart ()-debugMessage msg = liftIO $ logM "gitit" DEBUG msg--mkUser :: String   -- username-       -> String   -- email-       -> String   -- unhashed password-       -> IO User-mkUser uname email pass = do-  salt <- genSalt-  return  User { uUsername = uname,-                 uPassword = Password { pSalt = salt,-                                        pHashed = hashPassword salt pass },-                 uEmail = email }--genSalt :: IO String-genSalt = replicateM 32 $ randomRIO ('0','z')--hashPassword :: String -> String -> String-hashPassword salt pass = showDigest $ sha512 $ L.fromString $ salt ++ pass--authUser :: String -> String -> GititServerPart Bool-authUser name pass = do-  users' <- queryGititState users-  case M.lookup name users' of-       Just u  -> do-         let salt = pSalt $ uPassword u-         let hashed = pHashed $ uPassword u-         return $ hashed == hashPassword salt pass-       Nothing -> return False--isUser :: String -> GititServerPart Bool-isUser name = liftM (M.member name) $ queryGititState users--addUser :: String -> User -> GititServerPart ()-addUser uname user =-  updateGititState (\s -> s { users = M.insert uname user (users s) }) >>-  getConfig >>=-  liftIO . writeUserFile--adjustUser :: String -> User -> GititServerPart ()-adjustUser uname user = updateGititState-  (\s -> s  { users = M.adjust (const user) uname (users s) }) >>-  getConfig >>=-  liftIO . writeUserFile--delUser :: String -> GititServerPart ()-delUser uname =-  updateGititState (\s -> s { users = M.delete uname (users s) }) >>-  getConfig >>=-  liftIO . writeUserFile--writeUserFile :: Config -> IO ()-writeUserFile conf = do-  usrs <- queryGititState users-  writeFile (userFile conf) $-      "[" ++ intercalate "\n," (map show $ M.toList usrs) ++ "\n]"--getUser :: String -> GititServerPart (Maybe User)-getUser uname = liftM (M.lookup uname) $ queryGititState users--isSession :: MonadIO m => SessionKey -> m Bool-isSession key = liftM (M.member key . unsession) $ queryGititState sessions--setSession :: MonadIO m => SessionKey -> SessionData -> m ()-setSession key u = updateGititState $ \s ->-  s { sessions = Sessions . M.insert key u . unsession $ sessions s }--newSession :: MonadIO m => SessionData -> m SessionKey-newSession u = do-  key <- liftIO $ randomRIO (0, 1000000000)-  setSession key u-  return key--delSession :: MonadIO m => SessionKey -> m ()-delSession key = updateGititState $ \s ->-  s { sessions = Sessions . M.delete key . unsession $ sessions s }--getSession :: MonadIO m => SessionKey -> m (Maybe SessionData)-getSession key = queryGititState $ M.lookup key . unsession . sessions--getConfig :: GititServerPart Config-getConfig = liftM wikiConfig ask--getFileStore :: GititServerPart FileStore-getFileStore = liftM wikiFileStore ask--getDefaultPageType :: GititServerPart PageType-getDefaultPageType = liftM defaultPageType getConfig--getDefaultLHS :: GititServerPart Bool-getDefaultLHS = liftM defaultLHS getConfig

@@ -1,489 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,-Anton van Straaten <anton@appsolutions.com>--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 for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- | Types for Gitit modules.--}--module Network.Gitit.Types (-                            PageType(..)-                           , FileStoreType(..)-                           , MathMethod(..)-                           , AuthenticationLevel(..)-                           , Config(..)-                           , Page(..)-                           , SessionKey-                           -- we do not export SessionData constructors, in case we need to extend  SessionData with other data in the future-                           , SessionData-                           , sessionData-                           , sessionDataGithubState-                           , sessionUser-                           , sessionGithubState-                           , User(..)-                           , Sessions(..)-                           , Password(..)-                           , GititState(..)-                           , HasContext-                           , modifyContext-                           , getContext-                           , ContentTransformer-                           , Plugin(..)-                           , PluginData(..)-                           , PluginM-                           , runPluginM-                           , Context(..)-                           , PageLayout(..)-                           , Tab(..)-                           , Recaptcha(..)-                           , Params(..)-                           , Command(..)-                           , WikiState(..)-                           , GititServerPart-                           , Handler-                           , fromEntities-                           , GithubConfig-                           , oAuth2-                           , org-                           , githubConfig) where--import Control.Monad.Reader (ReaderT, runReaderT, mplus)-import Control.Monad.State (StateT, runStateT, get, modify)-import Control.Monad (liftM)-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)-import Data.Time (parseTime)-#if MIN_VERSION_time(1,5,0)-import Data.Time (defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-#endif-import Data.FileStore.Types-import Network.Gitit.Server-import Text.HTML.TagSoup.Entity (lookupEntity)-import Data.Char (isSpace)-import Network.OAuth.OAuth2--data PageType = Markdown-              | CommonMark-              | RST-              | LaTeX-              | HTML-              | Textile-              | Org-              | DocBook-              | MediaWiki-                deriving (Read, Show, Eq)--data FileStoreType = Git | Darcs | Mercurial deriving Show--data MathMethod = MathML | JsMathScript | WebTeX String | RawTeX | MathJax String-                  deriving (Read, Show, Eq)--data AuthenticationLevel = Never | ForModify | ForRead-                  deriving (Read, Show, Eq, Ord)---- | Data structure for information read from config file.-data Config = Config {-  -- | Path of repository containing filestore-  repositoryPath       :: FilePath,-  -- | Type of repository-  repositoryType       :: FileStoreType,-  -- | Default page markup type for this wiki-  defaultPageType      :: PageType,-  -- | Default file extension for pages in this wiki-  defaultExtension     :: String,-  -- | How to handle LaTeX math in pages?-  mathMethod           :: MathMethod,-  -- | Treat as literate haskell by default?-  defaultLHS           :: Bool,-  -- | Show Haskell code with bird tracks-  showLHSBirdTracks    :: Bool,-  -- | Combinator to set @REMOTE_USER@ request header-  withUser             :: Handler -> Handler,-  -- | Handler for login, logout, register, etc.-  requireAuthentication :: AuthenticationLevel,-  -- | Specifies which actions require authentication.-  authHandler          :: Handler,-  -- | Path of users database-  userFile             :: FilePath,-  -- | Seconds of inactivity before session expires-  sessionTimeout       :: Int,-  -- | Directory containing page templates-  templatesDir         :: FilePath,-  -- | Path of server log file-  logFile              :: FilePath,-  -- | Severity filter for log messages (DEBUG, INFO,-  -- NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY)-  logLevel             :: Priority,-  -- | Path of static directory-  staticDir            :: FilePath,-  -- | Names of plugin modules to load-  pluginModules        :: [String],-  -- | Show table of contents on each page?-  tableOfContents      :: Bool,-  -- | Max size of file uploads-  maxUploadSize        :: Integer,-  -- | Max size of page uploads-  maxPageSize          :: Integer,-  -- | IP address to bind to-  address              :: String,-  -- | Port number to serve content on-  portNumber           :: Int,-  -- | Print debug info to the console?-  debugMode            :: Bool,-  -- | The front page of the wiki-  frontPage            :: String,-  -- | Pages that cannot be edited via web-  noEdit               :: [String],-  -- | Pages that cannot be deleted via web-  noDelete             :: [String],-  -- | Default summary if description left blank-  defaultSummary       :: String,-  -- | @Nothing@ = anyone can register.-  -- @Just (prompt, answers)@ = a user will-  -- be given the prompt and must give-  -- one of the answers to register.-  accessQuestion       :: Maybe (String, [String]),-  -- | Use ReCAPTCHA for user registration.-  useRecaptcha         :: Bool,-  recaptchaPublicKey   :: String,-  recaptchaPrivateKey  :: String,-  -- | RPX domain and key-  rpxDomain            :: String,-  rpxKey               :: String,-  -- | Should responses be compressed?-  compressResponses    :: Bool,-  -- | Should responses be cached?-  useCache             :: Bool,-  -- | Directory to hold cached pages-  cacheDir             :: FilePath,-  -- | Map associating mime types with file extensions-  mimeMap              :: M.Map String String,-  -- | Command to send notification emails-  mailCommand          :: String,-  -- | Text of password reset email-  resetPasswordMessage :: String,-  -- | Markup syntax help for edit sidebar-  markupHelp           :: String,-  -- | Provide an atom feed?-  useFeed              :: Bool,-  -- | Base URL of wiki, for use in feed-  baseUrl              :: String,-  -- | Title of wiki, used in feed-  useAbsoluteUrls      :: Bool,-  -- | Should WikiLinks be absolute w.r.t. the base URL?-  wikiTitle            :: String,-  -- | Number of days history to be included in feed-  feedDays             :: Integer,-  -- | Number of minutes to cache feeds before refreshing-  feedRefreshTime      :: Integer,-  -- | Allow PDF export?-  pdfExport            :: Bool,-  -- | Directory to search for pandoc customizations-  pandocUserData       :: Maybe FilePath,-  -- | Filter HTML through xss-sanitize-  xssSanitize          :: Bool,-  -- | The default number of days in the past to look for \"recent\" activity-  recentActivityDays   :: Int,-  -- | Github client data for authentication (id, secret, callback,-  -- authorize endpoint, access token endpoint)-  githubAuth           :: GithubConfig-  }---- | Data for rendering a wiki page.-data Page = Page {-    pageName        :: String-  , pageFormat      :: PageType-  , pageLHS         :: Bool-  , pageTOC         :: Bool-  , pageTitle       :: String-  , pageCategories  :: [String]-  , pageText        :: String-  , pageMeta        :: [(String, String)]-} deriving (Read, Show)--type SessionKey = Integer--data SessionData = SessionData {-  sessionUser :: Maybe String,-  sessionGithubState :: Maybe String-} deriving (Read,Show,Eq)--sessionData :: String -> SessionData-sessionData user = SessionData (Just user) Nothing--sessionDataGithubState  :: String -> SessionData-sessionDataGithubState  githubState = SessionData Nothing (Just githubState)--data Sessions a = Sessions {unsession::M.Map SessionKey a}-  deriving (Read,Show,Eq)---- Password salt hashedPassword-data Password = Password { pSalt :: String, pHashed :: String }-  deriving (Read,Show,Eq)--data User = User {-  uUsername :: String,-  uPassword :: Password,-  uEmail    :: String-} deriving (Show,Read)---- | Common state for all gitit wikis in an application.-data GititState = GititState {-  sessions       :: Sessions SessionData,-  users          :: M.Map String User,-  templatesPath  :: FilePath,-  renderPage     :: PageLayout -> Html -> Handler,-  plugins        :: [Plugin]-}--type ContentTransformer = StateT Context GititServerPart--data Plugin = PageTransform (Pandoc -> PluginM Pandoc)-            | PreParseTransform (String -> PluginM String)-            | PreCommitTransform (String -> PluginM String)--data PluginData = PluginData { pluginConfig    :: Config-                             , pluginUser      :: Maybe User-                             , pluginRequest   :: Request-                             , pluginFileStore :: FileStore-                             }--type PluginM = ReaderT PluginData (StateT Context IO)--runPluginM :: PluginM a -> PluginData -> Context -> IO (a, Context)-runPluginM plugin = runStateT . runReaderT plugin--data Context = Context { ctxFile            :: String-                       , ctxLayout          :: PageLayout-                       , ctxCacheable       :: Bool-                       , ctxTOC             :: Bool-                       , ctxBirdTracks      :: Bool-                       , ctxCategories      :: [String]-                       , ctxMeta            :: [(String, String)]-                       }--class (Monad m) => HasContext m where-  getContext    :: m Context-  modifyContext :: (Context -> Context) -> m ()--instance HasContext ContentTransformer where-  getContext    = get-  modifyContext = modify--instance HasContext PluginM where-  getContext    = get-  modifyContext = modify---- | Abstract representation of page layout (tabs, scripts, etc.)-data PageLayout = PageLayout-  { pgPageName       :: String-  , pgRevision       :: Maybe String-  , pgPrintable      :: Bool-  , pgMessages       :: [String]-  , pgTitle          :: String-  , pgScripts        :: [String]-  , pgShowPageTools  :: Bool-  , pgShowSiteNav    :: Bool-  , pgMarkupHelp     :: Maybe String-  , pgTabs           :: [Tab]-  , pgSelectedTab    :: Tab-  , pgLinkToFeed     :: Bool-  }--data Tab = ViewTab-         | EditTab-         | HistoryTab-         | DiscussTab-         | DiffTab-         deriving (Eq, Show)--data Recaptcha = Recaptcha {-    recaptchaChallengeField :: String-  , recaptchaResponseField  :: String-  } deriving (Read, Show)--instance FromData SessionKey where-     fromData = readCookieValue "sid"--data Params = Params { pUsername     :: String-                     , pPassword     :: String-                     , pPassword2    :: String-                     , pRevision     :: Maybe String-                     , pDestination  :: String-                     , pForUser      :: Maybe String-                     , pSince        :: Maybe UTCTime-                     , pRaw          :: String-                     , pLimit        :: Int-                     , pPatterns     :: [String]-                     , pGotoPage     :: String-                     , pFileToDelete :: String-                     , pEditedText   :: Maybe String-                     , pMessages     :: [String]-                     , pFrom         :: Maybe String-                     , pTo           :: Maybe String-                     , pFormat       :: String-                     , pSHA1         :: String-                     , pLogMsg       :: String-                     , pEmail        :: String-                     , pFullName     :: String-                     , pAccessCode   :: String-                     , pWikiname     :: String-                     , pPrintable    :: Bool-                     , pOverwrite    :: Bool-                     , pFilename     :: String-                     , pFilePath     :: FilePath-                     , pConfirm      :: Bool-                     , pSessionKey   :: Maybe SessionKey-                     , pRecaptcha    :: Recaptcha-                     , pResetCode    :: String-                     , pRedirect     :: Maybe Bool-                     }  deriving Show--instance FromReqURI [String] where-  fromReqURI s = case fromReqURI s of-                      Just (s' :: String) ->-                                   case reads s' of-                                        ((xs,""):_) -> xs-                                        _           -> Nothing-                      Nothing             -> Nothing--instance FromData Params where-     fromData = do-         let look' = look-         un <- look' "username"       `mplus` return ""-         pw <- look' "password"       `mplus` return ""-         p2 <- look' "password2"      `mplus` return ""-         rv <- (look' "revision" >>= \s ->-                 return (if null s then Nothing else Just s))-                 `mplus` return Nothing-         fu <- liftM Just (look' "forUser") `mplus` return Nothing-         si <- liftM (parseTime defaultTimeLocale "%Y-%m-%d") (look' "since")-                 `mplus` return Nothing  -- YYYY-mm-dd format-         ds <- look' "destination" `mplus` return ""-         ra <- look' "raw"            `mplus` return ""-         lt <- lookRead "limit"       `mplus` return 100-         pa <- look' "patterns"       `mplus` return ""-         gt <- look' "gotopage"       `mplus` return ""-         ft <- look' "filetodelete"   `mplus` return ""-         me <- looks "message"-         fm <- liftM Just (look' "from") `mplus` return Nothing-         to <- liftM Just (look' "to")   `mplus` return Nothing-         et <- liftM (Just . filter (/='\r')) (look' "editedText")-                 `mplus` return Nothing-         fo <- look' "format"         `mplus` return ""-         sh <- look' "sha1"           `mplus` return ""-         lm <- look' "logMsg"         `mplus` return ""-         em <- look' "email"          `mplus` return ""-         na <- look' "full_name_1"    `mplus` return ""-         wn <- look' "wikiname"       `mplus` return ""-         pr <- (look' "printable" >> return True) `mplus` return False-         ow <- liftM (=="yes") (look' "overwrite") `mplus` return False-         fileparams <- liftM Just (lookFile "file") `mplus` return Nothing-         let (fp, fn) = case fileparams of-                             Just (x,y,_) -> (x,y)-                             Nothing      -> ("","")-         ac <- look' "accessCode"     `mplus` return ""-         cn <- (look' "confirm" >> return True) `mplus` return False-         sk <- liftM Just (readCookieValue "sid") `mplus` return Nothing-         rc <- look' "recaptcha_challenge_field" `mplus` return ""-         rr <- look' "recaptcha_response_field" `mplus` return ""-         rk <- look' "reset_code" `mplus` return ""-         rd <- (look' "redirect" >>= \r -> return (case r of-             "yes" -> Just True-             "no" -> Just False-             _ -> Nothing)) `mplus` return Nothing-         return   Params { pUsername     = un-                         , pPassword     = pw-                         , pPassword2    = p2-                         , pRevision     = rv-                         , pForUser      = fu-                         , pSince        = si-                         , pDestination  = ds-                         , pRaw          = ra-                         , pLimit        = lt-                         , pPatterns     = words pa-                         , pGotoPage     = gt-                         , pFileToDelete = ft-                         , pMessages     = me-                         , pFrom         = fm-                         , pTo           = to-                         , pEditedText   = et-                         , pFormat       = fo-                         , pSHA1         = sh-                         , pLogMsg       = lm-                         , pEmail        = em-                         , pFullName     = na-                         , pWikiname     = wn-                         , pPrintable    = pr-                         , pOverwrite    = ow-                         , pFilename     = fn-                         , pFilePath     = fp-                         , pAccessCode   = ac-                         , pConfirm      = cn-                         , pSessionKey   = sk-                         , pRecaptcha    = Recaptcha {-                              recaptchaChallengeField = rc,-                              recaptchaResponseField = rr }-                         , pResetCode    = rk-                         , pRedirect     = rd-                         }--data Command = Command (Maybe String) deriving Show--instance FromData Command where-     fromData = do-       pairs <- lookPairs-       return $ case map fst pairs `intersect` commandList of-                 []          -> Command Nothing-                 (c:_)       -> Command $ Just c-               where commandList = ["update", "cancel", "export"]---- | State for a single wiki.-data WikiState = WikiState {-                     wikiConfig    :: Config-                   , wikiFileStore :: FileStore-                   }--type GititServerPart = ServerPartT (ReaderT WikiState IO)--type Handler = GititServerPart Response---- Unescapes XML entities-fromEntities :: String -> String-fromEntities ('&':xs) =-  case lookupEntity ent of-        Just c  -> c ++ fromEntities rest-        Nothing -> '&' : fromEntities xs-    where (ent, rest) = case break (\c -> isSpace c || c == ';') xs of-                             (zs,';':ys) -> (zs,ys)-                             _           -> ("",xs)-fromEntities (x:xs) = x : fromEntities xs-fromEntities [] = []--data GithubConfig = GithubConfig { oAuth2 :: OAuth2-                                 , org :: Maybe Text-                                 }--githubConfig :: OAuth2 -> Maybe Text -> GithubConfig-githubConfig = GithubConfig

@@ -1,110 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}-{--Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>-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 for more details.-You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- Utility functions for Gitit.--}--module Network.Gitit.Util ( readFileUTF8-                          , inDir-                          , withTempDir-                          , orIfNull-                          , splitCategories-                          , trim-                          , yesOrNo-                          , parsePageType-                          , encUrl-                          )-where-import System.Directory-import Control.Exception (bracket)-import System.FilePath ((</>), (<.>))-import System.IO.Error (isAlreadyExistsError)-import Control.Monad.Trans (liftIO)-import Data.Char (toLower, isAscii)-import Network.Gitit.Types-import qualified Control.Exception as E-import qualified Text.Pandoc.UTF8 as UTF8-import Network.URL (encString)---- | Read file as UTF-8 string.  Encode filename as UTF-8.-readFileUTF8 :: FilePath -> IO String-readFileUTF8 = UTF8.readFile---- | Perform a function a directory and return to working directory.-inDir :: FilePath -> IO a -> IO a-inDir d action = do-  w <- getCurrentDirectory-  setCurrentDirectory d-  result <- action-  setCurrentDirectory w-  return result---- | Perform a function in a temporary directory and clean up.-withTempDir :: FilePath -> (FilePath -> IO a) -> IO a-withTempDir baseName f = do-  oldDir <- getCurrentDirectory-  bracket (createTempDir 0 baseName)-          (\tmp -> setCurrentDirectory oldDir >> removeDirectoryRecursive tmp)-          f---- | Create a temporary directory with a unique name.-createTempDir :: Integer -> FilePath -> IO FilePath-createTempDir num baseName = do-  sysTempDir <- getTemporaryDirectory-  let dirName = sysTempDir </> baseName <.> show num-  liftIO $ E.catch (createDirectory dirName >> return dirName) $-      \e -> if isAlreadyExistsError e-               then createTempDir (num + 1) baseName-               else ioError e---- | Returns a list, if it is not null, or a backup, if it is.-orIfNull :: [a] -> [a] -> [a]-orIfNull lst backup = if null lst then backup else lst---- | Split a string containing a list of categories.-splitCategories :: String -> [String]-splitCategories = words . map puncToSpace . trim-     where puncToSpace x | x `elem` ".,;:" = ' '-           puncToSpace x = x---- | Trim leading and trailing spaces.-trim :: String -> String-trim = reverse . trimLeft . reverse . trimLeft-  where trimLeft = dropWhile (`elem` " \t")---- | Show Bool as "yes" or "no".-yesOrNo :: Bool -> String-yesOrNo True  = "yes"-yesOrNo False = "no"--parsePageType :: String -> (PageType, Bool)-parsePageType s =-  case map toLower s of-       "markdown"     -> (Markdown,False)-       "markdown+lhs" -> (Markdown,True)-       "commonmark"   -> (CommonMark,False)-       "rst"          -> (RST,False)-       "rst+lhs"      -> (RST,True)-       "html"         -> (HTML,False)-       "textile"      -> (Textile,False)-       "latex"        -> (LaTeX,False)-       "latex+lhs"    -> (LaTeX,True)-       "org"          -> (Org,False)-       "mediawiki"    -> (MediaWiki,False)-       x              -> error $ "Unknown page type: " ++ x--encUrl :: String -> String-encUrl = encString True isAscii

@@ -47,22 +47,21 @@ Compiling and installing gitit ------------------------------ -You'll need the [GHC] compiler and the [cabal-install] tool. GHC can-be downloaded [here]. Note that, starting with release 0.5, GHC 6.10-or higher is required. For [cabal-install] on *nix, follow the [quick-install] instructions.+The most reliable way to install gitit from source is to get the+[stack] tool.  Then clone the gitit repository and use stack+to install: -[GHC]: http://www.haskell.org/ghc/-[here]: http://www.haskell.org/ghc/-[cabal-install]:  https://wiki.haskell.org/Cabal-Install-[quick install]:  https://wiki.haskell.org/Cabal-Install#Unix+    git clone https://github.com/jgm/gitit+    cd gitit+    stack install -Once you've got cabal-install, installing gitit is trivial:+Alternatively, instead of using [stack], you can get the+[Haskell Platform] and do the following:      cabal update     cabal install gitit -These commands will install the latest released version of gitit.+This will install the latest released version of gitit. To install a version of gitit checked out from the repository, change to the gitit directory and type: @@ -79,23 +78,8 @@ cabal-install executable directory (usually `~/.cabal/bin`). And make sure `~/.cabal/bin` is in your system path. -Optional syntax highlighting support---------------------------------------If pandoc was compiled with optional syntax highlighting support,-this will be available in gitit too.  This feature is recommended-if you plan to display source code on your wiki.--Highlighting support requires the [pcre] library, so make sure that-is installed before continuing.--[pcre]:  http://www.pcre.org/ --To install gitit with highlighting support, first ensure that pandoc-is compiled with highlighting support, then install gitit as above:--    cabal install pandoc -fhighlighting --reinstall-    cabal install gitit+[stack]: https://github.com/commercialhaskell/stack+[Haskell Platform]: https://www.haskell.org/platform/  Running gitit -------------

@@ -1,6 +1,6 @@ name:                gitit-version:             0.11.1.1-Cabal-version:       >= 1.6+version:             0.12+Cabal-version:       >= 1.8 build-type:          Simple synopsis:            Wiki using happstack, git or darcs, and pandoc. description:         Gitit is a wiki backed by a git, darcs, or mercurial@@ -114,46 +114,33 @@   default:           True  Library-  hs-source-dirs:    .+  hs-source-dirs:    src   exposed-modules:   Network.Gitit, Network.Gitit.ContentTransformer,                      Network.Gitit.Types, Network.Gitit.Framework,                      Network.Gitit.Initialize, Network.Gitit.Config,                      Network.Gitit.Layout, Network.Gitit.Authentication,-                     Network.Gitit.Authentication.Github-  other-modules:     Network.Gitit.Cache, Network.Gitit.State,-                     Paths_gitit, Network.Gitit.Server, Network.Gitit.Export,-                     Network.Gitit.Util, Network.Gitit.Handlers,+                     Network.Gitit.Authentication.Github,+                     Network.Gitit.Util, Network.Gitit.Server+                     Network.Gitit.Cache, Network.Gitit.State,+                     Paths_gitit, Network.Gitit.Export,+                     Network.Gitit.Handlers,                      Network.Gitit.Plugins, Network.Gitit.Rpxnow,                      Network.Gitit.Page, Network.Gitit.Feed,                      Network.Gitit.Compat.Except-  if flag(plugins)-    exposed-modules: Network.Gitit.Interface-    build-depends:   ghc, ghc-paths-    cpp-options:     -D_PLUGINS-  build-depends:     base >= 3, pandoc >= 1.12.4 && < 1.16,-                     pandoc-types >= 1.12.3 && < 1.13, filepath, safe-  extensions:        CPP-  if impl(ghc >= 6.12)-    ghc-options:     -Wall -fno-warn-unused-do-bind-  else-    ghc-options:     -Wall-  ghc-prof-options:  -fprof-auto-exported -rtsopts--Executable           gitit-  hs-source-dirs:    .-  main-is:           gitit.hs-  build-depends:     base >=3 && < 5,+  build-depends:     base >= 3 && < 5,+                     filepath,+                     safe,                      parsec,                      pretty,                      xhtml,                      containers,-                     pandoc >= 1.12.4 && < 1.16,-                     pandoc-types >= 1.12.3 && < 1.13,                      process,                      filepath,                      directory,                      mtl,                      old-time,+                     pandoc >= 1.12.4 && < 1.16,+                     pandoc-types >= 1.12.3 && < 1.13,                      highlighting-kate >= 0.5.0.1 && < 0.7,                      bytestring,                      text,@@ -192,10 +179,32 @@   else     build-depends:   network >= 2 && < 2.6   if flag(plugins)+    exposed-modules: Network.Gitit.Interface     build-depends:   ghc, ghc-paths     cpp-options:     -D_PLUGINS   extensions:        CPP   if impl(ghc >= 6.12)+    ghc-options:     -Wall -fno-warn-unused-do-bind+  else+    ghc-options:     -Wall+  ghc-prof-options:  -fprof-auto-exported -rtsopts++Executable           gitit+  hs-source-dirs:    .+  main-is:           gitit.hs+  build-depends:     base >=3 && < 5,+                     gitit,+                     mtl,+                     hslogger,+                     bytestring,+                     utf8-string,+                     directory+  if flag(network-uri)+    build-depends:   network-uri >= 2.6 && < 2.7, network >= 2.6+  else+    build-depends:   network >= 2 && < 2.6+  extensions:        CPP+  if impl(ghc >= 6.12)     ghc-options:     -Wall -threaded -fno-warn-unused-do-bind   else     ghc-options:     -Wall -threaded@@ -205,6 +214,10 @@   hs-source-dirs:    .   main-is:           expireGititCache.hs   build-depends:     base >=3 && < 5, HTTP, url, filepath+  if flag(network-uri)+    build-depends:   network-uri >= 2.6 && < 2.7, network >= 2.6+  else+    build-depends:   network >= 2 && < 2.6   if impl(ghc >= 6.10)     build-depends:   base >= 4, syb   ghc-options:       -Wall

@@ -0,0 +1,224 @@+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>++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 for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+-}++{- | Functions for embedding a gitit wiki into a Happstack application.++The following is a minimal standalone wiki program:++> import Network.Gitit+> import Happstack.Server.SimpleHTTP+>+> main = do+>   conf <- getDefaultConfig+>   createStaticIfMissing conf+>   createTemplateIfMissing conf+>   createRepoIfMissing conf+>   initializeGititState conf+>   simpleHTTP nullConf{port = 5001} $ wiki conf++Here is a more complex example, which serves different wikis+under different paths, and uses a custom authentication scheme:++> import Network.Gitit+> import Control.Monad+> import Text.XHtml hiding (dir)+> import Happstack.Server.SimpleHTTP+>+> type WikiSpec = (String, FileStoreType, PageType)+>+> wikis = [ ("markdownWiki", Git, Markdown)+>         , ("latexWiki", Darcs, LaTeX) ]+>+> -- custom authentication+> myWithUser :: Handler -> Handler+> myWithUser handler = do+>   -- replace the following with a function that retrieves+>   -- the logged in user for your happstack app:+>   user <- return "testuser"+>   localRq (setHeader "REMOTE_USER" user) handler+>+> myAuthHandler = msum+>   [ dir "_login"  $ seeOther "/your/login/url"  $ toResponse ()+>   , dir "_logout" $ seeOther "/your/logout/url" $ toResponse () ]+>+> handlerFor :: Config -> WikiSpec -> ServerPart Response+> handlerFor conf (path', fstype, pagetype) = dir path' $+>   wiki conf{ repositoryPath = path'+>            , repositoryType = fstype+>            , defaultPageType = pagetype}+>+> indexPage :: ServerPart Response+> indexPage = ok $ toResponse $+>   (p << "Wiki index") ++++>   ulist << map (\(path', _, _) -> li << hotlink (path' ++ "/") << path') wikis+>+> main = do+>   conf <- getDefaultConfig+>   let conf' = conf{authHandler = myAuthHandler, withUser = myWithUser}+>   forM wikis $ \(path', fstype, pagetype) -> do+>     let conf'' = conf'{ repositoryPath = path'+>                       , repositoryType = fstype+>                       , defaultPageType = pagetype+>                       }+>     createStaticIfMissing conf''+>     createRepoIfMissing conf''+>   createTemplateIfMissing conf'+>   initializeGititState conf'+>   simpleHTTP nullConf{port = 5001} $+>     (nullDir >> indexPage) `mplus` msum (map (handlerFor conf') wikis)++-}++module Network.Gitit (+                     -- * Wiki handlers+                       wiki+                     , reloadTemplates+                     , runHandler+                     -- * Initialization+                     , module Network.Gitit.Initialize+                     -- * Configuration+                     , module Network.Gitit.Config+                     , loginUserForm+                     -- * Types+                     , module Network.Gitit.Types+                     -- * Tools for building handlers+                     , module Network.Gitit.Framework+                     , module Network.Gitit.Layout+                     , module Network.Gitit.ContentTransformer+                     , module Network.Gitit.Page+                     , getFileStore+                     , getUser+                     , getConfig+                     , queryGititState+                     , updateGititState+                     )+where+import Network.Gitit.Types+import Network.Gitit.Server+import Network.Gitit.Framework+import Network.Gitit.Handlers+import Network.Gitit.Initialize+import Network.Gitit.Config+import Network.Gitit.Layout+import Network.Gitit.State+        (getFileStore, getUser, getConfig, queryGititState, updateGititState)+import Network.Gitit.ContentTransformer+import Network.Gitit.Page+import Network.Gitit.Authentication (loginUserForm)+import Paths_gitit (getDataFileName)+import Control.Monad.Reader+import Prelude hiding (readFile)+import qualified Data.ByteString.Char8 as B+import System.FilePath ((</>))+import System.Directory (getTemporaryDirectory)+import Safe++-- | Happstack handler for a gitit wiki.+wiki :: Config -> ServerPart Response+wiki conf = do+  tempDir <- liftIO getTemporaryDirectory+  let maxSize = fromIntegral $ maxUploadSize conf+  decodeBody $ defaultBodyPolicy tempDir maxSize maxSize maxSize+  let static = staticDir conf+  defaultStatic <- liftIO $ getDataFileName $ "data" </> "static"+  -- if file not found in staticDir, we check also in the data/static+  -- directory, which contains defaults+  let staticHandler = withExpiresHeaders $+        serveDirectory' static `mplus` serveDirectory' defaultStatic+  let debugHandler' = msum [debugHandler | debugMode conf]+  let handlers = debugHandler' `mplus` authHandler conf `mplus`+                 authenticate ForRead (msum wikiHandlers)+  let fs = filestoreFromConfig conf+  let ws = WikiState { wikiConfig = conf, wikiFileStore = fs }+  if compressResponses conf+     then compressedResponseFilter+     else return ""+  staticHandler `mplus` runHandler ws (withUser conf handlers)++-- | Like 'serveDirectory', but if file is not found, fail instead of+-- returning a 404 error.+serveDirectory' :: FilePath -> ServerPart Response+serveDirectory' p = do+  rq <- askRq+  resp' <- serveDirectory EnableBrowsing [] p+  if rsCode resp' == 404 || lastNote "fileServeStrict'" (rqUri rq) == '/'+     then mzero  -- pass through if not found or directory index+     else+       -- turn off compresion filter unless it's text+       case getHeader "Content-Type" resp' of+            Just ct | B.pack "text/" `B.isPrefixOf` ct -> return resp'+            _ -> ignoreFilters >> return resp'++wikiHandlers :: [Handler]+wikiHandlers =+  [ -- redirect /wiki -> /wiki/ when gitit is being served at /wiki+    -- so that relative wikilinks on the page will work properly:+    guardBareBase >> getWikiBase >>= \b -> movedPermanently (b ++ "/") (toResponse ())+  , dir "_activity" showActivity+  , dir "_go"       goToPage+  , method GET >> dir "_search"   searchResults+  , dir "_upload"   $  do guard =<< return . uploadsAllowed =<< getConfig+                          msum [ method GET  >> authenticate ForModify uploadForm+                                 , method POST >> authenticate ForModify uploadFile ]+  , dir "_random"   $ method GET  >> randomPage+  , dir "_index"    indexPage+  , dir "_feed"     feedHandler+  , dir "_category" categoryPage+  , dir "_categories" categoryListPage+  , dir "_expire"     expireCache+  , dir "_showraw"  $ msum+      [ showRawPage+      , guardPath isSourceCode >> showFileAsText ]+  , dir "_history"  $ msum+      [ showPageHistory+      , guardPath isSourceCode >> showFileHistory ]+  , dir "_edit" $ authenticate ForModify (unlessNoEdit editPage showPage)+  , dir "_diff" $ msum+      [ showPageDiff+      , guardPath isSourceCode >> showFileDiff ]+  , dir "_discuss" discussPage+  , dir "_delete" $ msum+      [ method GET  >>+          authenticate ForModify (unlessNoDelete confirmDelete showPage)+      , method POST >>+          authenticate ForModify (unlessNoDelete deletePage showPage) ]+  , dir "_preview" preview+  , guardIndex >> indexPage+  , guardCommand "export" >> exportPage+  , method POST >> guardCommand "cancel" >> showPage+  , method POST >> guardCommand "update" >>+      authenticate ForModify (unlessNoEdit updatePage showPage)+  , showPage+  , guardPath isSourceCode >> method GET >> showHighlightedSource+  , handleAny+  , notFound =<< (guardPath isPage >> createPage)+  ]++-- | Recompiles the gitit templates.+reloadTemplates :: ServerPart Response+reloadTemplates = do+  liftIO recompilePageTemplate+  ok $ toResponse "Page templates have been recompiled."++-- | Converts a gitit Handler into a standard happstack ServerPart.+runHandler :: WikiState -> Handler -> ServerPart Response+runHandler = mapServerPartT . unpackReaderT++unpackReaderT :: s -> UnWebT (ReaderT s IO) a -> UnWebT IO a+unpackReaderT st uw = runReaderT uw st+

@@ -0,0 +1,541 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,+                   Henry Laxen <nadine.and.henry@pobox.com>++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 for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+-}++{- Handlers for registering and authenticating users.+-}++module Network.Gitit.Authentication ( loginUserForm+                                    , formAuthHandlers+                                    , httpAuthHandlers+                                    , rpxAuthHandlers+                                    , githubAuthHandlers) where++import Network.Gitit.State+import Network.Gitit.Types+import Network.Gitit.Framework+import Network.Gitit.Layout+import Network.Gitit.Server+import Network.Gitit.Util+import Network.Gitit.Authentication.Github+import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)+import Text.XHtml hiding ( (</>), dir, method, password, rev )+import qualified Text.XHtml as X ( password )+import System.Process (readProcessWithExitCode)+import Control.Monad (unless, liftM, mplus)+import Control.Monad.Trans (liftIO)+import System.Exit+import System.Log.Logger (logM, Priority(..))+import Data.Char (isAlphaNum, isAlpha)+import qualified Data.Map as M+import Text.Pandoc.Shared (substitute)+import Data.Maybe (isJust, fromJust, isNothing, 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 Codec.Binary.UTF8.String (encodeString)+import Data.ByteString.UTF8 (toString)+import Network.Gitit.Rpxnow as R++data ValidationType = Register+                    | ResetPassword+                    deriving (Show,Read)++registerUser :: Params -> Handler+registerUser params = do+  result' <- sharedValidation Register params+  case result' of+    Left errors -> registerForm >>=+          formattedPage defaultPageLayout{+                          pgMessages = errors,+                          pgShowPageTools = False,+                          pgTabs = [],+                          pgTitle = "Register for an account"+                          }+    Right (uname, email, pword) -> do+       user <- liftIO $ mkUser uname email pword+       addUser uname user+       loginUser params{ pUsername = uname,+                         pPassword = pword,+                         pEmail = email }++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]]+  cfg <- getConfig+  let contents = if null (mailCommand cfg)+                    then p << "Sorry, password reset not available."+                    else passwordForm+  formattedPage defaultPageLayout{+                  pgShowPageTools = False,+                  pgTabs = [],+                  pgTitle = "Reset your password" }+                contents++resetPasswordRequest :: Params -> Handler+resetPasswordRequest params = do+  let uname = pUsername params+  mbUser <- getUser uname+  let errors = case mbUser of+        Nothing -> ["Unknown user. Please re-register " +++                    "or press the Back button to try again."]+        Just u  -> ["Since you did not register with " +++                   "an email address, we can't reset your password." |+                    null (uEmail u) ]+  if null errors+    then do+      let response =+            p << [ stringToHtml "An email has been sent to "+                 , bold $ stringToHtml . uEmail $ fromJust mbUser+                 , br+                 , stringToHtml+                   "Please click on the enclosed link to reset your password."+                 ]+      sendReregisterEmail (fromJust mbUser)+      formattedPage defaultPageLayout{+                      pgShowPageTools = False,+                      pgTabs = [],+                      pgTitle = "Resetting your password"+                      }+                    response+    else registerForm >>=+         formattedPage defaultPageLayout{+                         pgMessages = errors,+                         pgShowPageTools = False,+                         pgTabs = [],+                         pgTitle = "Register for an account"+                         }++resetLink :: String -> User -> String+resetLink base' user =+  exportURL $  foldl add_param+    (fromJust . importURL $ base' ++ "/_doResetPassword")+    [("username", uUsername user), ("reset_code", take 20 (pHashed (uPassword user)))]++sendReregisterEmail :: User -> GititServerPart ()+sendReregisterEmail user = do+  cfg <- getConfig+  hostname <- liftIO getHostName+  base' <- getWikiBase+  let messageTemplate = T.newSTMP $ resetPasswordMessage cfg+  let filledTemplate = T.render .+                       T.setAttribute "username" (uUsername user) .+                       T.setAttribute "useremail" (uEmail user) .+                       T.setAttribute "hostname" hostname .+                       T.setAttribute "port" (show $ portNumber cfg) .+                       T.setAttribute "resetlink" (resetLink base' user) $+                       messageTemplate+  let (mailcommand:args) = words $ substitute "%s" (uEmail user)+                                   (mailCommand cfg)+  (exitCode, _pOut, pErr) <- liftIO $ readProcessWithExitCode mailcommand args+                                      filledTemplate+  liftIO $ logM "gitit" WARNING $ "Sent reset password email to " ++ uUsername user +++                         " at " ++ uEmail user+  unless (exitCode == ExitSuccess) $+    liftIO $ logM "gitit" WARNING $ mailcommand ++ " failed. " ++ pErr++validateReset :: Params -> (User -> Handler) -> Handler+validateReset params postValidate = do+  let uname = pUsername params+  user <- getUser uname+  let knownUser = isJust user+  let resetCodeMatches = take 20 (pHashed (uPassword (fromJust user))) ==+                           pResetCode params+  let errors = case (knownUser, resetCodeMatches) of+                     (True, True)   -> []+                     (True, False)  -> ["Your reset code is invalid"]+                     (False, _)     -> ["User " +++                       renderHtmlFragment (stringToHtml uname) +++                       " is not known"]+  if null errors+     then postValidate (fromJust user)+     else registerForm >>=+          formattedPage defaultPageLayout{+                          pgMessages = errors,+                          pgShowPageTools = False,+                          pgTabs = [],+                          pgTitle = "Register for an account"+                          }++resetPassword :: Params -> Handler+resetPassword params = validateReset params $ \user ->+  resetPasswordForm (Just user) >>=+  formattedPage defaultPageLayout{+                  pgShowPageTools = False,+                  pgTabs = [],+                  pgTitle = "Reset your registration info"+                  }++doResetPassword :: Params -> Handler+doResetPassword params = validateReset params $ \user -> do+  result' <- sharedValidation ResetPassword params+  case result' of+    Left errors ->+      resetPasswordForm (Just user) >>=+          formattedPage defaultPageLayout{+                          pgMessages = errors,+                          pgShowPageTools = False,+                          pgTabs = [],+                          pgTitle = "Reset your registration info"+                          }+    Right (uname, email, pword) -> do+       user' <- liftIO $ mkUser uname email pword+       adjustUser uname user'+       liftIO $ logM "gitit" WARNING $+            "Successfully reset password and email for " ++ uUsername user'+       loginUser params{ pUsername = uname,+                         pPassword = pword,+                         pEmail = email }++registerForm :: GititServerPart Html+registerForm = sharedForm Nothing++resetPasswordForm :: Maybe User -> GititServerPart Html+resetPasswordForm = sharedForm  -- synonym for now++sharedForm :: Maybe User -> GititServerPart Html+sharedForm mbUser = withData $ \params -> do+  cfg <- getConfig+  dest <- case pDestination params of+                ""  -> getReferer+                x   -> return x+  let accessQ = case mbUser of+            Just _ -> noHtml+            Nothing -> case accessQuestion cfg of+                      Nothing          -> noHtml+                      Just (prompt, _) -> label ! [thefor "accessCode"] << prompt +++ br ++++                                          X.password "accessCode" ! [size "15", intAttr "tabindex" 1]+                                          +++ br+  let captcha = if useRecaptcha cfg+                   then captchaFields (recaptchaPublicKey cfg) Nothing+                   else noHtml+  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+  let submitField = case mbUser of+                      Nothing    -> submit "register" "Register"+                      Just _     -> submit "resetPassword" "Reset Password"++  return $ gui "" ! [identifier "loginForm"] << fieldset <<+            [ accessQ+            , userNameField+            , label ! [thefor "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"]+            , br+            , label ! [thefor "password"]+                    << ("Password (at least 6 characters," +++                        " including at least one non-letter):")+            , br+            , X.password "password" ! [size "20", intAttr "tabindex" 4]+            , stringToHtml " "+            , br+            , label ! [thefor "password2"] << "Confirm Password:"+            , br+            , X.password "password2" ! [size "20", intAttr "tabindex" 5]+            , stringToHtml " "+            , br+            , captcha+            , textfield "destination" ! [thestyle "display: none;", value dest]+            , submitField ! [intAttr "tabindex" 6]]+++sharedValidation :: ValidationType+                 -> Params+                 -> GititServerPart (Either [String] (String,String,String))+sharedValidation validationType params = do+  let isValidUsernameChar c = isAlphaNum c || c == ' '+  let isValidUsername u = length u >= 3 && all isValidUsernameChar u+  let isValidPassword pw = length pw >= 6 && not (all isAlpha pw)+  let accessCode = pAccessCode params+  let uname = pUsername params+  let pword = pPassword params+  let pword2 = pPassword2 params+  let email = pEmail params+  let fakeField = pFullName params+  let recaptcha = pRecaptcha params+  taken <- isUser uname+  cfg <- getConfig+  let optionalTests Register =+          [(taken, "Sorry, that username is already taken.")]+      optionalTests ResetPassword = []+  let isValidAccessCode = case validationType of+        ResetPassword -> True+        Register -> case accessQuestion cfg of+            Nothing           -> True+            Just (_, answers) -> accessCode `elem` answers+  let isValidEmail e = length (filter (=='@') e) == 1+  peer <- liftM (fst . rqPeer) askRq+  captchaResult <-+    if useRecaptcha cfg+       then if null (recaptchaChallengeField recaptcha) ||+                 null (recaptchaResponseField recaptcha)+               -- no need to bother captcha.net in this case+               then return $ Left "missing-challenge-or-response"+               else liftIO $ do+                      mbIPaddr <- lookupIPAddr peer+                      let ipaddr = fromMaybe (error $ "Could not find ip address for " ++ peer)+                                   mbIPaddr+                      ipaddr `seq` validateCaptcha (recaptchaPrivateKey cfg)+                              ipaddr (recaptchaChallengeField recaptcha)+                              (recaptchaResponseField recaptcha)+       else return $ Right ()+  let (validCaptcha, captchaError) =+        case captchaResult of+              Right () -> (True, Nothing)+              Left err -> (False, Just err)+  let errors = validate $ optionalTests validationType +++        [ (not isValidAccessCode, "Incorrect response to access prompt.")+        , (not (isValidUsername uname),+         "Username must be at least 3 charcaters, all letters or digits.")+        , (not (isValidPassword pword),+         "Password must be at least 6 characters, " +++         "and must contain at least one non-letter.")+        , (not (null email) && not (isValidEmail email),+         "Email address appears invalid.")+        , (pword /= pword2,+        "Password does not match confirmation.")+        , (not validCaptcha,+        "Failed CAPTCHA (" ++ fromJust captchaError +++        "). Are you really human?")+        , (not (null fakeField), -- fakeField is hidden in CSS (honeypot)+        "You do not seem human enough. If you're sure you are human, " +++        "try turning off form auto-completion in your browser.")+        ]+  return $ if null errors then Right (uname, email, pword) else Left errors++-- user authentication+loginForm :: String -> GititServerPart Html+loginForm dest = do+  cfg <- getConfig+  base' <- getWikiBase+  return $ gui (base' ++ "/_login") ! [identifier "loginForm"] <<+    fieldset <<+      [ label ! [thefor "username"] << "Username "+      , textfield "username" ! [size "15", intAttr "tabindex" 1]+      , stringToHtml " "+      , label ! [thefor "password"] << "Password "+      , X.password "password" ! [size "15", intAttr "tabindex" 2]+      , stringToHtml " "+      , textfield "destination" ! [thestyle "display: none;", value dest]+      , submit "login" "Login" ! [intAttr "tabindex" 3]+      ] ++++    p << [ stringToHtml "If you do not have an account, "+         , anchor ! [href $ 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"] <<+                     "click here to get a new one."+                 ]++loginUserForm :: Handler+loginUserForm = withData $ \params -> do+  dest <- case pDestination params of+                ""  -> getReferer+                x   -> return x+  loginForm dest >>=+    formattedPage defaultPageLayout{ pgShowPageTools = False,+                                     pgTabs = [],+                                     pgTitle = "Login",+                                     pgMessages = pMessages params+                                   }++loginUser :: Params -> Handler+loginUser params = do+  let uname = pUsername params+  let pword = pPassword params+  let destination = pDestination params+  allowed <- authUser uname pword+  cfg <- getConfig+  if allowed+    then do+      key <- newSession (sessionData uname)+      addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))+      seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " +++        renderHtmlFragment (stringToHtml uname))+    else+      withMessages ["Invalid username or password."] loginUserForm++logoutUser :: Params -> Handler+logoutUser params = do+  let key = pSessionKey params+  dest <- case pDestination params of+                ""  -> getReferer+                x   -> return x+  case key of+       Just k  -> do+         delSession k+         expireCookie "sid"+       Nothing -> return ()+  seeOther (encUrl dest) $ toResponse "You have been logged out."++registerUserForm :: Handler+registerUserForm = registerForm >>=+    formattedPage defaultPageLayout{+                    pgShowPageTools = False,+                    pgTabs = [],+                    pgTitle = "Register for an account"+                    }++formAuthHandlers :: [Handler]+formAuthHandlers =+  [ dir "_register"  $ method GET >> registerUserForm+  , dir "_register"  $ method POST >> withData registerUser+  , 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+  ]++loginUserHTTP :: Params -> Handler+loginUserHTTP params = do+  base' <- getWikiBase+  let destination = pDestination params `orIfNull` (base' ++ "/")+  seeOther (encUrl destination) $ toResponse ()++logoutUserHTTP :: Handler+logoutUserHTTP = unauthorized $ toResponse ()  -- will this work?++httpAuthHandlers :: [Handler]+httpAuthHandlers =+  [ dir "_logout" logoutUserHTTP+  , dir "_login"  $ withData loginUserHTTP+  , dir "_user" currentUser ]++oauthGithubCallback :: GithubConfig+                   -> GithubCallbackPars                  -- ^ Authentication code gained after authorization+                   -> Handler+oauthGithubCallback ghConfig githubCallbackPars =+  withData $ \(sk :: Maybe SessionKey) ->+      do+        mbSd <- maybe (return Nothing) getSession sk+        mbGititState <- case mbSd of+                          Nothing    -> return Nothing+                          Just sd    -> return $ sessionGithubState sd+        let gititState = fromMaybe (error "No Github state found in session (is it the same domain?)") mbGititState+        mUser <- getGithubUser ghConfig githubCallbackPars gititState+        base' <- getWikiBase+        let destination = base' ++ "/"+        case mUser of+          Right user -> do+                     let userEmail = uEmail user+                     updateGititState $ \s -> s { users = M.insert userEmail user (users s) }+                     addUser (uUsername user) user+                     key <- newSession (sessionData userEmail)+                     cfg <- getConfig+                     addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))+                     seeOther (encUrl destination) $ toResponse ()+          Left err -> do+              liftIO $ logM "gitit" WARNING $ "Login Failed: " ++ ghUserMessage err ++ maybe "" (". Github response" ++) (ghDetails err)+              let url = destination ++ "?message=" ++ ghUserMessage err+              seeOther (encUrl url) $ toResponse ()++githubAuthHandlers :: GithubConfig+                   -> [Handler]+githubAuthHandlers ghConfig =+  [ dir "_logout" $ withData logoutUser+  , dir "_login" $ loginGithubUser $ oAuth2 ghConfig+  , dir "_githubCallback" $ withData $ oauthGithubCallback ghConfig+  , dir "_user" currentUser ]++-- 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) (mkCookie "sid" (show 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+currentUser = do+  req <- askRq+  ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)

@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++module Network.Gitit.Authentication.Github ( loginGithubUser+                                           , getGithubUser+                                           , GithubCallbackPars+                                           , GithubLoginError+                                           , ghUserMessage+                                           , ghDetails) where++import Network.Gitit.Types+import Network.Gitit.Server+import Network.Gitit.State+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL+import Network.HTTP.Conduit+import Network.HTTP.Client.TLS+import Network.OAuth.OAuth2+import Control.Monad (liftM, mplus, mzero)+import Data.Maybe+import Data.Aeson+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (encodeUtf8)+import Control.Applicative+import Control.Monad.Trans (liftIO)+import Data.UUID (toString)+import Data.UUID.V4 (nextRandom)+import qualified Control.Exception as E+import Prelude++loginGithubUser :: OAuth2 -> Handler+loginGithubUser githubKey = do+  state <- liftIO $ fmap toString nextRandom+  key <- newSession (sessionDataGithubState state)+  cfg <- getConfig+  addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))+  let usingOrg = isJust $ org $ githubAuth cfg+  let scopes = "user:email" ++ if usingOrg then ",read:org" else ""+  let url = authorizationUrl githubKey `appendQueryParam` [("state", BS.pack state), ("scope", BS.pack scopes)]+  seeOther (BS.unpack url) $ toResponse ("redirecting to github" :: String)++data GithubLoginError = GithubLoginError { ghUserMessage :: String+                                         , ghDetails :: Maybe String+                                         }++getGithubUser :: GithubConfig            -- ^ Oauth2 configuration (client secret)+              -> GithubCallbackPars      -- ^ Authentication code gained after authorization+              -> String                  -- ^ Github state, we expect the state we sent in loginGithubUser+              -> GititServerPart (Either GithubLoginError User) -- ^ user email and name (password 'none')+getGithubUser ghConfig githubCallbackPars githubState =+       withManagerSettings tlsManagerSettings getUserInternal+    where+    getUserInternal mgr =+        liftIO $ do+            let (Just state) = rState githubCallbackPars+            if state == githubState+              then do+                let (Just code) = rCode githubCallbackPars+                ifSuccess+                   "No access token found yet"+                   (fetchAccessToken mgr (oAuth2 ghConfig) (sToBS code))+                   (\at -> ifSuccess+                           "User Authentication failed"+                           (userInfo mgr at)+                           (\githubUser -> ifSuccess+                            ("No email for user " ++ unpack (gLogin githubUser) ++ " returned by Github")+                            (mailInfo mgr at)+                            (\githubUserMail -> do+                                       let gitLogin = gLogin githubUser+                                       user <- mkUser (unpack gitLogin)+                                                   (unpack $ email $ head githubUserMail)+                                                   "none"+                                       let mbOrg = org ghConfig+                                       case mbOrg of+                                             Nothing -> return $ Right user+                                             Just githuborg -> ifSuccess+                                                      ("Membership check of user " ++ unpack gitLogin ++  " to "  ++ unpack githuborg ++ " failed")+                                                      (orgInfo gitLogin githuborg mgr at)+                                                      (\_ -> return $ Right user))))+              else+                return $ Left $+                       GithubLoginError ("The state sent to github is not the same as the state received: " ++ state ++ ", but expected sent state: " ++  githubState)+                                        Nothing+    ifSuccess errMsg failableAction successAction  = E.catch+                                                 (do Right outcome <- failableAction+                                                     successAction outcome)+                                                 (\exception -> liftIO $ return $ Left $+                                                                GithubLoginError errMsg+                                                                                 (Just $ show (exception :: E.SomeException)))++data GithubCallbackPars = GithubCallbackPars { rCode :: Maybe String+                                             , rState :: Maybe String }+                          deriving Show++instance FromData GithubCallbackPars where+    fromData = do+         vCode <- liftM Just (look "code") `mplus` return Nothing+         vState <- liftM Just (look "state") `mplus` return Nothing+         return GithubCallbackPars {rCode = vCode, rState = vState}++userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser)+userInfo mgr token = authGetJSON mgr token "https://api.github.com/user"++mailInfo :: Manager -> AccessToken -> IO (OAuth2Result [GithubUserMail])+mailInfo mgr token = authGetJSON mgr token "https://api.github.com/user/emails"++orgInfo  :: Text -> Text -> Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString)+orgInfo gitLogin githubOrg mgr token = do+  let url  = "https://api.github.com/orgs/" `BS.append` encodeUtf8 githubOrg `BS.append` "/members/" `BS.append` encodeUtf8 gitLogin+  authGetBS mgr token url++data GithubUser = GithubUser { gLogin :: Text+                             } deriving (Show, Eq)++instance FromJSON GithubUser where+    parseJSON (Object o) = GithubUser+                           <$> o .: "login"+    parseJSON _ = mzero++data GithubUserMail = GithubUserMail { email :: Text+                             } deriving (Show, Eq)++instance FromJSON GithubUserMail where+    parseJSON (Object o) = GithubUserMail+                           <$> o .: "email"+    parseJSON _ = mzero++sToBS :: String -> BS.ByteString+sToBS = encodeUtf8 . pack

@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-+Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>++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 for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+-}++{- Functions for maintaining user list and session state.+-}++module Network.Gitit.Cache ( expireCachedFile+                           , lookupCache+                           , cacheContents )+where++import qualified Data.ByteString as B (ByteString, readFile, writeFile)+import System.FilePath+import System.Directory (doesFileExist, removeFile, createDirectoryIfMissing, getModificationTime)+import Data.Time.Clock (UTCTime)+#if MIN_VERSION_directory(1,2,0)+#else+import System.Time (ClockTime(..))+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+#endif+import Network.Gitit.State+import Network.Gitit.Types+import Control.Monad+import Control.Monad.Trans (liftIO)+import Text.Pandoc.UTF8 (encodePath)++-- | Expire a cached file, identified by its filename in the filestore.+-- If there is an associated exported PDF, expire it too.+-- Returns () after deleting a file from the cache, fails if no cached file.+expireCachedFile :: String -> GititServerPart ()+expireCachedFile file = do+  cfg <- getConfig+  let target = encodePath $ cacheDir cfg </> file+  exists <- liftIO $ doesFileExist target+  when exists $ liftIO $ do+    liftIO $ removeFile target+    expireCachedPDF target (defaultExtension cfg)++expireCachedPDF :: String -> String -> IO ()+expireCachedPDF file ext = +  when (takeExtension file == "." ++ ext) $ do+    let pdfname = file ++ ".export.pdf"+    exists <- doesFileExist pdfname+    when exists $ removeFile pdfname++lookupCache :: String -> GititServerPart (Maybe (UTCTime, B.ByteString))+lookupCache file = do+  cfg <- getConfig+  let target = encodePath $ cacheDir cfg </> file+  exists <- liftIO $ doesFileExist target+  if exists+     then liftIO $ do+#if MIN_VERSION_directory(1,2,0)+       modtime <- getModificationTime target+#else+       TOD secs _ <- getModificationTime target+       let modtime = posixSecondsToUTCTime $ fromIntegral secs+#endif+       contents <- B.readFile target+       return $ Just (modtime, contents)+     else return Nothing++cacheContents :: String -> B.ByteString -> GititServerPart ()+cacheContents file contents = do+  cfg <- getConfig+  let target = encodePath $ cacheDir cfg </> file+  let targetDir = takeDirectory target+  liftIO $ do+    createDirectoryIfMissing True targetDir+    B.writeFile target contents+    expireCachedPDF target (defaultExtension cfg)

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+module Network.Gitit.Compat.Except (+                                   ExceptT+                                 , Except+                                 , Error(..)+                                 , runExceptT+                                 , runExcept+                                 , MonadError+                                 , throwError+                                 , catchError )+       where++#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except++class Error a where+  noMsg  :: a+  strMsg :: String -> a++  noMsg    = strMsg ""+  strMsg _ = noMsg++#else+import Control.Monad.Error+import Control.Monad.Identity (Identity, runIdentity)++type ExceptT = ErrorT++type Except s a = ErrorT s Identity a++runExceptT ::  ExceptT e m a -> m (Either e a)+runExceptT = runErrorT++runExcept :: ExceptT e Identity a -> Either e a+runExcept = runIdentity . runExceptT+#endif

@@ -0,0 +1,346 @@+{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-}+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>++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 for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+-}++{- | Functions for parsing command line options and reading the config file.+-}++module Network.Gitit.Config ( getConfigFromFile+                            , getConfigFromFiles+                            , getDefaultConfig+                            , readMimeTypesFile )+where+import Network.Gitit.Types+import Network.Gitit.Server (mimeTypes)+import Network.Gitit.Framework+import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers, githubAuthHandlers)+import Network.Gitit.Util (parsePageType, readFileUTF8)+import System.Log.Logger (logM, Priority(..))+import qualified Data.Map as M+import Data.ConfigFile hiding (readfile)+import Data.List (intercalate)+import Data.Char (toLower, toUpper, isDigit)+import Data.Text (pack)+import Paths_gitit (getDataFileName)+import System.FilePath ((</>))+import Text.Pandoc hiding (MathML, WebTeX, MathJax)+import qualified Control.Exception as E+import Network.OAuth.OAuth2+import qualified Data.ByteString.Char8 as BS+import Network.Gitit.Compat.Except+import Control.Monad+import Control.Monad.Trans++#if MIN_VERSION_pandoc(1,14,0)+import Text.Pandoc.Error (handleError)+#else+handleError :: Pandoc -> Pandoc+handleError = id+#endif++forceEither :: Show e => Either e a -> a+forceEither = either (error . show) id++-- | Get configuration from config file.+getConfigFromFile :: FilePath -> IO Config+getConfigFromFile fname = do+  cp <- getDefaultConfigParser+  readfile cp fname >>= extractConfig . forceEither++-- | Get configuration from config files.+getConfigFromFiles :: [FilePath] -> IO Config+getConfigFromFiles fnames = do+  config <- getConfigParserFromFiles fnames+  extractConfig config++getConfigParserFromFiles :: [FilePath] ->+                            IO ConfigParser+getConfigParserFromFiles (fname:fnames) = do+  cp <- getConfigParserFromFiles fnames+  config <- readfile cp fname+  return $ forceEither config+getConfigParserFromFiles [] = getDefaultConfigParser++-- | A version of readfile that treats the file as UTF-8.+readfile :: MonadError CPError m+          => ConfigParser+          -> FilePath+          -> IO (m ConfigParser)+readfile cp path' = do+  contents <- readFileUTF8 path'+  return $ readstring cp contents++extractConfig :: ConfigParser -> IO Config+extractConfig cp = do+  config' <- runExceptT $ do+      cfRepositoryType <- get cp "DEFAULT" "repository-type"+      cfRepositoryPath <- get cp "DEFAULT" "repository-path"+      cfDefaultPageType <- get cp "DEFAULT" "default-page-type"+      cfDefaultExtension <- get cp "DEFAULT" "default-extension"+      cfMathMethod <- get cp "DEFAULT" "math"+      cfMathjaxScript <- get cp "DEFAULT" "mathjax-script"+      cfShowLHSBirdTracks <- get cp "DEFAULT" "show-lhs-bird-tracks"+      cfRequireAuthentication <- get cp "DEFAULT" "require-authentication"+      cfAuthenticationMethod <- get cp "DEFAULT" "authentication-method"+      cfUserFile <- get cp "DEFAULT" "user-file"+      cfSessionTimeout <- get cp "DEFAULT" "session-timeout"+      cfTemplatesDir <- get cp "DEFAULT" "templates-dir"+      cfLogFile <- get cp "DEFAULT" "log-file"+      cfLogLevel <- get cp "DEFAULT" "log-level"+      cfStaticDir <- get cp "DEFAULT" "static-dir"+      cfPlugins <- get cp "DEFAULT" "plugins"+      cfTableOfContents <- get cp "DEFAULT" "table-of-contents"+      cfMaxUploadSize <- get cp "DEFAULT" "max-upload-size"+      cfMaxPageSize <- get cp "DEFAULT" "max-page-size"+      cfAddress <- get cp "DEFAULT" "address"+      cfPort <- get cp "DEFAULT" "port"+      cfDebugMode <- get cp "DEFAULT" "debug-mode"+      cfFrontPage <- get cp "DEFAULT" "front-page"+      cfNoEdit <- get cp "DEFAULT" "no-edit"+      cfNoDelete <- get cp "DEFAULT" "no-delete"+      cfDefaultSummary <- get cp "DEFAULT" "default-summary"+      cfAccessQuestion <- get cp "DEFAULT" "access-question"+      cfAccessQuestionAnswers <- get cp "DEFAULT" "access-question-answers"+      cfUseRecaptcha <- get cp "DEFAULT" "use-recaptcha"+      cfRecaptchaPublicKey <- get cp "DEFAULT" "recaptcha-public-key"+      cfRecaptchaPrivateKey <- get cp "DEFAULT" "recaptcha-private-key"+      cfRPXDomain <- get cp "DEFAULT" "rpx-domain"+      cfRPXKey <- get cp "DEFAULT" "rpx-key"+      cfCompressResponses <- get cp "DEFAULT" "compress-responses"+      cfUseCache <- get cp "DEFAULT" "use-cache"+      cfCacheDir <- get cp "DEFAULT" "cache-dir"+      cfMimeTypesFile <- get cp "DEFAULT" "mime-types-file"+      cfMailCommand <- get cp "DEFAULT" "mail-command"+      cfResetPasswordMessage <- get cp "DEFAULT" "reset-password-message"+      cfUseFeed <- get cp "DEFAULT" "use-feed"+      cfBaseUrl <- get cp "DEFAULT" "base-url"+      cfAbsoluteUrls <- get cp "DEFAULT" "absolute-urls"+      cfWikiTitle <- get cp "DEFAULT" "wiki-title"+      cfFeedDays <- get cp "DEFAULT" "feed-days"+      cfFeedRefreshTime <- get cp "DEFAULT" "feed-refresh-time"+      cfPDFExport <- get cp "DEFAULT" "pdf-export"+      cfPandocUserData <- get cp "DEFAULT" "pandoc-user-data"+      cfXssSanitize <- get cp "DEFAULT" "xss-sanitize"+      cfRecentActivityDays <- get cp "DEFAULT" "recent-activity-days"+      let (pt, lhs) = parsePageType cfDefaultPageType+      let markupHelpFile = show pt ++ if lhs then "+LHS" else ""+      markupHelpPath <- liftIO $ getDataFileName $ "data" </> "markupHelp" </> markupHelpFile+      markupHelpText <- liftM (writeHtmlString def . handleError .+                            readMarkdown def) $+                            liftIO $ readFileUTF8 markupHelpPath++      mimeMap' <- liftIO $ readMimeTypesFile cfMimeTypesFile+      let authMethod = map toLower cfAuthenticationMethod+      let stripTrailingSlash = reverse . dropWhile (=='/') . reverse+      let repotype' = case map toLower cfRepositoryType of+                        "git"       -> Git+                        "darcs"     -> Darcs+                        "mercurial" -> Mercurial+                        x           -> error $ "Unknown repository type: " ++ x+      when (authMethod == "rpx" && cfRPXDomain == "") $+         liftIO $ logM "gitit" WARNING "rpx-domain is not set"+      ghConfig <- extractGithubConfig cp++      return Config{+          repositoryPath       = cfRepositoryPath+        , repositoryType       = repotype'+        , defaultPageType      = pt+        , defaultExtension     = cfDefaultExtension+        , mathMethod           = case map toLower cfMathMethod of+                                      "jsmath"   -> JsMathScript+                                      "mathml"   -> MathML+                                      "mathjax"  -> MathJax cfMathjaxScript+                                      "google"   -> WebTeX "http://chart.apis.google.com/chart?cht=tx&chl="+                                      _          -> RawTeX+        , defaultLHS           = lhs+        , showLHSBirdTracks    = cfShowLHSBirdTracks+        , withUser             = case authMethod of+                                      "form"     -> withUserFromSession+                                      "github"   -> withUserFromSession+                                      "http"     -> withUserFromHTTPAuth+                                      "rpx"      -> withUserFromSession+                                      _          -> id+        , requireAuthentication = case map toLower cfRequireAuthentication of+                                       "none"    -> Never+                                       "modify"  -> ForModify+                                       "read"    -> ForRead+                                       _         -> ForModify++        , authHandler          = case authMethod of+                                      "form"     -> msum formAuthHandlers+                                      "github"   -> msum $ githubAuthHandlers ghConfig+                                      "http"     -> msum httpAuthHandlers+                                      "rpx"      -> msum rpxAuthHandlers+                                      _          -> mzero+        , userFile             = cfUserFile+        , sessionTimeout       = readNumber "session-timeout" cfSessionTimeout * 60  -- convert minutes -> seconds+        , templatesDir         = cfTemplatesDir+        , logFile              = cfLogFile+        , logLevel             = let levelString = map toUpper cfLogLevel+                                     levels = ["DEBUG", "INFO", "NOTICE", "WARNING", "ERROR",+                                               "CRITICAL", "ALERT", "EMERGENCY"]+                                 in  if levelString `elem` levels+                                        then read levelString+                                        else error $ "Invalid log-level.\nLegal values are: " ++ intercalate ", " levels+        , staticDir            = cfStaticDir+        , pluginModules        = splitCommaList cfPlugins+        , tableOfContents      = cfTableOfContents+        , maxUploadSize        = readSize "max-upload-size" cfMaxUploadSize+        , maxPageSize          = readSize "max-page-size" cfMaxPageSize+        , address              = cfAddress+        , portNumber           = readNumber "port" cfPort+        , debugMode            = cfDebugMode+        , frontPage            = cfFrontPage+        , noEdit               = splitCommaList cfNoEdit+        , noDelete             = splitCommaList cfNoDelete+        , defaultSummary       = cfDefaultSummary+        , accessQuestion       = if null cfAccessQuestion+                                    then Nothing+                                    else Just (cfAccessQuestion, splitCommaList cfAccessQuestionAnswers)+        , useRecaptcha         = cfUseRecaptcha+        , recaptchaPublicKey   = cfRecaptchaPublicKey+        , recaptchaPrivateKey  = cfRecaptchaPrivateKey+        , rpxDomain            = cfRPXDomain+        , rpxKey               = cfRPXKey+        , compressResponses    = cfCompressResponses+        , useCache             = cfUseCache+        , cacheDir             = cfCacheDir+        , mimeMap              = mimeMap'+        , mailCommand          = cfMailCommand+        , resetPasswordMessage = fromQuotedMultiline cfResetPasswordMessage+        , markupHelp           = markupHelpText+        , useFeed              = cfUseFeed+        , baseUrl              = stripTrailingSlash cfBaseUrl+        , useAbsoluteUrls      = cfAbsoluteUrls+        , wikiTitle            = cfWikiTitle+        , feedDays             = readNumber "feed-days" cfFeedDays+        , feedRefreshTime      = readNumber "feed-refresh-time" cfFeedRefreshTime+        , pdfExport            = cfPDFExport+        , pandocUserData       = if null cfPandocUserData+                                    then Nothing+                                    else Just cfPandocUserData+        , xssSanitize          = cfXssSanitize+        , recentActivityDays   = cfRecentActivityDays+        , githubAuth           = ghConfig+        }+  case config' of+        Left (ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e'+        Left e                  -> error (show e)+        Right c                 -> return c++extractGithubConfig ::  (Functor m, MonadError CPError m) => ConfigParser+                    -> m GithubConfig+extractGithubConfig cp = do+      cfOauthClientId <- getGithubProp "oauthClientId"+      cfOauthClientSecret <- getGithubProp "oauthClientSecret"+      cfOauthCallback <- getGithubProp "oauthCallback"+      cfOauthOAuthorizeEndpoint  <- getGithubProp "oauthOAuthorizeEndpoint"+      cfOauthAccessTokenEndpoint <- getGithubProp "oauthAccessTokenEndpoint"+      cfOrg <- if hasGithubProp "github-org"+                 then fmap Just (getGithubProp "github-org")+                 else return Nothing+      let cfgOAuth2 = OAuth2 { oauthClientId =  BS.pack cfOauthClientId+                          , oauthClientSecret =  BS.pack cfOauthClientSecret+                          , oauthCallback = Just $ BS.pack cfOauthCallback+                          , oauthOAuthorizeEndpoint = BS.pack cfOauthOAuthorizeEndpoint+                          , oauthAccessTokenEndpoint = BS.pack cfOauthAccessTokenEndpoint+                          }+      return $ githubConfig cfgOAuth2 $ fmap pack cfOrg+  where getGithubProp = get cp "Github"+        hasGithubProp = has_option cp "Github"++fromQuotedMultiline :: String -> String+fromQuotedMultiline = unlines . map doline . lines . dropWhile (`elem` " \t\n")+  where doline = dropWhile (`elem` " \t") . dropGt+        dropGt ('>':' ':xs) = xs+        dropGt ('>':xs) = xs+        dropGt x = x++readNumber :: (Num a, Read a) => String -> String -> a+readNumber _   x | all isDigit x = read x+readNumber opt _ = error $ opt ++ " must be a number."++readSize :: (Num a, Read a) => String -> String -> a+readSize opt x =+  case reverse x of+       ('K':_) -> readNumber opt (init x) * 1000+       ('M':_) -> readNumber opt (init x) * 1000000+       ('G':_) -> readNumber opt (init x) * 1000000000+       _       -> readNumber opt x++splitCommaList :: String -> [String]+splitCommaList l =+  let (first,rest) = break (== ',') l+      first' = lrStrip first+  in case rest of+         []     -> if null first' then [] else [first']+         (_:rs) -> first' : splitCommaList rs++lrStrip :: String -> String+lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace+    where isWhitespace = (`elem` " \t\n")++getDefaultConfigParser :: IO ConfigParser+getDefaultConfigParser = do+  cp <- getDataFileName "data/default.conf" >>= readfile emptyCP+  return $ forceEither cp++-- | Returns the default gitit configuration.+getDefaultConfig :: IO Config+getDefaultConfig = getDefaultConfigParser >>= extractConfig++-- | Read a file associating mime types with extensions, and return a+-- map from extensions to types. Each line of the file consists of a+-- mime type, followed by space, followed by a list of zero or more+-- extensions, separated by spaces. Example: text/plain txt text+readMimeTypesFile :: FilePath -> IO (M.Map String String)+readMimeTypesFile f = E.catch+  (liftM (foldr (go . words)  M.empty . lines) $ readFileUTF8 f)+  handleMimeTypesFileNotFound+     where go []     m = m  -- skip blank lines+           go (x:xs) m = foldr (`M.insert` x) m xs+           handleMimeTypesFileNotFound (e :: E.SomeException) = do+             logM "gitit" WARNING $ "Could not read mime types file: " +++               f ++ "\n" ++ show e ++ "\n" ++ "Using defaults instead."+             return mimeTypes++{-+-- | Ready collection of common mime types. (Copied from+-- Happstack.Server.HTTP.FileServe.)+mimeTypes :: M.Map String String+mimeTypes = M.fromList+        [("xml","application/xml")+        ,("xsl","application/xml")+        ,("js","text/javascript")+        ,("html","text/html")+        ,("htm","text/html")+        ,("css","text/css")+        ,("gif","image/gif")+        ,("jpg","image/jpeg")+        ,("png","image/png")+        ,("txt","text/plain")+        ,("doc","application/msword")+        ,("exe","application/octet-stream")+        ,("pdf","application/pdf")+        ,("zip","application/zip")+        ,("gz","application/x-gzip")+        ,("ps","application/postscript")+        ,("rtf","application/rtf")+        ,("wav","application/x-wav")+        ,("hs","text/plain")]+-}

@@ -0,0 +1,757 @@+{-# LANGUAGE CPP #-}+{-+Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,+Anton van Straaten <anton@appsolutions.com>++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 for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+-}++{- Functions for content conversion.+-}++module Network.Gitit.ContentTransformer+  (+  -- * ContentTransformer runners+    runPageTransformer+  , runFileTransformer+  -- * Gitit responders+  , showRawPage+  , showFileAsText+  , showPage+  , exportPage+  , showHighlightedSource+  , showFile+  , preview+  , applyPreCommitPlugins+  -- * Cache support for transformers+  , cacheHtml+  , cachedHtml+  -- * Content retrieval combinators+  , rawContents+  -- * Response-generating combinators+  , textResponse+  , mimeFileResponse+  , mimeResponse+  , exportPandoc+  , applyWikiTemplate+  -- * Content-type transformation combinators+  , pageToWikiPandoc+  , pageToPandoc+  , pandocToHtml+  , highlightSource+  -- * Content or context augmentation combinators+  , applyPageTransforms+  , wikiDivify+  , addPageTitleToPandoc+  , addMathSupport+  , addScripts+  -- * ContentTransformer context API+  , getFileName+  , getPageName+  , getLayout+  , getParams+  , getCacheable+  -- * Pandoc and wiki content conversion support+  , inlinesToURL+  , inlinesToString+  )+where++import qualified Control.Exception as E+import Control.Monad.State+import Control.Monad.Reader (ask)+import Data.Foldable (traverse_)+import Data.List (stripPrefix)+import Data.Maybe (isNothing, mapMaybe)+import Network.Gitit.Cache (lookupCache, cacheContents)+import Network.Gitit.Export (exportFormats)+import Network.Gitit.Framework hiding (uriPath)+import Network.Gitit.Layout+import Network.Gitit.Page (stringToPage)+import Network.Gitit.Server+import Network.Gitit.State+import Network.Gitit.Types+import Network.HTTP (urlDecode)+import Network.URI (isUnescapedInURI)+import Network.URL (encString)+import System.FilePath+import qualified Text.Pandoc.Builder as B+import Text.HTML.SanitizeXSS (sanitizeBalance)+import Text.Highlighting.Kate+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 qualified Data.Text as T+import qualified Data.Set as Set+import qualified Data.ByteString as S (concat)+import qualified Data.ByteString.Char8 as SC (unpack)+import qualified Data.ByteString.Lazy as L (toChunks, fromChunks)+import qualified Data.FileStore as FS+import qualified Text.Pandoc as Pandoc+import Text.URI (parseURI, URI(..), uriQueryItems)++#if MIN_VERSION_pandoc(1,14,0)+import Text.Pandoc.Error (handleError)+#else+handleError :: Pandoc -> Pandoc+handleError = id+#endif+--+-- ContentTransformer runners+--++runPageTransformer :: ToMessage a+               => ContentTransformer a+               -> GititServerPart a+runPageTransformer xform = withData $ \params -> do+  page <- getPage+  cfg <- getConfig+  evalStateT xform  Context{ ctxFile = pathForPage page (defaultExtension cfg)+                           , ctxLayout = defaultPageLayout{+                                             pgPageName = page+                                           , pgTitle = page+                                           , pgPrintable = pPrintable params+                                           , pgMessages = pMessages params+                                           , pgRevision = pRevision params+                                           , pgLinkToFeed = useFeed cfg }+                           , ctxCacheable = True+                           , ctxTOC = tableOfContents cfg+                           , ctxBirdTracks = showLHSBirdTracks cfg+                           , ctxCategories = []+                           , ctxMeta = [] }++runFileTransformer :: ToMessage a+               => ContentTransformer a+               -> GititServerPart a+runFileTransformer xform = withData $ \params -> do+  page <- getPage+  cfg <- getConfig+  evalStateT xform  Context{ ctxFile = id page+                           , ctxLayout = defaultPageLayout{+                                             pgPageName = page+                                           , pgTitle = page+                                           , pgPrintable = pPrintable params+                                           , pgMessages = pMessages params+                                           , pgRevision = pRevision params+                                           , pgLinkToFeed = useFeed cfg }+                           , ctxCacheable = True+                           , ctxTOC = tableOfContents cfg+                           , ctxBirdTracks = showLHSBirdTracks cfg+                           , ctxCategories = []+                           , ctxMeta = [] }++-- | Converts a @ContentTransformer@ into a @GititServerPart@;+-- specialized to wiki pages.+-- runPageTransformer :: ToMessage a+--                    => ContentTransformer a+--                    -> GititServerPart a+-- runPageTransformer = runTransformer pathForPage++-- | Converts a @ContentTransformer@ into a @GititServerPart@;+-- specialized to non-pages.+-- runFileTransformer :: ToMessage a+--                    => ContentTransformer a+--                    -> GititServerPart a+-- runFileTransformer = runTransformer id++--+-- Gitit responders+--++-- | Responds with raw page source.+showRawPage :: Handler+showRawPage = runPageTransformer rawTextResponse++-- | Responds with raw source (for non-pages such as source+-- code files).+showFileAsText :: Handler+showFileAsText = runFileTransformer rawTextResponse++-- | Responds with rendered wiki page.+showPage :: Handler+showPage = runPageTransformer htmlViaPandoc++-- | Responds with page exported into selected format.+exportPage :: Handler+exportPage = runPageTransformer exportViaPandoc++-- | Responds with highlighted source code.+showHighlightedSource :: Handler+showHighlightedSource = runFileTransformer highlightRawSource++-- | Responds with non-highlighted source code.+showFile :: Handler+showFile = runFileTransformer (rawContents >>= mimeFileResponse)++-- | Responds with rendered page derived from form data.+preview :: Handler+preview = runPageTransformer $+          liftM (filter (/= '\r') . pRaw) getParams >>=+          contentsToPage >>=+          pageToWikiPandoc >>=+          pandocToHtml >>=+          return . toResponse . renderHtmlFragment++-- | Applies pre-commit plugins to raw page source, possibly+-- modifying it.+applyPreCommitPlugins :: String -> GititServerPart String+applyPreCommitPlugins = runPageTransformer . applyPreCommitTransforms++--+-- Top level, composed transformers+--++-- | Responds with raw source.+rawTextResponse :: ContentTransformer Response+rawTextResponse = rawContents >>= textResponse++-- | Responds with a wiki page in the format specified+-- by the @format@ parameter.+exportViaPandoc :: ContentTransformer Response+exportViaPandoc = rawContents >>=+                  maybe mzero return >>=+                  contentsToPage >>=+                  pageToWikiPandoc >>=+                  exportPandoc++-- | Responds with a wiki page. Uses the cache when+-- possible and caches the rendered page when appropriate.+htmlViaPandoc :: ContentTransformer Response+htmlViaPandoc = cachedHtml `mplus`+                  (rawContents >>=+                   maybe mzero return >>=+                   contentsToPage >>=+                   handleRedirects >>=+                   either return+                     (pageToWikiPandoc >=>+                      addMathSupport >=>+                      pandocToHtml >=>+                      wikiDivify >=>+                      applyWikiTemplate >=>+                      cacheHtml))++-- | Responds with highlighted source code in a wiki+-- page template.  Uses the cache when possible and+-- caches the rendered page when appropriate.+highlightRawSource :: ContentTransformer Response+highlightRawSource =+  cachedHtml `mplus`+    (updateLayout (\l -> l { pgTabs = [ViewTab,HistoryTab] }) >>+     rawContents >>=+     highlightSource >>=+     applyWikiTemplate >>=+     cacheHtml)++--+-- Cache support for transformers+--++-- | Caches a response (actually just the response body) on disk,+-- unless the context indicates that the page is not cacheable.+cacheHtml :: Response -> ContentTransformer Response+cacheHtml resp' = do+  params <- getParams+  file <- getFileName+  cacheable <- getCacheable+  cfg <- lift getConfig+  when (useCache cfg && cacheable && isNothing (pRevision params) && not (pPrintable params)) $+    lift $ cacheContents file $ S.concat $ L.toChunks $ rsBody resp'+  return resp'++-- | Returns cached page if available, otherwise mzero.+cachedHtml :: ContentTransformer Response+cachedHtml = do+  file <- getFileName+  params <- getParams+  cfg <- lift getConfig+  if useCache cfg && not (pPrintable params) && isNothing (pRevision params)+     then do mbCached <- lift $ lookupCache file+             let emptyResponse = setContentType "text/html; charset=utf-8" . toResponse $ ()+             maybe mzero (\(_modtime, contents) -> lift . ok $ emptyResponse{rsBody = L.fromChunks [contents]}) mbCached+     else mzero++--+-- Content retrieval combinators+--++-- | Returns raw file contents.+rawContents :: ContentTransformer (Maybe String)+rawContents = do+  params <- getParams+  file <- getFileName+  fs <- lift getFileStore+  let rev = pRevision params+  liftIO $ E.catch (liftM Just $ FS.retrieve fs file rev)+               (\e -> if e == FS.NotFound then return Nothing else E.throwIO e)++--+-- Response-generating combinators+--++-- | Converts raw contents to a text/plain response.+textResponse :: Maybe String -> ContentTransformer Response+textResponse Nothing  = mzero  -- fail quietly if file not found+textResponse (Just c) = mimeResponse c "text/plain; charset=utf-8"++-- | Converts raw contents to a response that is appropriate with+-- a mime type derived from the page's extension.+mimeFileResponse :: Maybe String -> ContentTransformer Response+mimeFileResponse Nothing = error "Unable to retrieve file contents."+mimeFileResponse (Just c) =+  mimeResponse c =<< lift . getMimeTypeForExtension . takeExtension =<< getFileName++mimeResponse :: Monad m+             => String        -- ^ Raw contents for response body+             -> String        -- ^ Mime type+             -> m Response+mimeResponse c mimeType =+  return . setContentType mimeType . toResponse $ c++-- | Converts Pandoc to response using format specified in parameters.+exportPandoc :: Pandoc -> ContentTransformer Response+exportPandoc doc = do+  params <- getParams+  page <- getPageName+  cfg <- lift getConfig+  let format = pFormat params+  case lookup format (exportFormats cfg) of+       Nothing     -> error $ "Unknown export format: " ++ format+       Just writer -> lift (writer page doc)++-- | Adds the sidebar, page tabs, and other elements of the wiki page+-- layout to the raw content.+applyWikiTemplate :: Html -> ContentTransformer Response+applyWikiTemplate c = do+  Context { ctxLayout = layout } <- get+  lift $ formattedPage layout c++--+-- Content-type transformation combinators+--++-- | Converts Page to Pandoc, applies page transforms, and adds page+-- title.+pageToWikiPandoc :: Page -> ContentTransformer Pandoc+pageToWikiPandoc page' =+  pageToWikiPandoc' page' >>= addPageTitleToPandoc (pageTitle page')++pageToWikiPandoc' :: Page -> ContentTransformer Pandoc+pageToWikiPandoc' = applyPreParseTransforms >=>+                     pageToPandoc >=> applyPageTransforms++-- | Converts source text to Pandoc using default page type.+pageToPandoc :: Page -> ContentTransformer Pandoc+pageToPandoc page' = do+  modifyContext $ \ctx -> ctx{ ctxTOC = pageTOC page'+                             , ctxCategories = pageCategories page'+                             , ctxMeta = pageMeta page' }+  return $ readerFor (pageFormat page') (pageLHS page') (pageText page')++-- | Detects if the page is a redirect page and handles accordingly. The exact+-- behaviour is as follows:+--+-- If the page is /not/ a redirect page (the most common case), then check the+-- referer to see if the client came to this page as a result of a redirect+-- from another page. If so, then add a notice to the messages to notify the+-- user that they were redirected from another page, and provide a link back+-- to the original page, with an extra parameter to disable redirection+-- (e.g., to allow the original page to be edited).+--+-- If the page /is/ a redirect page, then check the query string for the+-- @redirect@ parameter. This can modify the behaviour of the redirect as+-- follows:+--+-- 1. If the @redirect@ parameter is unset, then check the referer to see if+--    client came to this page as a result of a redirect from another page. If+--    so, then do not redirect, and add a notice to the messages explaining+--    that this page is a redirect page, that would have redirected to the+--    destination given in the metadata (and provide a link thereto), but this+--    was stopped because a double-redirect was detected. This is a simple way+--    to prevent cyclical redirects and other abuses enabled by redirects.+--    redirect to the same page. If the client did /not/ come to this page as+--    a result of a redirect, then redirect back to the same page, except with+--    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+--    refresh + javascript backup) redirect to make sure the referer is set to+--    this URL.+--+-- 3. If the @redirect@ parameter is set to \"no\", then do not redirect, but+--    add a notice to the messages that this page /would/ have redirected to+--    the destination given in the metadata had it not been disabled, and+--    provide a link to the destination given in the metadata. This behaviour+--    is the @revision@ parameter is present in the query string.+handleRedirects :: Page -> ContentTransformer (Either Response Page)+handleRedirects page = case lookup "redirect" (pageMeta page) of+    Nothing -> isn'tRedirect+    Just destination -> isRedirect destination+  where+    addMessage message = modifyContext $ \context -> context+        { ctxLayout = (ctxLayout context)+            { pgMessages = pgMessages (ctxLayout context) ++ [message]+            }+        }+    redirectedFrom source = do+        (url, html) <- processSource source+        return $ concat+            [ "Redirected from <a href=\""+            , url+            , "?redirect=no\" title=\"Go to original page\">"+            , html+            , "</a>"+            ]+    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>"+            , ", 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>."+            ]+    processSource source = do+        base' <- getWikiBase+        let url = stringToHtmlString $ base' ++ urlForPage source+        let html = stringToHtmlString source+        return (url, html)+    processDestination destination = do+        base' <- getWikiBase+        let (page', fragment) = break (== '#') destination+        let url = stringToHtmlString $ concat+             [ base'+             , urlForPage page'+             , fragment+             ]+        let html = stringToHtmlString page'+        return (url, html)+    getSource = do+        cfg <- lift getConfig+        base' <- getWikiBase+        request <- askRq+        return $ do+            uri <- getHeader "referer" request >>= parseURI . SC.unpack+            let params = uriQueryItems uri+            redirect' <- lookup "redirect" params+            guard $ redirect' == "yes"+            path' <- stripPrefix (base' ++ "/") (uriPath uri)+            let path'' = if null path' then frontPage cfg else urlDecode path'+            guard $ isPage path''+            return path''+    withBody = setContentType "text/html; charset=utf-8" . toResponse+    isn'tRedirect = do+        getSource >>= traverse_ (redirectedFrom >=> addMessage)+        return (Right page)+    isRedirect destination = do+        params <- getParams+        case maybe (pRedirect params) (\_ -> Just False) (pRevision params) of+             Nothing -> do+                source <- getSource+                case source of+                     Just source' -> do+                        doubleRedirect source' destination >>= addMessage+                        return (Right page)+                     Nothing -> fmap Left $ do+                        base' <- getWikiBase+                        let url' = concat+                             [ base'+                             , 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>"+                            ]+             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>"+                    ]+             Just False -> do+                cancelledRedirect destination >>= addMessage+                return (Right page)++-- | Converts contents of page file to Page object.+contentsToPage :: String -> ContentTransformer Page+contentsToPage s = do+  cfg <- lift getConfig+  pn <- getPageName+  return $ stringToPage cfg pn s++-- | Converts pandoc document to HTML.+pandocToHtml :: Pandoc -> ContentTransformer Html+pandocToHtml pandocContents = do+  base' <- lift getWikiBase+  toc <- liftM ctxTOC get+  bird <- liftM ctxBirdTracks get+  cfg <- lift getConfig+  return $ primHtml $ T.unpack .+           (if xssSanitize cfg then sanitizeBalance else id) . T.pack $+           writeHtmlString def{+                        writerStandalone = True+                      , writerTemplate = "$if(toc)$<div id=\"TOC\">\n$toc$\n</div>\n$endif$\n$body$"+                      , writerHTMLMathMethod =+                            case mathMethod cfg of+                                 MathML -> Pandoc.MathML Nothing+                                 WebTeX u -> Pandoc.WebTeX u+                                 MathJax u -> Pandoc.MathJax u+                                 _      -> JsMath (Just $ base' +++                                                      "/js/jsMath/easy/load.js")+                      , writerTableOfContents = toc+                      , writerHighlight = True+                      , writerExtensions = if bird+                                              then Set.insert+                                                   Ext_literate_haskell+                                                   $ writerExtensions def+                                              else writerExtensions def+                      -- note: javascript obfuscation gives problems on preview+                      , writerEmailObfuscation = ReferenceObfuscation+                      } pandocContents++-- | Returns highlighted source code.+highlightSource :: Maybe String -> ContentTransformer Html+highlightSource Nothing = mzero+highlightSource (Just source) = do+  file <- getFileName+  let formatOpts = defaultFormatOpts { numberLines = True, lineAnchors = True }+  case languagesByExtension $ takeExtension file of+        []    -> mzero+        (l:_) -> return $ primHtml $ Blaze.renderHtml+                        $ formatHtmlBlock formatOpts+                        $! highlightAs l $ filter (/='\r') source++--+-- Plugin combinators+--++getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]+getPageTransforms = liftM (mapMaybe pageTransform) $ queryGititState plugins+  where pageTransform (PageTransform x) = Just x+        pageTransform _                 = Nothing++getPreParseTransforms :: ContentTransformer [String -> PluginM String]+getPreParseTransforms = liftM (mapMaybe preParseTransform) $+                          queryGititState plugins+  where preParseTransform (PreParseTransform x) = Just x+        preParseTransform _                     = Nothing++getPreCommitTransforms :: ContentTransformer [String -> PluginM String]+getPreCommitTransforms = liftM (mapMaybe preCommitTransform) $+                          queryGititState plugins+  where preCommitTransform (PreCommitTransform x) = Just x+        preCommitTransform _                      = Nothing++-- | @applyTransform a t@ applies the transform @t@ to input @a@.+applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a+applyTransform inp transform = do+  context <- get+  conf <- lift getConfig+  user <- lift getLoggedInUser+  fs <- lift getFileStore+  req <- lift askRq+  let pluginData = PluginData{ pluginConfig = conf+                             , pluginUser = user+                             , pluginRequest = req+                             , pluginFileStore = fs }+  (result', context') <- liftIO $ runPluginM (transform inp) pluginData context+  put context'+  return result'++-- | Applies all the page transform plugins to a Pandoc document.+applyPageTransforms :: Pandoc -> ContentTransformer Pandoc+applyPageTransforms c = do+  xforms <- getPageTransforms+  foldM applyTransform c (wikiLinksTransform : xforms)++-- | Applies all the pre-parse transform plugins to a Page object.+applyPreParseTransforms :: Page -> ContentTransformer Page+applyPreParseTransforms page' = getPreParseTransforms >>= foldM applyTransform (pageText page') >>=+                                (\t -> return page'{ pageText = t })++-- | Applies all the pre-commit transform plugins to a raw string.+applyPreCommitTransforms :: String -> ContentTransformer String+applyPreCommitTransforms c = getPreCommitTransforms >>= foldM applyTransform c++--+-- Content or context augmentation combinators+--++-- | Puts rendered page content into a wikipage div, adding+-- categories.+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 htmlCategories = if null categories+                          then noHtml+                          else thediv ! [identifier "categoryList"] << ulist << map categoryLink categories+  return $ thediv ! [identifier "wikipage"] << [c, htmlCategories]++-- | Adds page title to a Pandoc document.+addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc+addPageTitleToPandoc title' (Pandoc _ blocks) = do+  updateLayout $ \layout -> layout{ pgTitle = title' }+  return $ if null title'+              then Pandoc nullMeta blocks+              else Pandoc (B.setMeta "title" (B.str title') nullMeta) blocks++-- | Adds javascript links for math support.+addMathSupport :: a -> ContentTransformer a+addMathSupport c = do+  conf <- lift getConfig+  updateLayout $ \l ->+    case mathMethod conf of+         JsMathScript -> addScripts l ["jsMath/easy/load.js"]+         MathML       -> addScripts l ["MathMLinHTML.js"]+         WebTeX _     -> l+         MathJax u    -> addScripts l [u]+         RawTeX       -> l+  return c++-- | Adds javascripts to page layout.+addScripts :: PageLayout -> [String] -> PageLayout+addScripts layout scriptPaths =+  layout{ pgScripts = scriptPaths ++ pgScripts layout }++--+-- ContentTransformer context API+--++getParams :: ContentTransformer Params+getParams = lift (withData return)++getFileName :: ContentTransformer FilePath+getFileName = liftM ctxFile get++getPageName :: ContentTransformer String+getPageName = liftM (pgPageName . ctxLayout) get++getLayout :: ContentTransformer PageLayout+getLayout = liftM ctxLayout get++getCacheable :: ContentTransformer Bool+getCacheable = liftM ctxCacheable get++-- | Updates the layout with the result of applying f to the current layout+updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()+updateLayout f = do+  ctx <- get+  let l = ctxLayout ctx+  put ctx { ctxLayout = f l }++--+-- Pandoc and wiki content conversion support+--++readerFor :: PageType -> Bool -> String -> Pandoc+readerFor pt lhs =+  let defPS = def{ readerSmart = True+                 , readerExtensions = if lhs+                                         then Set.insert Ext_literate_haskell+                                              $ readerExtensions def+                                         else readerExtensions def+                 , readerParseRaw = True+                 }+  in handleError . case pt of+       RST        -> readRST defPS+       Markdown   -> readMarkdown defPS+#if MIN_VERSION_pandoc(1,14,0)+       CommonMark -> readCommonMark defPS+#else+       CommonMark -> error "CommonMark input requires pandoc 1.14"+#endif+       LaTeX      -> readLaTeX defPS+       HTML       -> readHtml defPS+       Textile    -> readTextile defPS+       Org        -> readOrg defPS+       DocBook    -> readDocBook defPS+       MediaWiki  -> readMediaWiki defPS++wikiLinksTransform :: Pandoc -> PluginM Pandoc+wikiLinksTransform pandoc+  = do cfg <- liftM pluginConfig ask -- Can't use askConfig from Interface due to circular dependencies.+       return (bottomUp (convertWikiLinks cfg) pandoc)++-- | Convert links with no URL to wikilinks.+convertWikiLinks :: Config -> Inline -> Inline+convertWikiLinks cfg (Link ref ("", "")) | useAbsoluteUrls cfg =+  Link ref ("/" </> baseUrl cfg </> inlinesToURL ref, "Go to wiki page")+convertWikiLinks _cfg (Link ref ("", "")) =+  Link ref (inlinesToURL ref, "Go to wiki page")+convertWikiLinks _cfg x = x++-- | Derives a URL from a list of Pandoc Inline elements.+inlinesToURL :: [Inline] -> String+inlinesToURL = encString False isUnescapedInURI . inlinesToString++-- | Convert a list of inlines into a string.+inlinesToString :: [Inline] -> String+inlinesToString = concatMap go+  where go x = case x of+               Str s                   -> s+               Emph xs                 -> concatMap go xs+               Strong xs               -> concatMap go xs+               Strikeout xs            -> concatMap go xs+               Superscript xs          -> concatMap go xs+               Subscript xs            -> concatMap go xs+               SmallCaps xs            -> concatMap go xs+               Quoted DoubleQuote xs   -> '"' : (concatMap go xs ++ "\"")+               Quoted SingleQuote xs   -> '\'' : (concatMap go xs ++ "'")+               Cite _ xs               -> concatMap go xs+               Code _ s                -> s+               Space                   -> " "+               LineBreak               -> " "+               Math DisplayMath s      -> "$$" ++ s ++ "$$"+               Math InlineMath s       -> "$" ++ s ++ "$"+               RawInline (Format "tex") s -> s+               RawInline _ _           -> ""+               Link xs _               -> concatMap go xs+               Image xs _              -> concatMap go xs+               Note _                  -> ""+               Span _ xs               -> concatMap go xs+