Minimal pagination for git and darcs change log

src/Control/Applicative/Local.hs

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

src/Darcs/Local/PatchInfo/Parser.hs

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

src/Data/Either/Local.hs

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

src/Data/Git/Local.hs

@@ -21,6 +21,9 @@ module Data.Git.Local
     , TreeRows
     , PathView (..)
     , viewPath
+      -- * View refs
+    , listBranches
+    , listTags
     )
 where
 
@@ -31,6 +34,7 @@ import Data.Byteable (toBytes)
 import Data.Git
 import Data.Git.Harder
 import Data.Git.Types (GitTime (..))
+import Data.Set (Set)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8With)
 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.Lazy as BL (ByteString)
+import qualified Data.Set as S (mapMonotonic)
+import qualified Data.Text as T (pack)
 
 import Data.EventTime.Local
 import Data.Hourglass.Local ()
@@ -115,3 +121,9 @@ viewPath git root path = do
             case target of
                 Left blob  -> return $ BlobView nameT oid (blobGetContent blob)
                 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

src/Data/Paginate/Local.hs

@@ -156,4 +156,6 @@ paginate ps ns = do
     curr <- psCurrent ps
     let (offset, limit) = subseq (psPer ps) curr
     (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)

src/Vervis/Darcs.hs

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

src/Vervis/Git.hs

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

src/Vervis/Handler/Repo.hs

@@ -67,11 +67,11 @@ import Data.Git.Local
 import Text.FilePath.Local (breakExt)
 import Vervis.Form.Repo
 import Vervis.Foundation
-import Vervis.GitOld (timeAgo')
 import Vervis.Path
 import Vervis.MediaType (chooseMediaType)
 import Vervis.Model
 import Vervis.Model.Repo
+import Vervis.Paginate
 import Vervis.Readme
 import Vervis.Render
 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.Git.Local as G (createRepo)
 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 user = do
@@ -186,12 +186,15 @@ getRepoSourceR shar repo refdir = do
 getDarcsRepoHeadChanges :: Text -> Text -> Handler Html
 getDarcsRepoHeadChanges shar repo = do
     path <- askRepoDir shar repo
-    mentries <- liftIO $ D.readChangesView path
-    case mentries of
+    (entries, navModel) <- getPageAndNav $
+        \ o l -> do
+            mv <- liftIO $ D.readChangesView path o l
+            case mv of
                 Nothing -> notFound
-        Just entries ->
+                Just v  -> return v
     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 repository shar repo =
@@ -210,13 +213,16 @@ getDarcsRepoChanges shar repo tag = notFound
 getGitRepoChanges :: Text -> Text -> Text -> Handler Html
 getGitRepoChanges shar repo ref = do
     path <- askRepoDir shar repo
-    (branches, tags, mentries) <- liftIO $ G.readChangesView path ref
-    case mentries of
-        Nothing -> notFound
-        Just entries ->
+    (branches, tags) <- liftIO $ G.listRefs path
+    if ref `S.member` branches || ref `S.member` tags
+        then do
+            (entries, navModel) <- getPageAndNav $
+                \ o l -> liftIO $ G.readChangesView path ref o l
             let refSelect = refSelectW shar repo branches tags
                 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 shar repo ref = do

src/Vervis/Paginate.hs

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

templates/repo/changes-darcs.hamlet

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

templates/repo/changes-git.hamlet

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

vervis.cabal

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