Refactor Git log view into separate modules and Widgets
This commit is contained in:
parent
d1d49170e0
commit
07b627eb9c
11 changed files with 211 additions and 52 deletions
|
@ -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)
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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
37
src/Vervis/Widget/Repo.hs
Normal 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")
|
|
@ -21,7 +21,7 @@ $nothing
|
|||
You are not logged in.
|
||||
<a href=@{AuthR LoginR}>Log in.
|
||||
|
||||
^{breadcrumbBar}
|
||||
^{breadcrumbsW}
|
||||
|
||||
$maybe msg <- mmsg
|
||||
<div #message>#{msg}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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}
|
||||
|
|
17
templates/repo/widget/changes.cassius
Normal file
17
templates/repo/widget/changes.cassius
Normal 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
|
26
templates/repo/widget/changes.hamlet
Normal file
26
templates/repo/widget/changes.hamlet
Normal 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}
|
27
templates/repo/widget/ref-select.hamlet
Normal file
27
templates/repo/widget/ref-select.hamlet
Normal 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}
|
11
vervis.cabal
11
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
|
||||
|
|
Loading…
Reference in a new issue