Refactor Git log view into separate modules and Widgets

This commit is contained in:
fr33domlover 2016-05-06 10:29:02 +00:00
parent d1d49170e0
commit 07b627eb9c
11 changed files with 211 additions and 52 deletions

View file

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

View file

@ -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
let path =
root </> unpack sharer </> unpack repo
mdt <- lastChange path
ago <- case mdt of
Nothing -> return "never"
Just dt -> timeAgo dt
return (sharer, mproj, repo, ago)
liftIO $ forM repos $
\ (Value sharer, Value mproj, Value repo, Value vcs) -> do
ago <- case vcs of
VCSDarcs -> return "[Not implemented yet]"
VCSGit -> do
let path =
root </> unpack sharer </> unpack repo
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")

View file

@ -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
oid <- resolveName git $ 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
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")
(branches, tags, mentries) <- liftIO $ G.readChangesView path ref
case mentries of
Nothing -> notFound
Just entries ->
let refSelect = refSelectW shar repo branches tags
changes = changesW entries
in defaultLayout $(widgetFile "repo/changes-git")
getRepoChangesR :: Text -> Text -> Text -> Handler Html
getRepoChangesR shar repo ref = do

37
src/Vervis/Widget/Repo.hs Normal file
View file

@ -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")

View file

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

View file

@ -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

View file

@ -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>
<tr>
<th>Author
<th>Hash
<th>Message
<th>Time
$forall (author, hash, message, time) <- rows
<tr>
<td>#{author}
<td>#{hash}
<td>#{message}
<td>#{time}
^{refSelect}
^{changes}

View file

@ -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

View file

@ -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}

View file

@ -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}

View file

@ -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