diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -38,7 +38,7 @@ import qualified Text.XHtml as X ( password, method ) import Data.List (intersect, intersperse, intercalate, sort, nub, sortBy, isSuffixOf) import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) -import Data.ByteString.UTF8 (fromString) +import Data.ByteString.UTF8 (fromString, toString) import qualified Data.ByteString.Lazy.UTF8 as L (fromString) import qualified Data.Map as M import Data.Ord (comparing) @@ -51,20 +51,23 @@ import Data.Char (isAlphaNum, isAlpha) import Control.Monad.Reader import qualified Data.ByteString.Lazy as B -import Network.HTTP (urlEncodeVars, urlEncode) +import Network.HTTP (urlEncodeVars, urlEncode, urlDecode) import System.Console.GetOpt import System.Exit import Text.Highlighting.Kate -import Text.StringTemplate as T +import qualified Text.StringTemplate as T import Data.IORef import System.IO.Unsafe (unsafePerformIO) gititVersion :: String -gititVersion = "0.3.2" +gititVersion = "0.3.3" -template :: IORef (StringTemplate String) -template = unsafePerformIO $ newIORef $ newSTMP "" -- initialize template to empty string +sessionTime :: Int +sessionTime = 60 * 60 -- session will expire 1 hour after page request +template :: IORef (T.StringTemplate String) +template = unsafePerformIO $ newIORef $ T.newSTMP "" -- initialize template to empty string + main :: IO () main = do argv <- getArgs @@ -75,7 +78,7 @@ initializeWiki conf -- initialize template templ <- liftIO $ readFile (templateFile conf) - writeIORef template (newSTMP templ) + writeIORef template (T.newSTMP templ) control <- startSystemState entryPoint update $ SetConfig conf -- read user file and update state @@ -227,21 +230,21 @@ , handlePath "_login" GET loginUserForm , handlePath "_login" POST loginUser , handlePath "_logout" GET logoutUser - , handlePath "_upload" GET (ifLoggedIn "" uploadForm) - , handlePath "_upload" POST (ifLoggedIn "" uploadFile) + , handlePath "_upload" GET (ifLoggedIn uploadForm) + , handlePath "_upload" POST (ifLoggedIn uploadFile) , handlePath "_random" GET randomPage , withCommand "showraw" [ handlePage GET showRawPage ] , withCommand "history" [ handlePage GET showPageHistory, handle (not . isPage) GET showFileHistory ] - , withCommand "edit" [ handlePage GET $ unlessNoEdit $ ifLoggedIn "?edit" editPage ] + , withCommand "edit" [ handlePage GET $ unlessNoEdit $ ifLoggedIn editPage ] , 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 "?edit" updatePage ] - , withCommand "delete" [ handlePage GET $ unlessNoDelete $ ifLoggedIn "?delete" confirmDelete, - handlePage POST $ unlessNoDelete $ ifLoggedIn "?delete" deletePage ] + , withCommand "update" [ handlePage POST $ unlessNoEdit $ ifLoggedIn updatePage ] + , withCommand "delete" [ handlePage GET $ unlessNoDelete $ ifLoggedIn confirmDelete, + handlePage POST $ unlessNoDelete $ ifLoggedIn deletePage ] , handleSourceCode , handleAny , handlePage GET showPage @@ -252,6 +255,8 @@ , pPassword2 :: String , pRevision :: String , pDestination :: String + , pReferer :: Maybe String + , pUri :: String , pForUser :: String , pSince :: String , pRaw :: String @@ -285,7 +290,7 @@ rv <- look "revision" `mplus` return "HEAD" fu <- look "forUser" `mplus` return "" si <- look "since" `mplus` return "" - ds <- look "destination" `mplus` return "" + ds <- (lookCookieValue "destination") `mplus` return "/" ra <- look "raw" `mplus` return "" lt <- look "limit" `mplus` return "100" pa <- look "patterns" `mplus` return "" @@ -313,6 +318,8 @@ , pForUser = fu , pSince = si , pDestination = ds + , pReferer = Nothing -- this gets set by handle... + , pUri = "" -- this gets set by handle... , pRaw = ra , pLimit = read lt , pPatterns = words pa @@ -333,7 +340,8 @@ , pAccessCode = ac , pUser = "" -- this gets set by ifLoggedIn... , pConfirm = cn - , pSessionKey = sk } + , pSessionKey = sk + } getLoggedInUser :: MonadIO m => Params -> m (Maybe String) getLoggedInUser params = do @@ -369,28 +377,35 @@ then showPage page (params { pMessages = ("Page cannot be deleted." : pMessages params) }) else responder page params -ifLoggedIn :: String -> (String -> Params -> Web Response) -> (String -> Params -> Web Response) -ifLoggedIn fallback responder = +ifLoggedIn :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) +ifLoggedIn responder = \page params -> do user <- getLoggedInUser params case user of - Nothing -> seeOther ("/_login?" ++ urlEncodeVars [("destination", page ++ fallback)]) $ - toResponse $ p << "You must be logged in to perform this action." + Nothing -> do + loginUserForm page (params { pReferer = Just $ pUri params }) Just u -> do usrs <- query AskUsers let e = case M.lookup u usrs of Just usr -> uEmail usr Nothing -> error $ "User '" ++ u ++ "' not found." + -- give the user another hour... + addCookie sessionTime (mkCookie "sid" (show $ fromJust $ pSessionKey params)) responder page (params { pUser = u, pEmail = e }) handle :: (String -> Bool) -> Method -> (String -> Params -> Web Response) -> Handler handle pathtest meth responder = - uriRest $ \uri -> let path' = uriPath uri - in if pathtest path' - then withData $ \params -> - [ withRequest $ \req -> if rqMethod req == meth - then responder path' params - else noHandle ] - else anyRequest noHandle + withRequest $ \req -> let uri = urlDecode $ rqUri req ++ rqQuery req + path' = uriPath uri + referer = case M.lookup (fromString "referer") (rqHeaders req) of + Just r -> if null (hValue r) + then Nothing + else Just $ toString $ head $ hValue r + _ -> Nothing + in if pathtest path' && rqMethod req == meth + then unServerPartT + (withData $ \params -> + [ anyRequest $ responder path' (params { pReferer = referer, pUri = uri }) ]) req + else noHandle -- | Returns path portion of URI, without initial /. -- Consecutive spaces are collapsed. We don't want to distinguish 'Hi There' and 'Hi There'. @@ -660,9 +675,9 @@ let since = pSince params `orIfNull` "1 month ago" let forUser = pForUser params hist <- gitLog since forUser [] - let filesFor files = intersperse (primHtmlChar "nbsp") $ map - (\file -> anchor ! [href $ urlForPage file ++ "?history"] << file) $ map - (\file -> if ".page" `isSuffixOf` file then dropExtension file else file) files + let filesFor files revis = intersperse (primHtmlChar "nbsp") $ map + (\file -> anchor ! [href $ urlForPage file ++ "?diff&from=" ++ revis ++ "^" ++ "&to=" ++ revis] << file) $ map + (\file -> if ".page" `isSuffixOf` file then dropExtension file else file) files let heading = h1 << ("Recent changes" ++ if null forUser then "" else (" by " ++ forUser)) let contents = ulist ! [theclass "history"] << map (\entry -> li << [thespan ! [theclass "date"] << logDate entry, stringToHtml " (", @@ -670,7 +685,7 @@ anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", logAuthor entry)]] << (logAuthor entry), stringToHtml "): ", thespan ! [theclass "subject"] << logSubject entry, stringToHtml " (", - thespan ! [theclass "files"] << filesFor (logFiles entry), + thespan ! [theclass "files"] << filesFor (logFiles entry) (logRevision entry), stringToHtml ")"]) hist formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Recent changes" }) page params (heading +++ contents) @@ -689,9 +704,10 @@ '+' -> thespan ! [theclass "added"] << [tail l, "\n"] '-' -> thespan ! [theclass "deleted"] << [tail l, "\n"] _ -> thespan << [tail l, "\n"] - let formattedDiff = thespan ! [theclass "detail"] << ("Changes from " ++ from) +++ + let formattedDiff = h2 ! [theclass "revision"] << ("Changes from " ++ from) +++ pre ! [theclass "diff"] << map diffLineToHtml (drop 5 $ lines rawDiff) - formattedPage defaultPageLayout page (params { pRevision = to }) formattedDiff + formattedPage (defaultPageLayout { pgTabs = DiffTab : pgTabs defaultPageLayout, pgSelectedTab = DiffTab }) + page (params { pRevision = to }) formattedDiff editPage :: String -> Params -> Web Response editPage page params = do @@ -712,11 +728,13 @@ [sha1Box, textarea ! [cols "80", name "editedText", identifier "editedText"] << contents, br, label << "Description of changes:", br, - textfield "logMsg" ! [size "76", value logMsg], + textfield "logMsg" ! [value logMsg], submit "update" "Save", primHtmlChar "nbsp", - submit "cancel" "Discard", br, + 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, + formattedPage (defaultPageLayout { pgShowPageTools = False, pgSelectedTab = EditTab, pgScripts = ["preview.js"], pgTitle = ("Editing " ++ page) }) page (params {pMessages = messages}) editForm confirmDelete :: String -> Params -> Web Response @@ -846,7 +864,7 @@ , pgSelectedTab :: Tab } -data Tab = ViewTab | EditTab | HistoryTab | DiscussTab deriving (Eq, Show) +data Tab = ViewTab | EditTab | HistoryTab | DiscussTab | DiffTab deriving (Eq, Show) defaultPageLayout :: PageLayout defaultPageLayout = PageLayout @@ -877,12 +895,15 @@ else li let origPage s = if ":discuss" `isSuffixOf` s then take (length s - 8) s else s let linkForTab HistoryTab = Just $ tabli HistoryTab << anchor ! [href $ urlForPage page ++ "?revision=" ++ revision ++ "&history"] << "history" + linkForTab DiffTab = Just $ tabli DiffTab << anchor ! [href ""] << "diff" linkForTab ViewTab = if isDiscussPage page then Just $ tabli DiscussTab << anchor ! [href $ urlForPage $ origPage page] << "page" else Just $ tabli ViewTab << anchor ! [href $ urlForPage page ++ if revision == "HEAD" then "" else "?revision=" ++ revision] << "view" linkForTab DiscussTab = if isDiscussPage page then Just $ tabli ViewTab << anchor ! [href $ urlForPage page] << "discuss" - else Just $ tabli DiscussTab << anchor ! [href $ urlForPage page ++ "?discuss"] << "discuss" + else if isPage page + then Just $ tabli DiscussTab << anchor ! [href $ urlForPage page ++ "?discuss"] << "discuss" + else Nothing linkForTab EditTab = if isPage page then Just $ tabli EditTab << anchor ! [href $ urlForPage page ++ "?edit&revision=" ++ revision ++ if revision == "HEAD" then "" else "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ revision)]] << @@ -898,43 +919,47 @@ else ulist ! [theclass "messages"] << map (li <<) messages templ <- liftIO $ readIORef template let filledTemp = T.render $ - setAttribute "pagetitle" pageTitle $ - setAttribute "javascripts" javascriptlinks $ - setAttribute "pagename" page $ + T.setAttribute "pagetitle" pageTitle $ + T.setAttribute "javascripts" javascriptlinks $ + T.setAttribute "pagename" page $ (case user of - Just u -> setAttribute "user" u + Just u -> T.setAttribute "user" u Nothing -> id) $ - (if isPage page then setAttribute "ispage" "true" else id) $ - (if pgShowPageTools layout then setAttribute "pagetools" "true" else id) $ - (if pPrintable params then setAttribute "printable" "true" else id) $ - (if pRevision params == "HEAD" then id else setAttribute "nothead" "true") $ - setAttribute "revision" revision $ - setAttribute "sha1" sha1 $ - setAttribute "searchbox" (renderHtmlFragment searchbox) $ - setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ - setAttribute "tabs" (renderHtmlFragment tabs) $ - setAttribute "messages" (renderHtmlFragment htmlMessages) $ - setAttribute "content" (renderHtmlFragment htmlContents) $ + (if isPage page then T.setAttribute "ispage" "true" else id) $ + (if pgShowPageTools layout then T.setAttribute "pagetools" "true" else id) $ + (if pPrintable params then T.setAttribute "printable" "true" else id) $ + (if pRevision params == "HEAD" then id else T.setAttribute "nothead" "true") $ + T.setAttribute "revision" revision $ + T.setAttribute "sha1" sha1 $ + T.setAttribute "searchbox" (renderHtmlFragment searchbox) $ + T.setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ + T.setAttribute "tabs" (renderHtmlFragment tabs) $ + T.setAttribute "messages" (renderHtmlFragment htmlMessages) $ + T.setAttribute "content" (renderHtmlFragment htmlContents) $ templ ok $ setContentType "text/html" $ toResponse filledTemp -- user authentication -loginForm :: Params -> Html -loginForm params = - let destination = pDestination params - in gui "" ! [identifier "loginForm"] << fieldset << - [ textfield "sha1" ! [thestyle "display: none", value destination] - , 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?" ++ urlEncodeVars [("destination", destination)])] << "click here to get one." ] +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 _ params = formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Login" }) "_login" params $ loginForm params +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 _ params = do +loginUser page params = do let uname = pUsername params let pword = pPassword params let destination = pDestination params @@ -944,27 +969,30 @@ if allowed then do key <- update $ NewSession (SessionData uname) - addCookie (3600) (mkCookie "sid" (show key)) - seeOther ("/" ++ substitute " " "%20" destination) $ toResponse $ p << ("Welcome, " ++ uname) + addCookie sessionTime (mkCookie "sid" (show key)) + addCookie 0 (mkCookie "destination" "") -- remove unneeded destination cookie + seeOther destination $ toResponse $ p << ("Welcome, " ++ uname) else - loginUserForm "_login" (params { pMessages = "Authentication failed." : pMessages params }) + loginUserForm' page (params { pMessages = "Authentication failed." : pMessages params }) logoutUser :: String -> Params -> Web Response logoutUser _ params = do let key = pSessionKey params - let destination = pDestination params + let destination = substitute " " "%20" $ fromMaybe "/" $ pReferer params case key of - Just k -> update $ DelSession k + Just k -> do + update $ DelSession k + addCookie 0 (mkCookie "sid" "") -- make cookie expire immediately, effectively deleting it Nothing -> return () - seeOther ("/" ++ substitute " " "%20" destination) $ toResponse $ p << "You have been logged out." + seeOther destination $ toResponse "You have been logged out." registerForm :: Web Html registerForm = do cfg <- query GetConfig let accessQ = case accessQuestion cfg of - Nothing -> noHtml - Just (prompt, _) -> label << prompt +++ br +++ - X.password "accessCode" ! [size "15"] +++ br + Nothing -> noHtml + Just (prompt, _) -> label << prompt +++ br +++ + X.password "accessCode" ! [size "15"] +++ br return $ gui "" ! [identifier "loginForm"] << fieldset << [ accessQ , label << "Username (at least 3 letters or digits):", br @@ -978,10 +1006,10 @@ , submit "register" "Register" ] registerUserForm :: String -> Params -> Web Response -registerUserForm _ params = do - let page = "_register" - regForm <- registerForm - formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) page params regForm +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 @@ -1012,7 +1040,7 @@ then do let passwordHash = showDigest $ sha512 $ L.fromString $ passwordSalt cfg ++ pword update $ AddUser uname (User { uUsername = uname, uPassword = passwordHash, uEmail = email }) - loginUser "/" (params { pUsername = uname, pPassword = pword }) + loginUser "/" (params { pUsername = uname, pPassword = pword, pEmail = email }) else formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) page (params { pMessages = errors }) regForm diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -38,15 +38,14 @@ that pandoc is compiled with support for it. First, make sure your system has the [pcre][] library installed. Then: - cabal install pandoc -fhighlighting - -You can skip this step if you don't care about highlighting support. + cabal update + cabal install -fhighlighting pandoc gitit -You can now install the latest release of gitit: +If you don't care about highlighting support, you can just do: - cabal update cabal install gitit +These commands 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: @@ -250,8 +249,8 @@ Reporting bugs ============== -There is no bug tracker as yet, so report bugs directly to the author, -jgm at berkeley . edu +Bugs may be reported (and feature requests filed) at +. Acknowledgements ================ diff --git a/css/screen.css b/css/screen.css --- a/css/screen.css +++ b/css/screen.css @@ -179,7 +179,7 @@ body a.noicon { background:none; padding:0; margin:0; } /* Make sure the icons are not cut */ -a[href^="http:"], a[href^="mailto:"], +a[href^="http:"], a[href^="https:"], a[href^="mailto:"], a[href$=".pdf"], a[href$=".doc"], a[href$=".xls"], a[href$=".rss"], a[href$=".rdf"], a[href^="aim:"] { padding:2px 22px 2px 0; @@ -190,6 +190,7 @@ /* External links */ a[href^="http:"] { background-image: url(../img/icons/external.png); padding-right: 14px; } +a[href^="https:"] { background-image: url(../img/icons/external.png); padding-right: 14px; } a[href^="mailto:"] { background-image: url(../img/icons/email.png); } /* Files */ @@ -362,6 +363,11 @@ #editform textarea { height: 25em; width: 98%; +} +#editform #logMsg { + width: 98%; + margin-right: 1em; + margin-bottom: 0.3em; } .added { background-color: yellow; } .deleted { text-decoration: line-through; color: gray; } diff --git a/data/template.html b/data/template.html --- a/data/template.html +++ b/data/template.html @@ -50,9 +50,9 @@
$if(user)$ - Logout $user$ + Logout $user$ $else$ - Login • Get an account + Login • Get an account $endif$
diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,5 +1,5 @@ name: gitit -version: 0.3.2 +version: 0.3.3 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc. @@ -19,6 +19,7 @@ license-file: LICENSE author: John MacFarlane maintainer: jgm@berkeley.edu +bug-reports: http://code.google.com/p/gitit/issues/list homepage: http://github.com/jgm/gitit/tree/master stability: experimental data-files: css/screen.css, css/print.css, css/ie.css, css/hk-pyg.css, diff --git a/js/preview.js b/js/preview.js --- a/js/preview.js +++ b/js/preview.js @@ -4,5 +4,6 @@ $("#previewpane").fadeIn(1000); }; $(document).ready(function(){ - $("#previewpane").before("Preview"); -}); + $("#previewButton").show(); + }); +