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
+    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
         { psPristineHash = phash
         , psPristineSize = psize
@@ -253,7 +266,17 @@ darcsDir = "_darcs"
 inventoryFile :: FilePath
 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
     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,22 +118,25 @@ readSourceView path dir = do
 readChangesView
     :: FilePath
     -- ^ 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 toLE pi h = LogEntry
+    let off' = total - off - lim
-                    { leAuthor  =
+    ps <- ExceptT $ readPatchInfoPage off' lim path
-                        T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi
+    now <- lift getCurrentTime
-                    , leHash    = decodeStrict $ B16.encode h
+    let toLE pi h = LogEntry
-                    , leMessage = piTitle pi
+            { leAuthor  =
-                    , leTime    =
+                T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi
-                        intervalToEventTime $
+            , leHash    = decodeStrict $ B16.encode h
-                        FriendlyConvert $
+            , leMessage = piTitle pi
-                        now `diffUTCTime` piTime pi
+            , leTime    =
-                    }
+                intervalToEventTime $
-            return $ Just $ map (uncurry toLE) $ reverse $ psPatches ps
+                FriendlyConvert $
+                now `diffUTCTime` piTime pi
+            }
+    return (total, map (uncurry toLE) $ reverse $ psPatches ps)

src/Vervis/Git.hs

@@ -16,6 +16,7 @@
 module Vervis.Git
     ( readSourceView
     , readChangesView
+    , listRefs
     )
 where
 
@@ -135,34 +136,36 @@ readChangesView
     -- ^ Repository path
     -> Text
     -- ^ 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])
+        nodes = case mnodes of
-                nodes = case mnodes of
+            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
-                    { leAuthor  = toText $ personName $ commitAuthor commit
+            { leAuthor  = toText $ personName $ commitAuthor commit
-                    , leHash    = toText $ toHex $ unObjId oid
+            , leHash    = toText $ toHex $ unObjId oid
-                    , leMessage = toText $ takeLine $ commitMessage commit
+            , leMessage = toText $ takeLine $ commitMessage commit
-                    , leTime    =
+            , leTime    =
-                        intervalToEventTime $
+                intervalToEventTime $
-                        FriendlyConvert $
+                FriendlyConvert $
-                        now - t
+                now - t
-                    }
+            }
-                    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

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
+    (entries, navModel) <- getPageAndNav $
-    case mentries of
+        \ o l -> do
-        Nothing -> notFound
+            mv <- liftIO $ D.readChangesView path o l
-        Just entries ->
+            case mv of
-            let changes = changesW entries
+                Nothing -> notFound
-            in  defaultLayout $(widgetFile "repo/changes-darcs")
+                Just v  -> return v
+    let changes = changesW entries
+        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
+    (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
                 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 ())
+    -> 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 <-
         fromMaybe (error "Pagination in invalid response content") <$>
         getCurrentRoute
     let url n = (route, "?page=" <> T.pack (show n))
-        widget = pageNavWidget nm navWidgetSettings url
+    pageNavWidget nm navWidgetSettings url
-    return (items, widget)

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