Minimal pagination for git and darcs change log

This commit is contained in:
fr33domlover 2016-05-13 08:49:19 +00:00
parent 17c4ff3d23
commit b2f5b20184
12 changed files with 223 additions and 77 deletions

View file

@ -0,0 +1,52 @@
{- 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 Control.Applicative.Local
( atMost
, atMost_
, upTo
, upTo_
)
where
import Prelude
import Control.Applicative
-- | Apply action between zero and @n@ times, inclusive, and list the results.
atMost :: Alternative f => Int -> f a -> f [a]
atMost n action = go n
where
go n =
if n <= 0
then pure []
else liftA2 (:) action (go $ n - 1) <|> pure []
-- | Apply action between zero and @n@ times, inclusive, and discard results.
atMost_ :: Alternative f => Int -> f a -> f ()
atMost_ n action = go n
where
go n =
if n <= 0
then pure ()
else action *> (go $ n - 1) <|> pure ()
-- | Apply action between one and @n@ times, inclusive, and list the results.
upTo :: Alternative f => Int -> f a -> f [a]
upTo n action = liftA2 (:) action $ atMost n action
-- | Apply action between one and @n@ times, inclusive, and discard results.
upTo_ :: Alternative f => Int -> f a -> f ()
upTo_ n action = action *> atMost_ n action

View file

@ -21,7 +21,9 @@
-- make sure it's exactly the right content, we use ByteString first and then -- make sure it's exactly the right content, we use ByteString first and then
-- later decode to Text. -- later decode to Text.
module Darcs.Local.PatchInfo.Parser module Darcs.Local.PatchInfo.Parser
( readPatchInfo ( readPatchInfoCount
, readPatchInfoAll
, readPatchInfoPage
) )
where where
@ -43,6 +45,7 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Char8 as BC
import qualified Storage.Hashed.Hash as H import qualified Storage.Hashed.Hash as H
import Control.Applicative.Local
import Darcs.Local.PatchInfo.Types import Darcs.Local.PatchInfo.Types
import Data.Attoparsec.ByteString.Local import Data.Attoparsec.ByteString.Local
import Data.ByteString.Local (stripPrefix) import Data.ByteString.Local (stripPrefix)
@ -239,8 +242,18 @@ patchInfosOffsetP off = do
patchInfosLimitP :: Int -> Parser PatchSeq patchInfosLimitP :: Int -> Parser PatchSeq
patchInfosLimitP lim = do patchInfosLimitP lim = do
(psize, phash) <- pristineP (psize, phash) <- pristineP
ps <- replicateM lim $ word8 lf >> patchInfoP ps <- atMost lim $ word8 lf >> patchInfoP
word8 lf return PatchSeq
{ psPristineHash = phash
, psPristineSize = psize
, psPatches = ps
}
patchInfosOffsetLimitP :: Int -> Int -> Parser PatchSeq
patchInfosOffsetLimitP off lim = do
(psize, phash) <- pristineP
replicateM_ off $ word8 lf >> skipPatchP
ps <- atMost lim $ word8 lf >> patchInfoP
return PatchSeq return PatchSeq
{ psPristineHash = phash { psPristineHash = phash
, psPristineSize = psize , psPristineSize = psize
@ -253,7 +266,17 @@ darcsDir = "_darcs"
inventoryFile :: FilePath inventoryFile :: FilePath
inventoryFile = "hashed_inventory" inventoryFile = "hashed_inventory"
readPatchInfo :: FilePath -> IO (Either String PatchSeq) readPatchInfoCount :: FilePath -> IO (Either String Int)
readPatchInfo repoPath = do readPatchInfoCount repoPath = do
let invPath = repoPath </> darcsDir </> inventoryFile
parseFileIncremental invPath $ patchInfosCountP <* endOfInput
readPatchInfoAll :: FilePath -> IO (Either String PatchSeq)
readPatchInfoAll repoPath = do
let invPath = repoPath </> darcsDir </> inventoryFile let invPath = repoPath </> darcsDir </> inventoryFile
parseFileIncremental invPath $ patchInfosAllP <* endOfInput parseFileIncremental invPath $ patchInfosAllP <* endOfInput
readPatchInfoPage :: Int -> Int -> FilePath -> IO (Either String PatchSeq)
readPatchInfoPage off lim repoPath = do
let invPath = repoPath </> darcsDir </> inventoryFile
parseFileIncremental invPath $ patchInfosOffsetLimitP off lim

30
src/Data/Either/Local.hs Normal file
View file

@ -0,0 +1,30 @@
{- 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 Data.Either.Local
( maybeRight
, maybeLeft
)
where
import Prelude
maybeRight :: Either a b -> Maybe b
maybeRight (Left _) = Nothing
maybeRight (Right b) = Just b
maybeLeft :: Either a b -> Maybe a
maybeLeft (Left a) = Just a
maybeLeft (Right _) = Nothing

View file

@ -21,6 +21,9 @@ module Data.Git.Local
, TreeRows , TreeRows
, PathView (..) , PathView (..)
, viewPath , viewPath
-- * View refs
, listBranches
, listTags
) )
where where
@ -31,6 +34,7 @@ import Data.Byteable (toBytes)
import Data.Git import Data.Git
import Data.Git.Harder import Data.Git.Harder
import Data.Git.Types (GitTime (..)) import Data.Git.Types (GitTime (..))
import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
@ -38,6 +42,8 @@ import System.Directory.Tree
import qualified Data.ByteString as B (ByteString, writeFile) import qualified Data.ByteString as B (ByteString, writeFile)
import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Set as S (mapMonotonic)
import qualified Data.Text as T (pack)
import Data.EventTime.Local import Data.EventTime.Local
import Data.Hourglass.Local () import Data.Hourglass.Local ()
@ -115,3 +121,9 @@ viewPath git root path = do
case target of case target of
Left blob -> return $ BlobView nameT oid (blobGetContent blob) Left blob -> return $ BlobView nameT oid (blobGetContent blob)
Right tree -> TreeView nameT oid <$> mkRows tree Right tree -> TreeView nameT oid <$> mkRows tree
listBranches :: Git -> IO (Set Text)
listBranches git = S.mapMonotonic (T.pack . refNameRaw) <$> branchList git
listTags :: Git -> IO (Set Text)
listTags git = S.mapMonotonic (T.pack . refNameRaw) <$> tagList git

View file

@ -156,4 +156,6 @@ paginate ps ns = do
curr <- psCurrent ps curr <- psCurrent ps
let (offset, limit) = subseq (psPer ps) curr let (offset, limit) = subseq (psPer ps) curr
(total, items) <- psSelect ps offset limit (total, items) <- psSelect ps offset limit
return (items, navModel ns curr total) let (d, m) = total `divMod` psPer ps
pages = if m == 0 then d else d + 1
return (items, navModel ns curr pages)

View file

@ -21,6 +21,8 @@ where
import Prelude import Prelude
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (strictDecode) import Data.Text.Encoding.Error (strictDecode)
@ -39,6 +41,7 @@ import qualified Data.Text as T (takeWhile, stripEnd)
import Darcs.Local.PatchInfo.Parser import Darcs.Local.PatchInfo.Parser
import Darcs.Local.PatchInfo.Types import Darcs.Local.PatchInfo.Types
import Darcs.Local.Repository import Darcs.Local.Repository
import Data.Either.Local (maybeRight)
import Data.EventTime.Local import Data.EventTime.Local
import Data.Text.UTF8.Local (decodeStrict) import Data.Text.UTF8.Local (decodeStrict)
import Data.Time.Clock.Local () import Data.Time.Clock.Local ()
@ -115,14 +118,17 @@ readSourceView path dir = do
readChangesView readChangesView
:: FilePath :: FilePath
-- ^ Repository path -- ^ Repository path
-> IO (Maybe [LogEntry]) -> Int
-- ^ View of change log -- ^ Offset, i.e. latest patches to skip
readChangesView path = do -> Int
eps <- readPatchInfo path -- ^ Limit, i.e. how many latest patches to take after the offset
case eps of -> IO (Maybe (Int, [LogEntry]))
Left _err -> return Nothing -- ^ Total number of changes, and view of the chosen subset
Right ps -> do readChangesView path off lim = fmap maybeRight $ runExceptT $ do
now <- getCurrentTime total <- ExceptT $ readPatchInfoCount path
let off' = total - off - lim
ps <- ExceptT $ readPatchInfoPage off' lim path
now <- lift getCurrentTime
let toLE pi h = LogEntry let toLE pi h = LogEntry
{ leAuthor = { leAuthor =
T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi
@ -133,4 +139,4 @@ readChangesView path = do
FriendlyConvert $ FriendlyConvert $
now `diffUTCTime` piTime pi now `diffUTCTime` piTime pi
} }
return $ Just $ map (uncurry toLE) $ reverse $ psPatches ps return (total, map (uncurry toLE) $ reverse $ psPatches ps)

View file

@ -16,6 +16,7 @@
module Vervis.Git module Vervis.Git
( readSourceView ( readSourceView
, readChangesView , readChangesView
, listRefs
) )
where where
@ -135,14 +136,13 @@ readChangesView
-- ^ Repository path -- ^ Repository path
-> Text -> Text
-- ^ Name of branch or tag -- ^ Name of branch or tag
-> IO (Set Text, Set Text, Maybe [LogEntry]) -> Int
-- ^ Branches, tags, view of selected ref's change log -- ^ Offset, i.e. latest commits to skip
readChangesView path ref = withRepo (fromString path) $ \ git -> do -> Int
let toTexts = S.mapMonotonic $ T.pack . refNameRaw -- ^ Limit, i.e. how many latest commits to take after the offset
branches <- toTexts <$> branchList git -> IO (Int, [LogEntry])
tags <- toTexts <$> tagList git -- ^ Total number of ref's changes, and view of selected ref's change log
ml <- if ref `S.member` branches || ref `S.member` tags readChangesView path ref off lim = withRepo (fromString path) $ \ git -> do
then do
oid <- resolveName git $ T.unpack ref oid <- resolveName git $ T.unpack ref
graph <- loadCommitGraphPT git [oid] graph <- loadCommitGraphPT git [oid]
let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph]) let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
@ -150,6 +150,7 @@ readChangesView path ref = withRepo (fromString path) $ \ git -> do
Nothing -> error "commit graph contains a cycle" Nothing -> error "commit graph contains a cycle"
Just ns -> ns Just ns -> ns
pairs = D.toList $ fmap (nodeLabel graph) nodes pairs = D.toList $ fmap (nodeLabel graph) nodes
pairs' = take lim $ drop off pairs
toText = TE.decodeUtf8With TE.lenientDecode toText = TE.decodeUtf8With TE.lenientDecode
Elapsed now <- timeCurrent Elapsed now <- timeCurrent
let mkrow oid commit = LogEntry let mkrow oid commit = LogEntry
@ -163,6 +164,8 @@ readChangesView path ref = withRepo (fromString path) $ \ git -> do
} }
where where
Elapsed t = gitTimeUTC $ personTime $ commitAuthor commit Elapsed t = gitTimeUTC $ personTime $ commitAuthor commit
return $ Just $ map (uncurry mkrow) pairs return (noNodes graph, map (uncurry mkrow) pairs')
else return Nothing
return (branches, tags, ml) listRefs :: FilePath -> IO (Set Text, Set Text)
listRefs path = withRepo (fromString path) $ \ git ->
(,) <$> listBranches git <*> listTags git

View file

@ -67,11 +67,11 @@ import Data.Git.Local
import Text.FilePath.Local (breakExt) import Text.FilePath.Local (breakExt)
import Vervis.Form.Repo import Vervis.Form.Repo
import Vervis.Foundation import Vervis.Foundation
import Vervis.GitOld (timeAgo')
import Vervis.Path import Vervis.Path
import Vervis.MediaType (chooseMediaType) import Vervis.MediaType (chooseMediaType)
import Vervis.Model import Vervis.Model
import Vervis.Model.Repo import Vervis.Model.Repo
import Vervis.Paginate
import Vervis.Readme import Vervis.Readme
import Vervis.Render import Vervis.Render
import Vervis.Settings import Vervis.Settings
@ -83,7 +83,7 @@ import qualified Darcs.Local.Repository as D (createRepo)
import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Git.Local as G (createRepo) import qualified Data.Git.Local as G (createRepo)
import qualified Vervis.Darcs as D (readSourceView, readChangesView) import qualified Vervis.Darcs as D (readSourceView, readChangesView)
import qualified Vervis.Git as G (readSourceView, readChangesView) import qualified Vervis.Git as G (readSourceView, readChangesView, listRefs)
getReposR :: Text -> Handler Html getReposR :: Text -> Handler Html
getReposR user = do getReposR user = do
@ -186,12 +186,15 @@ getRepoSourceR shar repo refdir = do
getDarcsRepoHeadChanges :: Text -> Text -> Handler Html getDarcsRepoHeadChanges :: Text -> Text -> Handler Html
getDarcsRepoHeadChanges shar repo = do getDarcsRepoHeadChanges shar repo = do
path <- askRepoDir shar repo path <- askRepoDir shar repo
mentries <- liftIO $ D.readChangesView path (entries, navModel) <- getPageAndNav $
case mentries of \ o l -> do
mv <- liftIO $ D.readChangesView path o l
case mv of
Nothing -> notFound Nothing -> notFound
Just entries -> Just v -> return v
let changes = changesW entries let changes = changesW entries
in defaultLayout $(widgetFile "repo/changes-darcs") pageNav = navWidget navModel
defaultLayout $(widgetFile "repo/changes-darcs")
getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html
getGitRepoHeadChanges repository shar repo = getGitRepoHeadChanges repository shar repo =
@ -210,13 +213,16 @@ getDarcsRepoChanges shar repo tag = notFound
getGitRepoChanges :: Text -> Text -> Text -> Handler Html getGitRepoChanges :: Text -> Text -> Text -> Handler Html
getGitRepoChanges shar repo ref = do getGitRepoChanges shar repo ref = do
path <- askRepoDir shar repo path <- askRepoDir shar repo
(branches, tags, mentries) <- liftIO $ G.readChangesView path ref (branches, tags) <- liftIO $ G.listRefs path
case mentries of if ref `S.member` branches || ref `S.member` tags
Nothing -> notFound then do
Just entries -> (entries, navModel) <- getPageAndNav $
\ o l -> liftIO $ G.readChangesView path ref o l
let refSelect = refSelectW shar repo branches tags let refSelect = refSelectW shar repo branches tags
changes = changesW entries changes = changesW entries
in defaultLayout $(widgetFile "repo/changes-git") pageNav = navWidget navModel
defaultLayout $(widgetFile "repo/changes-git")
else notFound
getRepoChangesR :: Text -> Text -> Text -> Handler Html getRepoChangesR :: Text -> Text -> Text -> Handler Html
getRepoChangesR shar repo ref = do getRepoChangesR shar repo ref = do

View file

@ -14,7 +14,8 @@
-} -}
module Vervis.Paginate module Vervis.Paginate
( getPaginated ( getPageAndNav
, navWidget
) )
where where
@ -59,16 +60,17 @@ paginateSettings select = def
navWidgetSettings :: NavWidgetSettings navWidgetSettings :: NavWidgetSettings
navWidgetSettings = def navWidgetSettings = def
getPaginated getPageAndNav
:: MonadHandler m :: MonadHandler m
=> (Int -> Int -> m (Int, f i)) => (Int -> Int -> m (Int, f i))
-- ^ Given offset and limit, get total number of items and chosen subset -- ^ Given offset and limit, get total number of items and chosen subset
-> m (f i, WidgetT (HandlerSite m) IO ()) -> m (f i, NavModel)
getPaginated select = do getPageAndNav select = paginate (paginateSettings select) navSettings
(items, nm) <- paginate (paginateSettings select) navSettings
navWidget :: NavModel -> WidgetT site IO ()
navWidget nm = do
route <- route <-
fromMaybe (error "Pagination in invalid response content") <$> fromMaybe (error "Pagination in invalid response content") <$>
getCurrentRoute getCurrentRoute
let url n = (route, "?page=" <> T.pack (show n)) let url n = (route, "?page=" <> T.pack (show n))
widget = pageNavWidget nm navWidgetSettings url pageNavWidget nm navWidgetSettings url
return (items, widget)

View file

@ -16,4 +16,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>TODO <p>TODO
^{pageNav}
^{changes} ^{changes}
^{pageNav}

View file

@ -14,4 +14,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{refSelect} ^{refSelect}
^{pageNav}
^{changes} ^{changes}
^{pageNav}

View file

@ -34,7 +34,8 @@ flag library-only
default: False default: False
library library
exposed-modules: Darcs.Local.PatchInfo.Parser exposed-modules: Control.Applicative.Local
Darcs.Local.PatchInfo.Parser
Darcs.Local.PatchInfo.Types Darcs.Local.PatchInfo.Types
Darcs.Local.Repository Darcs.Local.Repository
Data.Attoparsec.ByteString.Local Data.Attoparsec.ByteString.Local
@ -42,6 +43,7 @@ library
Data.ByteString.Char8.Local Data.ByteString.Char8.Local
Data.ByteString.Local Data.ByteString.Local
Data.Char.Local Data.Char.Local
Data.Either.Local
Data.EventTime.Local Data.EventTime.Local
Data.Functor.Local Data.Functor.Local
Data.Git.Local Data.Git.Local