Added user list page at _users

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

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)

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'

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

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

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')

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 {

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.

data/templates/sitenav.st

@@ -7,6 +7,7 @@
       <li><a href="$base$/_categories">Categories</a></li>
       <li><a href="$base$/_random">Random page</a></li>
       <li><a href="$base$/_activity">Recent activity</a></li>
+      <li><a href="$base$/_users">Users</a></li>
       $if(wikiupload)$
         <li><a href="$base$/_upload">Upload a file</a></li>
       $endif$