diff --git a/Network/Gitit.hs b/Network/Gitit.hs index 388b773ff..7d5953424 100644 --- a/Network/Gitit.hs +++ b/Network/Gitit.hs @@ -180,6 +180,7 @@ wikiHandlers = , dir "_feed" feedHandler , dir "_category" categoryPage , dir "_categories" categoryListPage + , dir "_users" userListPage , dir "_expire" expireCache , dir "_showraw" $ msum [ showRawPage diff --git a/Network/Gitit/Authentication.hs b/Network/Gitit/Authentication.hs index 522159000..33f24df2f 100644 --- a/Network/Gitit/Authentication.hs +++ b/Network/Gitit/Authentication.hs @@ -41,6 +41,7 @@ import Control.Monad.Trans (MonadIO(), liftIO) import System.Exit import System.Log.Logger (logM, Priority(..)) import Data.Char (isAlphaNum, isAlpha, isAscii) +import Data.Foldable (for_) import qualified Data.Map as M import Text.Pandoc.Shared (substitute) import Data.Maybe (isJust, fromJust, isNothing, fromMaybe) @@ -51,6 +52,7 @@ import Network.HTTP (urlEncodeVars, urlDecode, urlEncode) import Codec.Binary.UTF8.String (encodeString) import Data.ByteString.UTF8 (toString) import Network.Gitit.Rpxnow as R +import Data.Time.Clock (getCurrentTime) data ValidationType = Register | ResetPassword @@ -379,6 +381,9 @@ loginUser params = do cfg <- getConfig if allowed then do + now <- liftIO getCurrentTime + mbUser <- getUser uname + for_ mbUser $ \user -> adjustUser uname (user {uLastSeen = now}) key <- newSession (SessionData uname) addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key)) seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++ uname) diff --git a/Network/Gitit/Config.hs b/Network/Gitit/Config.hs index bdb63c170..d485f8184 100644 --- a/Network/Gitit/Config.hs +++ b/Network/Gitit/Config.hs @@ -110,6 +110,7 @@ extractConfig cp = do cfPandocUserData <- get cp "DEFAULT" "pandoc-user-data" cfXssSanitize <- get cp "DEFAULT" "xss-sanitize" cfRecentActivityDays <- get cp "DEFAULT" "recent-activity-days" + cfShowUserEmails <- get cp "DEFAULT" "show-user-emails" let (pt, lhs) = parsePageType cfDefaultPageType let markupHelpFile = show pt ++ if lhs then "+LHS" else "" markupHelpPath <- liftIO $ getDataFileName $ "data" > "markupHelp" > markupHelpFile @@ -204,6 +205,7 @@ extractConfig cp = do else Just cfPandocUserData , xssSanitize = cfXssSanitize , recentActivityDays = cfRecentActivityDays + , showUserEmails = cfShowUserEmails } case config' of Left (ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e' diff --git a/Network/Gitit/Framework.hs b/Network/Gitit/Framework.hs index 7c9cbc071..33674935c 100644 --- a/Network/Gitit/Framework.hs +++ b/Network/Gitit/Framework.hs @@ -132,7 +132,13 @@ getLoggedInUser = do mbUser <- getUser u case mbUser of Just user -> return $ Just user - Nothing -> return $ Just User{uUsername = u, uEmail = "", uPassword = undefined} + Nothing -> return $ Just User + { uUsername = u + , uEmail = "" + , uPassword = undefined + , uCreated = undefined + , uLastSeen = undefined + } pAuthorizationHeader :: GenParser Char st String pAuthorizationHeader = try pBasicHeader <|> pDigestHeader diff --git a/Network/Gitit/Handlers.hs b/Network/Gitit/Handlers.hs index 1f0ec23eb..2d206e27f 100644 --- a/Network/Gitit/Handlers.hs +++ b/Network/Gitit/Handlers.hs @@ -34,6 +34,7 @@ module Network.Gitit.Handlers ( , indexPage , categoryPage , categoryListPage + , userListPage , preview , showRawPage , showFileAsText @@ -56,6 +57,7 @@ import Safe import Network.Gitit.Server import Network.Gitit.Framework import Network.Gitit.Layout +import Network.Gitit.State (queryGititState) import Network.Gitit.Types import Network.Gitit.Feed (filestoreToXmlFeed, FeedConfig(..)) import Network.Gitit.Util (orIfNull) @@ -73,15 +75,21 @@ import Data.List (intercalate, intersperse, delete, nub, sortBy, find, isPrefixO import Data.List.Split (wordsBy) import Data.Maybe (fromMaybe, mapMaybe, isJust, catMaybes) import Data.Ord (comparing) -import Data.Char (toLower, isSpace) +import Data.Char (toLower, isSpace, ord) +import Numeric (showHex) import Control.Monad.Reader import qualified Data.ByteString.Lazy as B import qualified Data.ByteString as S +import Network.URL (encString) +import Network.URI (isUnescapedInURI) import Network.HTTP (urlEncodeVars) -import Data.Time (getCurrentTime, addUTCTime) +import Data.Time (getCurrentTime, addUTCTime, fromGregorian, + secondsToDiffTime, formatTime) import Data.Time.Clock (diffUTCTime, UTCTime(..)) +import System.Locale (defaultTimeLocale) import Data.FileStore import System.Log.Logger (logM, Priority(..)) +import Data.Map (elems) handleAny :: Handler handleAny = uriRest $ \uri -> @@ -766,6 +774,73 @@ categoryListPage = do pgScripts = ["search.js"], pgTitle = "Categories" } htmlMatches +userListPage :: Handler +userListPage = do + base' <- getWikiBase + fs <- getFileStore + cfg <- getConfig + hist <- liftIO $ history fs [] (TimeRange Nothing Nothing) Nothing + let uEdits u = length $ + filter (\r -> authorName (revAuthor r) == (uUsername u)) hist + let compareUsers u u' = compare + (uLastSeen u', uEdits u', map toLower $ uUsername u) + (uLastSeen u, uEdits u, map toLower $ uUsername u') + users' <- fmap (sortBy compareUsers . elems) (queryGititState users) + let activityLink u = anchor ! [href $ concat + [ base' + , "/_activity?" + , urlEncodeVars [("forUser", (uUsername u))] + ]] + let userHtml u = tr << do + let username = td ! [theclass "username"] << activityLink u << + uUsername u + let email = if not (showUserEmails cfg) then noHtml else do + let email' = uEmail u + let url = "mailto:" ++ encString False isUnescapedInURI email' + let href' = htmlAttr "href" (primHtml (obfuscateString url)) + let text' = primHtml $ obfuscateString $ take 10 email' ++ + if length email' < 11 then "" else "..." + let link' = if null email' then noHtml else anchor ! [href'] << + text' + td ! [theclass "email"] << link' + let edits = td ! [theclass "edits"] << show (uEdits u) + let created = td ! [theclass "created"] << if uCreated u == epoch + then stringToHtml "unknown" + else showTime (uCreated u) + let lastSeen = td ! [theclass "lastseen"] << if uLastSeen u == epoch + then stringToHtml "never" + else showTime (uLastSeen u) + trĀ << [username, email, edits, lastSeen, created] + let headrow = tr << + [ th ! [theclass "username"] << "User" + , if showUserEmails cfg + then th ! [theclass "email"] << "Email" + else noHtml + , th ! [theclass "edits"] << "Edits" + , th ! [theclass "lastseen"] << "Last seen" + , th ! [theclass "created"] << "Joined" + ] + let html = thediv ! [identifier "userList"] << table << + (thead headrow +++ tbody << map userHtml users') + formattedPage defaultPageLayout{ + pgPageName = "Users", + pgShowPageTools = False, + pgTabs = [], + pgTitle = "Users" } html + where + epoch = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0) + obfuscateChar char = do + let num = ord char + let numstr = if even num then show num else "x" ++ showHex num "" + "" ++ numstr ++ ";" + obfuscateString = concatMap obfuscateChar . fromEntities + +showTime :: UTCTime -> Html +showTime then_ = do + let full = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" then_ + let text' = formatTime defaultTimeLocale "%H:%M, %e %B %Y" then_ + tag "time" ! [strAttr "datetime" full] << text' + expireCache :: Handler expireCache = do page <- getPage diff --git a/Network/Gitit/State.hs b/Network/Gitit/State.hs index 8018afb5b..ac2980879 100644 --- a/Network/Gitit/State.hs +++ b/Network/Gitit/State.hs @@ -32,6 +32,7 @@ import Data.FileStore import Data.List (intercalate) import System.Log.Logger (Priority(..), logM) import Network.Gitit.Types +import Data.Time.Clock (getCurrentTime) gititstate :: IORef GititState gititstate = unsafePerformIO $ newIORef GititState { sessions = undefined @@ -55,10 +56,13 @@ mkUser :: String -- username -> IO User mkUser uname email pass = do salt <- genSalt + now <- getCurrentTime return User { uUsername = uname, uPassword = Password { pSalt = salt, pHashed = hashPassword salt pass }, - uEmail = email } + uEmail = email, + uCreated = now, + uLastSeen = now} genSalt :: IO String genSalt = replicateM 32 $ randomRIO ('0','z') diff --git a/Network/Gitit/Types.hs b/Network/Gitit/Types.hs index b1862cf94..8319e5842 100644 --- a/Network/Gitit/Types.hs +++ b/Network/Gitit/Types.hs @@ -25,7 +25,7 @@ module Network.Gitit.Types where import Control.Monad.Reader (ReaderT, runReaderT, mplus) import Control.Monad.State (StateT, runStateT, get, modify) -import Control.Monad (liftM) +import Control.Monad (liftM, msum) import System.Log.Logger (Priority(..)) import Text.Pandoc.Definition (Pandoc) import Text.XHtml (Html) @@ -37,6 +37,8 @@ import Data.FileStore.Types import Network.Gitit.Server import Text.HTML.TagSoup.Entity (lookupEntity) import Data.Char (isSpace) +import Text.Read hiding (get, look) +import Data.Time (UTCTime (UTCTime), fromGregorian, secondsToDiffTime) data PageType = Markdown | RST | LaTeX | HTML | Textile | Org | DocBook deriving (Read, Show, Eq) @@ -149,7 +151,9 @@ data Config = Config { -- | Filter HTML through xss-sanitize xssSanitize :: Bool, -- | The default number of days in the past to look for \"recent\" activity - recentActivityDays :: Int + recentActivityDays :: Int, + -- | Show email addresses in user list page + showUserEmails :: Bool } -- | Data for rendering a wiki page. @@ -180,8 +184,46 @@ data Password = Password { pSalt :: String, pHashed :: String } data User = User { uUsername :: String, uPassword :: Password, - uEmail :: String -} deriving (Show,Read) + uEmail :: String, + uCreated :: UTCTime, + uLastSeen :: UTCTime +} deriving (Show) + +instance Read User where + readPrec = parens $ prec 11 $ do + Ident "User" <- lexP + Punc "{" <- lexP + Ident "uUsername" <- lexP + Punc "=" <- lexP + username <- readPrec + Punc "," <- lexP + Ident "uPassword" <- lexP + Punc "=" <- lexP + password <- readPrec + Punc "," <- lexP + Ident "uEmail" <- lexP + Punc "=" <- lexP + email <- readPrec + (created, lastSeen) <- msum + [ do + Punc "," <- lexP + Ident "uCreated" <- lexP + Punc "=" <- lexP + created <- readPrec + Punc "," <- lexP + Ident "uLastSeen" <- lexP + Punc "=" <- lexP + lastSeen <- readPrec + Punc "}" <- lexP + return (created, lastSeen) + , do + Punc "}" <- lexP + let t = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0) + return (t, t) + ] + return (User username password email created lastSeen) + readList = readListDefault + readListPrec = readListPrecDefault -- | Common state for all gitit wikis in an application. data GititState = GititState { diff --git a/data/default.conf b/data/default.conf index b4d574caa..704c3eda8 100644 --- a/data/default.conf +++ b/data/default.conf @@ -275,3 +275,7 @@ recent-activity-days: 30 # if the activity page receives no 'since' parameter specifiying the time # thereafter which to show the changes, it will by default show "recent" # changes. This allows you to specify how recent "recent" means, in days. + +show-user-emails: no +# if yes, user email addresses will be shown on the user list page at /_users. +# The default is not to show them. diff --git a/data/templates/sitenav.st b/data/templates/sitenav.st index 863be4f33..b8718ecba 100644 --- a/data/templates/sitenav.st +++ b/data/templates/sitenav.st @@ -7,6 +7,7 @@