gitit-0.5.1: Gitit.hs
{-# LANGUAGE Rank2Types, FlexibleContexts #-}
{-
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
-}
module Main where
import Gitit.Server
import Gitit.Util (orIfNull, consolidateHeads)
import Gitit.Initialize (createStaticIfMissing, createRepoIfMissing)
import Gitit.Framework
import Gitit.Layout
import Gitit.Convert
import Gitit.Export (exportFormats)
import System.IO.UTF8
import System.IO (stderr)
import Control.Exception (throwIO, catch, try)
import Prelude hiding (writeFile, readFile, putStrLn, putStr, catch)
import System.Directory
import System.Time
import Control.Concurrent
import System.FilePath
import Gitit.State
import Gitit.Config (getConfigFromOpts)
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import qualified Text.XHtml as X ( password, method )
import Data.List (intersperse, sort, nub, sortBy, isSuffixOf, find, isPrefixOf)
import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing)
import Codec.Binary.UTF8.String (encodeString)
import qualified Data.Map as M
import Data.Ord (comparing)
import Paths_gitit
import Text.Pandoc
import Text.Pandoc.Shared (substitute)
import Data.Char (isAlphaNum, isAlpha, toLower)
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as B
import Network.HTTP (urlEncodeVars)
import Text.Highlighting.Kate
import qualified Text.StringTemplate as T
import Data.DateTime (getCurrentTime, addMinutes, formatDateTime)
import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)
import Data.FileStore
main :: IO ()
main = do
-- parse options to get config file
conf <- getConfigFromOpts
-- check for external programs that are needed
let prereqs = "grep" : case repository conf of
Git _ -> ["git"]
Darcs _ -> ["darcs"]
forM_ prereqs $ \prog ->
findExecutable prog >>= \mbFind ->
when (isNothing mbFind) $ error $
"Required program '" ++ prog ++ "' not found in system path."
-- read user file and update state
userFileExists <- doesFileExist $ userFile conf
users' <- if userFileExists
then liftM (M.fromList . read) $ readFile $ userFile conf
else return M.empty
-- create template file if it doesn't exist
let templatefile = templateFile conf
templateExists <- doesFileExist templatefile
unless templateExists $ do
templatePath <- getDataFileName $ "data" </> "template.html"
copyFile templatePath templatefile
hPutStrLn stderr $ "Created " ++ templatefile
-- read template file
templ <- liftM T.newSTMP $ liftIO $ readFile templatefile
-- initialize state
initializeAppState conf users' templ
-- setup the page repository and static files, if they don't exist
createRepoIfMissing conf
let staticdir = staticDir conf
createStaticIfMissing staticdir
-- start the server
hPutStrLn stderr $ "Starting server on port " ++ show (portNumber conf)
tid <- forkIO $ simpleHTTP (Conf { validator = Nothing, port = portNumber conf }) $
map (\d -> dir d [ withExpiresHeaders $ fileServe [] $ staticdir </> d]) ["css", "img", "js"] ++
[ debugHandler | debugMode conf ] ++
[ filterIf acceptsZip gzipBinary $ cookieFixer $ multi wikiHandlers ]
waitForTermination
-- shut down the server
putStrLn "Shutting down..."
killThread tid
putStrLn "Shutdown complete"
wikiHandlers :: [Handler]
wikiHandlers = [ handlePath "_index" GET indexPage
, handlePath "_activity" GET showActivity
, handlePath "_preview" POST preview
, handlePath "_go" POST goToPage
, handlePath "_search" POST searchResults
, handlePath "_search" GET searchResults
, handlePath "_register" GET registerUserForm
, handlePath "_register" POST registerUser
, handlePath "_login" GET loginUserForm
, handlePath "_login" POST loginUser
, handlePath "_logout" GET logoutUser
, handlePath "_upload" GET (ifLoggedIn uploadForm loginUserForm)
, handlePath "_upload" POST (ifLoggedIn uploadFile loginUserForm)
, handlePath "_random" GET randomPage
, handlePath "" GET showFrontPage
, withCommand "showraw" [ handlePage GET showRawPage ]
, withCommand "history" [ handlePage GET showPageHistory,
handle (not . isPage) GET showFileHistory ]
, withCommand "edit" [ handlePage GET $ unlessNoEdit (ifLoggedIn editPage loginUserForm) showPage ]
, withCommand "diff" [ handlePage GET showPageDiff,
handle isSourceCode GET showFileDiff ]
, withCommand "export" [ handlePage POST exportPage, handlePage GET exportPage ]
, withCommand "cancel" [ handlePage POST showPage ]
, withCommand "discuss" [ handlePage GET discussPage ]
, withCommand "update" [ handlePage POST $ unlessNoEdit (ifLoggedIn updatePage loginUserForm) showPage ]
, withCommand "delete" [ handlePage GET $ unlessNoDelete (ifLoggedIn confirmDelete loginUserForm) showPage,
handlePage POST $ unlessNoDelete (ifLoggedIn deletePage loginUserForm) showPage ]
, handlePage GET showPage
, handleSourceCode
, handleAny
, handlePage GET createPage
]
handleSourceCode :: Handler
handleSourceCode = withData $ \com ->
case com of
Command (Just "showraw") -> [ handle isSourceCode GET showFileAsText ]
_ -> [ handle isSourceCode GET showHighlightedSource ]
handleAny :: Handler
handleAny =
uriRest $ \uri -> let path' = uriPath uri
in do fs <- getFileStore
mimetype <- getMimeTypeForExtension (takeExtension path')
res <- liftIO $ try $ (retrieve fs path' Nothing :: IO B.ByteString)
case res of
Right contents -> anyRequest $ ok $ setContentType mimetype $
(toResponse noHtml) {rsBody = contents} -- ugly hack
Left NotFound -> anyRequest noHandle
Left e -> error (show e)
debugHandler :: Handler
debugHandler = do
liftIO $ putStr "\n"
withRequest $ \req -> liftIO $ getCurrentTime >>= (putStrLn . formatDateTime "%c") >> putStrLn (show req)
multi [ handle (const True) GET showParams, handle (const True) POST showParams ]
where showParams page params = do
liftIO $ putStrLn page >> putStrLn (show params)
noHandle
showRawPage :: String -> Params -> Web Response
showRawPage = showFileAsText . pathForPage
showFileAsText :: String -> Params -> Web Response
showFileAsText file params = do
mContents <- rawContents file params
case mContents of
Nothing -> error "Unable to retrieve page contents."
Just c -> ok $ setContentType "text/plain; charset=utf-8" $ toResponse $ encodeString c
randomPage :: String -> Params -> Web Response
randomPage _ _ = do
fs <- getFileStore
files <- liftIO $ index fs
let pages = map dropExtension $ filter (\f -> takeExtension f == ".page" && not (":discuss.page" `isSuffixOf` f)) files
if null pages
then error "No pages found!"
else do
TOD _ picosecs <- liftIO getClockTime
let newPage = pages !! ((fromIntegral picosecs `div` 1000000) `mod` length pages)
seeOther (urlForPage newPage) $ toResponse $ p << "Redirecting to a random page"
showFrontPage :: String -> Params -> Web Response
showFrontPage _ params = do
cfg <- getConfig
showPage (frontPage cfg) params
showPage :: String -> Params -> Web Response
showPage page params = do
jsMathExists <- queryAppState jsMath
mbCached <- lookupCache (pathForPage page) (pRevision params)
case mbCached of
Just cp ->
formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js" | jsMathExists]}) page params $ cpContents cp
_ -> do
mDoc <- pageAsPandoc page params
case mDoc of
Just d -> do
let divify c = thediv ! [identifier "wikipage",
strAttr "onDblClick" ("window.location = '" ++ urlForPage page ++
"?edit" ++
(case (pRevision params) of
Nothing -> ""
Just r -> urlEncodeVars [("revision", r),("logMsg", "Revert to " ++ r)]) ++ "';")] << c
c <- liftM divify $ pandocToHtml d
when (isNothing (pRevision params)) $ do
-- TODO not quite ideal, since page might have been modified after being retrieved by pageAsPandoc
-- better to have pageAsPandoc return the revision ID too...
fs <- getFileStore
rev <- liftIO $ latest fs (pathForPage page)
cacheContents (pathForPage page) rev c
formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js" | jsMathExists]}) page params c
Nothing -> noHandle
discussPage :: String -> Params -> Web Response
discussPage page params = do
if isDiscussPage page
then showPage page params
else showPage (page ++ ":discuss") params
createPage :: String -> Params -> Web Response
createPage page params =
formattedPage (defaultPageLayout { pgTabs = [] }) page params $
p << [ stringToHtml ("There is no page '" ++ page ++ "'. You may create the page by ")
, anchor ! [href $ urlForPage page ++ "?edit"] << "clicking here." ]
uploadForm :: String -> Params -> Web Response
uploadForm _ params = do
let page = "_upload"
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 << "File to upload:", br, afile "file" ! [value origPath] ]
, p << [label << "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 << "Overwrite existing file"]
, p << [label << "Description of content or changes:", br, textfield "logMsg" ! [size "60", value logMsg],
submit "upload" "Upload"] ]
formattedPage (defaultPageLayout { pgScripts = ["uploadForm.js"], pgShowPageTools = False, pgTabs = [], pgTitle = "Upload a file"} ) page params upForm
uploadFile :: String -> Params -> Web Response
uploadFile _ params = do
let page = "_upload"
let origPath = pFilename params
let fileContents = pFileContents params
let wikiname = pWikiname params `orIfNull` takeFileName origPath
let logMsg = pLogMsg params
cfg <- getConfig
mbUser <- getUser $ pUser params
(user, email) <- case mbUser of
Nothing -> fail "User must be logged in to delete page."
Just u -> return (uUsername u, uEmail u)
let overwrite = pOverwrite params
fs <- getFileStore
exists <- liftIO $ catch (latest fs wikiname >> return True) (\e -> if e == NotFound then return False else throwIO e >> return True)
let imageExtensions = [".png", ".jpg", ".gif"]
let errors = validate [ (null logMsg, "Description cannot be empty.")
, (null origPath, "File not found.")
, (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 existing file.")
, (B.length fileContents > fromIntegral (maxUploadSize cfg),
"File exceeds maximum upload size.")
, (takeExtension wikiname == ".page",
"This file extension is reserved for wiki pages.")
]
if null errors
then do
liftIO $ save fs wikiname (Author user email) logMsg fileContents
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Upload successful" }) page params $
thediv << [ h2 << ("Uploaded " ++ show (B.length fileContents) ++ " 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 ++ ")") ]
else uploadForm page (params { pMessages = errors })
goToPage :: String -> Params -> Web Response
goToPage _ params = do
let gotopage = pGotoPage params
fs <- getFileStore
allPageNames <- liftM (map dropExtension . filter (".page" `isSuffixOf`)) $ liftIO $ index fs
let findPage f = find f allPageNames
case findPage (gotopage ==) of
Just m -> seeOther (urlForPage m) $ toResponse "Redirecting to exact match"
Nothing -> case findPage (\n -> (map toLower gotopage) == (map toLower n)) of
Just m -> seeOther (urlForPage m) $ toResponse "Redirecting to case-insensitive match"
Nothing -> case findPage (\n -> (map toLower gotopage) `isPrefixOf` (map toLower n)) of
Just m -> seeOther (urlForPage m) $ toResponse "Redirecting to partial match"
Nothing -> searchResults "" params{ pPatterns = words gotopage }
searchResults :: String -> Params -> Web Response
searchResults _ params = do
let page = "_search"
let patterns = pPatterns params
let limit = pLimit params
fs <- getFileStore
matchLines <- if null patterns
then return []
else liftM (take limit) $ liftIO $ search fs defaultSearchQuery{queryPatterns = patterns}
let contentMatches = map matchResourceName matchLines
allPages <- liftM (filter (".page" `isSuffixOf`)) $ liftIO $ index fs
let matchesPatterns pageName = all (`elem` (words $ map toLower $ dropExtension pageName)) $ map (map toLower) patterns
let pageNameMatches = filter matchesPatterns allPages
let allMatchedFiles = nub $ filter (".page" `isSuffixOf`) contentMatches ++ pageNameMatches
let matches = map (\f -> (f, mapMaybe (\x -> if matchResourceName x == f then Just (matchLine x) else Nothing) matchLines)) allMatchedFiles
let relevance (f, ms) = length ms + if f `elem` pageNameMatches then 100 else 0
let preamble = if null matches
then h3 << if null patterns
then ["Please enter a search term."]
else ["No matches found for '", unwords patterns, "':"]
else h3 << [(show $ length matches), " matches found for '", unwords patterns, "':"]
let htmlMatches = preamble +++ olist << map
(\(file, contents) -> li << [anchor ! [href $ urlForPage $ takeBaseName file] << takeBaseName 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])
(reverse $ sortBy (comparing relevance) matches)
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgScripts = ["search.js"], pgTitle = "Search results"}) page params htmlMatches
preview :: String -> Params -> Web Response
preview _ params = do
pt <- getDefaultPageType -- should get the current page type instead
pandocToHtml (textToPandoc pt $ pRaw params) >>= ok . toResponse . encodeString . renderHtmlFragment
showPageHistory :: String -> Params -> Web Response
showPageHistory page params = showHistory (pathForPage page) page params
showFileHistory :: String -> Params -> Web Response
showFileHistory file params = showHistory file file params
showHistory :: String -> String -> Params -> Web Response
showHistory file page params = do
currTime <- liftIO getCurrentTime
let oneYearAgo = addMinutes (-1 * 60 * 24 * 365) currTime
let since = case pSince params of
Nothing -> Just oneYearAgo
Just t -> Just t
fs <- getFileStore
hist <- liftIO $ history fs [file] (TimeRange since Nothing)
if null hist
then noHandle
else do
let versionToHtml rev pos =
li ! [theclass "difflink", intAttr "order" pos, strAttr "revision" $ revId rev] <<
[thespan ! [theclass "date"] << (show $ revDateTime rev), stringToHtml " (",
thespan ! [theclass "author"] <<
anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", authorName $ revAuthor rev)]] <<
(authorName $ revAuthor rev), stringToHtml ")", stringToHtml ": ",
anchor ! [href (urlForPage page ++ "?revision=" ++ revId rev)] <<
thespan ! [theclass "subject"] << revDescription rev,
noscript << ([stringToHtml " [compare with ",
anchor ! [href $ urlForPage page ++ "?diff&from=" ++ revId rev ++
"^&to=" ++ revId rev] << "previous"] ++
(if pos /= 1
then [primHtmlChar "nbsp", primHtmlChar "bull",
primHtmlChar "nbsp",
anchor ! [href $ urlForPage page ++ "?diff&from=" ++
revId rev ++ "&to=HEAD"] << "current" ]
else []) ++
[stringToHtml "]"])]
let contents = ulist ! [theclass "history"] << zipWith versionToHtml hist [(length hist), (length hist - 1)..1]
formattedPage (defaultPageLayout { pgScripts = ["dragdiff.js"], pgSelectedTab = HistoryTab, pgTitle = ("Changes to " ++ page) }) page params contents
showActivity :: String -> Params -> Web Response
showActivity _ params = do
let page = "_activity"
currTime <- liftIO getCurrentTime
let oneMonthAgo = addMinutes (-1 * 60 * 24 * 30) currTime
let since = case pSince params of
Nothing -> Just oneMonthAgo
Just t -> Just t
let forUser = pForUser params
fs <- getFileStore
hist <- liftIO $ history fs [] (TimeRange since Nothing)
let fileFromChange (Added f) = f
fileFromChange (Modified f) = f
fileFromChange (Deleted f) = f
let filesFor changes revis = intersperse (primHtmlChar "nbsp") $ map
(\file -> anchor ! [href $ urlForPage file ++ "?diff&to=" ++ revis] << file) $ map
(\file -> if ".page" `isSuffixOf` file then dropExtension file else file) $ map fileFromChange changes
let heading = h1 << ("Recent changes" ++ if null forUser then "" else (" by " ++ forUser))
let contents = ulist ! [theclass "history"] << map (\rev -> li <<
[thespan ! [theclass "date"] << (show $ revDateTime rev), stringToHtml " (",
thespan ! [theclass "author"] <<
anchor ! [href $ "/_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 ")"]) hist
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Recent changes" }) page params (heading +++ contents)
showPageDiff :: String -> Params -> Web Response
showPageDiff page params = showDiff (pathForPage page) page params
showFileDiff :: String -> Params -> Web Response
showFileDiff page params = showDiff page page params
showDiff :: String -> String -> Params -> Web Response
showDiff file page params = do
let from = pFrom params
let to = pTo params
fs <- getFileStore
from' <- case from of
Nothing -> do
pageHist <- liftIO $ history fs [pathForPage page] (TimeRange Nothing Nothing)
if length pageHist < 2
then return Nothing
else case to of
Nothing -> return Nothing
Just t -> let (_, upto) = break (\r -> idsMatch fs (revId r) t) pageHist
in return $
if length upto >= 2
then Just $ revId $ upto !! 1 -- the immediately preceding revision
else Nothing
x -> return x
rawDiff <- liftIO $ diff fs file from' to
let diffItemToHtml (B, xs) = thespan << xs
diffItemToHtml (F, xs) = thespan ! [theclass "deleted"] << xs
diffItemToHtml (S, xs) = thespan ! [theclass "added"] << xs
let formattedDiff = h2 ! [theclass "revision"] << ("Changes from " ++ case from' of { Just r -> r; Nothing -> "beginning" }) +++
pre ! [theclass "diff"] << map diffItemToHtml rawDiff
formattedPage (defaultPageLayout { pgTabs = DiffTab : pgTabs defaultPageLayout, pgSelectedTab = DiffTab })
page (params { pRevision = to }) formattedDiff
editPage :: String -> Params -> Web Response
editPage page params = do
let rev = pRevision params
let messages = pMessages params
fs <- getFileStore
(mbRev, raw) <- case pEditedText params of
Nothing -> liftIO $ catch
(do c <- liftIO $ retrieve fs (pathForPage page) rev
r <- liftIO $ case rev of
Nothing -> latest fs (pathForPage page) >>= revision fs
Just r -> revision fs r
return $ (Just $ revId r, c))
(\e -> if e == NotFound
then return (Nothing, "")
else throwIO e)
Just t -> return (if null (pSHA1 params) then Nothing else Just (pSHA1 params), t)
let logMsg = pLogMsg params
let sha1Box = case mbRev of
Just r -> textfield "sha1" ! [thestyle "display: none", value r]
Nothing -> noHtml
let editForm = gui (urlForPage page) ! [identifier "editform"] <<
[sha1Box,
textarea ! [cols "80", name "editedText", identifier "editedText"] << raw, br,
label << "Description of changes:", br,
textfield "logMsg" ! [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 ]
formattedPage (defaultPageLayout { pgShowPageTools = False, pgSelectedTab = EditTab,
pgScripts = ["preview.js"], pgTitle = ("Editing " ++ page) }) page (params {pMessages = messages}) editForm
confirmDelete :: String -> Params -> Web Response
confirmDelete page params = do
let confirmForm = gui "" <<
[ p << "Are you sure you want to delete this page?"
, submit "confirm" "Yes, delete it!"
, stringToHtml " "
, submit "cancel" "No, keep it!"
, br ]
formattedPage defaultPageLayout page params confirmForm
deletePage :: String -> Params -> Web Response
deletePage page params = do
mbUser <- getUser $ pUser params
(user, email) <- case mbUser of
Nothing -> fail "User must be logged in to delete page."
Just u -> return (uUsername u, uEmail u)
if pConfirm params
then do
fs <- getFileStore
liftIO $ delete fs (pathForPage page) (Author user email) "Deleted using web interface."
seeOther "/" $ toResponse $ p << "Page deleted"
else seeOther (urlForPage page) $ toResponse $ p << "Page not deleted"
updatePage :: String -> Params -> Web Response
updatePage page params = do
mbUser <- getUser $ pUser params
(user, email) <- case mbUser of
Nothing -> fail "User must be logged in to delete page."
Just u -> return (uUsername u, uEmail u)
let editedText = case pEditedText params of
Nothing -> error "No body text in POST request"
Just b -> b
let logMsg = pLogMsg params
let oldSHA1 = pSHA1 params
fs <- getFileStore
if null logMsg
then editPage page (params { pMessages = ["Description cannot be empty."] })
else do
cfg <- getConfig
if length editedText > fromIntegral (maxUploadSize cfg)
then error "Page exceeds maximum size."
else return ()
-- ensure that every file has a newline at the end, to avoid "No newline at eof" messages in diffs
let editedText' = if null editedText || last editedText == '\n' then editedText else editedText ++ "\n"
-- check SHA1 in case page has been modified, merge
modifyRes <- if null oldSHA1
then liftIO $ create fs (pathForPage page) (Author user email) logMsg editedText' >> return (Right ())
else liftIO $ catch (modify fs (pathForPage page) oldSHA1 (Author user email) logMsg editedText')
(\e -> if e == Unchanged then return (Right ()) else throwIO e)
case modifyRes of
Right () -> seeOther (urlForPage page) $ toResponse $ p << "Page updated"
Left (MergeInfo mergedWithRev False mergedText) ->
updatePage page params{ pMessages = ("Merged with revision " ++ revId mergedWithRev) : pMessages params,
pEditedText = Just mergedText,
pSHA1 = revId mergedWithRev }
Left (MergeInfo mergedWithRev True mergedText) -> do
let mergeMsg = "The page has been edited since you checked it out. " ++
"Changes have been merged into your edits below. " ++
"Please resolve conflicts and Save."
editPage page (params { pEditedText = Just mergedText
, pSHA1 = revId mergedWithRev
, pMessages = [mergeMsg] })
indexPage :: String -> Params -> Web Response
indexPage _ params = do
let page = "_index"
fs <- getFileStore
files <- liftIO $ index fs
let htmlIndex = fileListToHtml "/" $ map splitPath $ sort $ filter (\f -> not (":discuss.page" `isSuffixOf` f)) files
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgScripts = ["folding.js"], pgTitle = "All pages" }) page params htmlIndex
-- | Create a hierarchical ordered list (with links) for a list of files
fileListToHtml :: String -> [[FilePath]] -> Html
fileListToHtml prefix lst = ulist ! [identifier "index", theclass "folding"] <<
(map (\(h, l) -> let h' = if takeExtension h == ".page" then dropExtension h else h
in if [] `elem` l
then li ! [theclass $ if takeExtension h == ".page" then "page" else "upload"] << anchor ! [href $ prefix ++ h'] << h'
else li ! [theclass "folder"] << [stringToHtml h', fileListToHtml (prefix ++ h') l]) $
consolidateHeads lst)
-- user authentication
loginForm :: Html
loginForm =
gui "/_login" ! [identifier "loginForm"] << fieldset <<
[ label << "Username ", textfield "username" ! [size "15"], stringToHtml " "
, label << "Password ", X.password "password" ! [size "15"], stringToHtml " "
, submit "login" "Login"] +++
p << [ stringToHtml "If you do not have an account, "
, anchor ! [href "/_register"] << "click here to get one." ]
loginUserForm :: String -> Params -> Web Response
loginUserForm page params =
addCookie (60 * 10) (mkCookie "destination" $ substitute " " "%20" $ fromMaybe "/" $ pReferer params) >>
loginUserForm' page params
loginUserForm' :: String -> Params -> Web Response
loginUserForm' page params =
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Login" }) page params loginForm
loginUser :: String -> Params -> Web Response
loginUser page params = do
let uname = pUsername params
let pword = pPassword params
let destination = pDestination params
allowed <- authUser uname pword
if allowed
then do
key <- newSession (SessionData uname)
addCookie sessionTime (mkCookie "sid" (show key))
addCookie 0 (mkCookie "destination" "") -- remove unneeded destination cookie
seeOther destination $ toResponse $ p << ("Welcome, " ++ uname)
else
loginUserForm' page (params { pMessages = "Authentication failed." : pMessages params })
logoutUser :: String -> Params -> Web Response
logoutUser _ params = do
let key = pSessionKey params
let destination = substitute " " "%20" $ fromMaybe "/" $ pReferer params
case key of
Just k -> do
delSession k
addCookie 0 (mkCookie "sid" "") -- make cookie expire immediately, effectively deleting it
Nothing -> return ()
seeOther destination $ toResponse "You have been logged out."
registerForm :: Web Html
registerForm = do
cfg <- getConfig
let accessQ = case accessQuestion cfg of
Nothing -> noHtml
Just (prompt, _) -> label << prompt +++ br +++
X.password "accessCode" ! [size "15"] +++ br
let captcha = if useRecaptcha cfg
then captchaFields (recaptchaPublicKey cfg) Nothing
else noHtml
return $ gui "" ! [identifier "loginForm"] << fieldset <<
[ accessQ
, label << "Username (at least 3 letters or digits):", br
, textfield "username" ! [size "20"], stringToHtml " ", br
, label << "Email (optional, will not be displayed on the Wiki):", br
, textfield "email" ! [size "20"], br
, textfield "fullname" ! [size "20", theclass "req"]
, label << "Password (at least 6 characters, including at least one non-letter):", br
, X.password "password" ! [size "20"], stringToHtml " ", br
, label << "Confirm Password:", br, X.password "password2" ! [size "20"], stringToHtml " ", br
, captcha
, submit "register" "Register" ]
registerUserForm :: String -> Params -> Web Response
registerUserForm _ params =
addCookie (60 * 10) (mkCookie "destination" $ substitute " " "%20" $ fromMaybe "/" $ pReferer params) >>
registerForm >>=
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) "_register" params
registerUser :: String -> Params -> Web Response
registerUser _ params = do
let isValidUsername u = length u >= 3 && all isAlphaNum 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 isValidAccessCode = case accessQuestion cfg of
Nothing -> True
Just (_, answers) -> accessCode `elem` answers
let isValidEmail e = length (filter (=='@') e) == 1
captchaResult <- if useRecaptcha cfg
then if null (recaptchaChallengeField recaptcha) || null (recaptchaResponseField recaptcha)
then return $ Left "missing-challenge-or-response" -- no need to bother captcha.net in this case
else liftIO $ do
mbIPaddr <- lookupIPAddr $ pPeer params
let ipaddr = case mbIPaddr of
Just ip -> ip
Nothing -> error $ "Could not find ip address for " ++ pPeer params
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 [ (taken, "Sorry, that username is already taken.")
, (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, with 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), "You do not seem human enough.") ] -- fakeField is hidden in CSS (honeypot)
if null errors
then do
user <- liftIO $ mkUser uname email pword
addUser uname user
loginUser "/" (params { pUsername = uname, pPassword = pword, pEmail = email })
else registerForm >>=
formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" })
"_register" (params { pMessages = errors })
showHighlightedSource :: String -> Params -> Web Response
showHighlightedSource file params = do
mbCached <- lookupCache file (pRevision params)
case mbCached of
Just cp -> formattedPage defaultPageLayout file params $ cpContents cp
_ -> do
contents <- rawContents file params
case contents of
Just source -> let lang' = head $ languagesByExtension $ takeExtension file
in case highlightAs lang' (filter (/='\r') source) of
Left _ -> noHandle
Right res -> do
let formattedContents = formatAsXHtml [OptNumberLines] lang' res
when (isNothing (pRevision params)) $ do
fs <- getFileStore
rev <- liftIO $ latest fs file
cacheContents file rev formattedContents
formattedPage defaultPageLayout file params $ formattedContents
Nothing -> noHandle
exportPage :: String -> Params -> Web Response
exportPage page params = do
let format = pFormat params
mDoc <- pageAsPandoc page params
case mDoc of
Nothing -> error $ "Unable to retrieve page contents."
Just doc -> case lookup format exportFormats of
Nothing -> error $ "Unknown export format: " ++ format
Just writer -> writer page doc
rawContents :: String -> Params -> Web (Maybe String)
rawContents file params = do
let rev = pRevision params
fs <- getFileStore
liftIO $ catch (retrieve fs file rev >>= return . Just) (\e -> if e == NotFound then return Nothing else throwIO e)
pageAsPandoc :: String -> Params -> Web (Maybe Pandoc)
pageAsPandoc page params = do
pt <- getDefaultPageType
mDoc <- rawContents (pathForPage page) params >>= (return . liftM (textToPandoc pt))
return $ case mDoc of
Nothing -> Nothing
Just (Pandoc _ blocks) -> Just $ Pandoc (Meta [Str page] [] []) blocks