Refactor Git log view into separate modules and Widgets

src/Vervis/Git.hs

@@ -15,6 +15,7 @@
 
 module Vervis.Git
     ( readSourceView
+    , readChangesView
     )
 where
 
@@ -22,18 +23,32 @@ import Prelude
 
 import Data.Foldable (find)
 import Data.Git
+import Data.Git.Graph
 import Data.Git.Harder
+import Data.Git.Ref (toHex)
 import Data.Git.Storage (getObject_)
 import Data.Git.Storage.Object (Object (..))
+import Data.Git.Types (GitTime (..))
+import Data.Graph.Inductive.Graph (noNodes)
+import Data.Graph.Inductive.Query.Topsort
 import Data.Set (Set)
 import Data.String (fromString)
-import Data.Text (Text, unpack, pack)
+import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
+import System.Hourglass (timeCurrent)
+import Time.Types (Elapsed (..))
 
 import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.DList as D (DList, empty, snoc, toList)
 import qualified Data.Set as S (member, mapMonotonic)
+import qualified Data.Text as T (pack, unpack)
+import qualified Data.Text.Encoding as TE (decodeUtf8With)
+import qualified Data.Text.Encoding.Error as TE (lenientDecode)
 
+import Data.ByteString.Char8.Local (takeLine)
+import Data.EventTime.Local
 import Data.Git.Local
+import Vervis.Changes
 import Vervis.Foundation (Widget)
 import Vervis.Readme
 import Vervis.SourceTree
@@ -69,7 +84,7 @@ loadSourceView
 loadSourceView git refT dir = do
     branches <- branchList git
     tags <- tagList git
-    let refS = unpack refT
+    let refS = T.unpack refT
         refN = RefName refS
     msv <- if refN `S.member` branches || refN `S.member` tags
         then do
@@ -108,5 +123,46 @@ readSourceView
 readSourceView path ref dir = do
     (bs, ts, msv) <-
         withRepo (fromString path) $ \ git -> loadSourceView git ref dir
-    let toTexts = S.mapMonotonic $ pack . refNameRaw
+    let toTexts = S.mapMonotonic $ T.pack . refNameRaw
     return (toTexts bs, toTexts ts, renderSources dir <$> msv)
+
+instance ResultList D.DList where
+    emptyList = D.empty
+    appendItem = flip D.snoc
+
+readChangesView
+    :: FilePath
+    -- ^ Repository path
+    -> Text
+    -- ^ Name of branch or tag
+    -> IO (Set Text, Set Text, Maybe [LogEntry])
+    -- ^ Branches, tags, view of selected ref's change log
+readChangesView path ref = withRepo (fromString path) $ \ git -> do
+    let toTexts = S.mapMonotonic $ T.pack . refNameRaw
+    branches <- toTexts <$> branchList git
+    tags <- toTexts <$> tagList git
+    ml <- if ref `S.member` branches || ref `S.member` tags
+        then do
+            oid <- resolveName git $ T.unpack ref
+            graph <- loadCommitGraphPT git [oid]
+            let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
+                nodes = case mnodes of
+                    Nothing -> error "commit graph contains a cycle"
+                    Just ns -> ns
+                pairs = D.toList $ fmap (nodeLabel graph) nodes
+                toText = TE.decodeUtf8With TE.lenientDecode
+            Elapsed now <- timeCurrent
+            let mkrow oid commit = LogEntry
+                    { leAuthor  = toText $ personName $ commitAuthor commit
+                    , leHash    = toText $ toHex $ unObjId oid
+                    , leMessage = toText $ takeLine $ commitMessage commit
+                    , leTime    =
+                        intervalToEventTime $
+                        FriendlyConvert $
+                        now - t
+                    }
+                    where
+                    Elapsed t = gitTimeUTC $ personTime $ commitAuthor commit
+            return $ Just $ map (uncurry mkrow) pairs
+        else return Nothing
+    return (branches, tags, ml)

src/Vervis/Handler/Home.hs

@@ -25,6 +25,7 @@ import Vervis.GitOld
 
 import qualified Database.Esqueleto as E ((==.))
 
+import Vervis.Model.Repo
 import Vervis.Path
 
 intro :: Handler Html
@@ -43,16 +44,21 @@ intro = do
                     ( sharer ^. SharerIdent
                     , project ?. ProjectIdent
                     , repo ^. RepoIdent
+                    , repo ^. RepoVcs
                     )
         root <- askRepoRootDir
-        liftIO $ forM repos $ \ (Value sharer, Value mproj, Value repo) -> do
+        liftIO $ forM repos $
-            let path =
+            \ (Value sharer, Value mproj, Value repo, Value vcs) -> do
-                    root </> unpack sharer </> unpack repo
+                ago <- case vcs of
-            mdt <- lastChange path
+                    VCSDarcs -> return "[Not implemented yet]"
-            ago <- case mdt of
+                    VCSGit -> do
-                Nothing -> return "never"
+                        let path =
-                Just dt -> timeAgo dt
+                                root </> unpack sharer </> unpack repo
-            return (sharer, mproj, repo, ago)
+                        mdt <- lastChange path
+                        case mdt of
+                            Nothing -> return "never"
+                            Just dt -> timeAgo dt
+                return (sharer, mproj, repo, vcs, ago)
     defaultLayout $ do
         setTitle "Welcome to Vervis!"
         $(widgetFile "homepage")

src/Vervis/Handler/Repo.hs

@@ -77,12 +77,13 @@ import Vervis.Render
 import Vervis.Settings
 import Vervis.SourceTree
 import Vervis.Style
+import Vervis.Widget.Repo
 
 import qualified Darcs.Local as D (createRepo)
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.Git.Local as G (createRepo)
 import qualified Vervis.Darcs as D (readSourceView)
-import qualified Vervis.Git as G (readSourceView)
+import qualified Vervis.Git as G (readSourceView, readChangesView)
 
 getReposR :: Text -> Handler Html
 getReposR user = do
@@ -130,10 +131,6 @@ getRepoNewR user = do
         setTitle $ toHtml $ mconcat ["Vervis > People > ", user, " > New Repo"]
         $(widgetFile "repo/repo-new")
 
-instance ResultList D.DList where
-    emptyList = D.empty
-    appendItem = flip D.snoc
-
 selectRepo :: Text -> Text -> AppDB Repo
 selectRepo shar repo = do
     Entity sid _s <- getBy404 $ UniqueSharerIdent shar
@@ -206,27 +203,13 @@ getDarcsRepoChanges shar repo tag = notFound
 getGitRepoChanges :: Text -> Text -> Text -> Handler Html
 getGitRepoChanges shar repo ref = do
     path <- askRepoDir shar repo
-    pairs <- liftIO $ withRepo (fromString path) $ \ git -> do
+    (branches, tags, mentries) <- liftIO $ G.readChangesView path ref
-        oid <- resolveName git $ unpack ref
+    case mentries of
-        graph <- loadCommitGraphPT git [oid]
+        Nothing -> notFound
-        let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
+        Just entries ->
-            nodes = case mnodes of
+            let refSelect = refSelectW shar repo branches tags
-                Nothing -> error "commit graph contains a cycle"
+                changes = changesW entries
-                Just ns -> ns
+            in  defaultLayout $(widgetFile "repo/changes-git")
-        return $ D.toList $ fmap (nodeLabel graph) nodes
-    now <- liftIO dateCurrent
-    let toText = decodeUtf8With lenientDecode
-        mkrow oid commit =
-            ( toText $ personName $ commitAuthor commit
-            , toText $ toHex $ unObjId oid
-            , toText $ takeLine $ commitMessage commit
-            , timeAgo' now (timeConvert $ personTime $ commitAuthor commit)
-            )
-        rows = map (uncurry mkrow) pairs
-    defaultLayout $ do
-        setTitle $ toHtml $ intercalate " > "
-            ["Vervis", "People", shar, "Repos", repo, "Commits"]
-        $(widgetFile "repo/changes-git")
 
 getRepoChangesR :: Text -> Text -> Text -> Handler Html
 getRepoChangesR shar repo ref = do

src/Vervis/Widget/Repo.hs

@@ -0,0 +1,37 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Widget.Repo
+    ( refSelectW
+    , changesW
+    )
+where
+
+import Prelude
+
+import Data.Set (Set)
+import Data.Text (Text)
+
+import qualified Data.Text as T (take)
+
+import Vervis.Changes
+import Vervis.Foundation
+import Vervis.Settings (widgetFile)
+
+refSelectW :: Text -> Text -> Set Text -> Set Text -> Widget
+refSelectW shar repo branches tags = $(widgetFile "repo/widget/ref-select")
+
+changesW :: Foldable f => f LogEntry -> Widget
+changesW entries = $(widgetFile "repo/widget/changes")

templates/default-layout.hamlet

@@ -21,7 +21,7 @@ $nothing
     You are not logged in.
     <a href=@{AuthR LoginR}>Log in.
 
-^{breadcrumbBar}
+^{breadcrumbsW}
 
 $maybe msg <- mmsg
   <div #message>#{msg}

templates/homepage.hamlet

@@ -27,8 +27,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Sharer
     <th>Project
     <th>Repo
+    <th>VCS
     <th>Last change
-  $forall (sharer, mproj, repo, ago) <- rows
+  $forall (sharer, mproj, repo, vcs, ago) <- rows
     <tr>
       <td>
         <a href=@{PersonR sharer}>#{sharer}
@@ -39,6 +40,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
           (none)
       <td>
         <a href=@{RepoR sharer repo}>#{repo}
+      <td>
+        $case vcs
+          $of VCSDarcs
+            Darcs
+          $of VCSGit
+            Git
       <td>#{ago}
 
 <h2>People

templates/repo/changes-git.hamlet

@@ -12,15 +12,6 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<table>
+^{refSelect}
-  <tr>
+
-    <th>Author
+^{changes}
-    <th>Hash
-    <th>Message
-    <th>Time
-  $forall (author, hash, message, time) <- rows
-    <tr>
-      <td>#{author}
-      <td>#{hash}
-      <td>#{message}
-      <td>#{time}

templates/repo/widget/changes.cassius

@@ -0,0 +1,17 @@
+/* This file is part of Vervis.
+ *
+ * Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ *
+ * ♡ Copying is an act of love. Please copy, reuse and share.
+ *
+ * The author(s) have dedicated all copyright and related and neighboring
+ * rights to this software to the public domain worldwide. This software is
+ * distributed without any warranty.
+ *
+ * You should have received a copy of the CC0 Public Domain Dedication along
+ * with this software. If not, see
+ * <http://creativecommons.org/publicdomain/zero/1.0/>.
+ */
+
+.hash
+    font-family: monospace

templates/repo/widget/changes.hamlet

@@ -0,0 +1,26 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<table>
+  <tr>
+    <th>Author
+    <th>Hash
+    <th>Message
+    <th>Time
+  $forall LogEntry author hash message time <- entries
+    <tr>
+      <td>#{author}
+      <td class="hash">#{T.take 10 hash}
+      <td>#{message}
+      <td>#{time}

templates/repo/widget/ref-select.hamlet

@@ -0,0 +1,27 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<h2>Branches
+
+<ul>
+$forall branch <- branches
+  <li>
+    <a href=@{RepoSourceR shar repo [branch]}>#{branch}
+
+<h2>Tags
+
+<ul>
+$forall tag <- tags
+  <li>
+    <a href=@{RepoSourceR shar repo [tag]}>#{tag}

vervis.cabal

@@ -43,8 +43,11 @@ library
                        Data.Git.Local
                        Data.Hourglass.Local
                        Data.List.Local
+                       Data.Text.UTF8.Local
+                       Data.Text.Lazy.UTF8.Local
                        Network.SSH.Local
                        Text.FilePath.Local
+                       Text.Jasmine.Local
                        Vervis.Application
                        Vervis.BinaryBody
                        Vervis.Changes
@@ -85,6 +88,7 @@ library
                        Vervis.Ssh
                        Vervis.Style
                        Vervis.Widget
+                       Vervis.Widget.Repo
   -- other-modules:       
   default-extensions:  TemplateHaskell
                        QuasiQuotes
@@ -103,12 +107,15 @@ library
                        TupleSections
                        RecordWildCards
   build-depends:       aeson
+                       -- for parsing commands sent over SSH
                      , attoparsec
                      , base
                      , base64-bytestring
                        -- for Data.Binary.Local
                      , binary
                      , blaze-html
+                       -- for Data.EventTime.Local
+                     , blaze-markup
                      , byteable
                      , bytestring
                      , case-insensitive
@@ -139,7 +146,9 @@ library
                      , hit-graph >= 0.1
                      , hit-harder >= 0.1
                      , hit-network >= 0.1
-                     , hjsmin
+                     -- currently discarding all JS so no need for minifier
+                     --, hjsmin
+                     -- 'hit' uses it for 'GitTime'
                      , hourglass
                      , http-conduit
                      , http-types