diff --git a/src/Control/Applicative/Local.hs b/src/Control/Applicative/Local.hs new file mode 100644 index 0000000..6de769c --- /dev/null +++ b/src/Control/Applicative/Local.hs @@ -0,0 +1,52 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Darcs/Local/PatchInfo/Parser.hs b/src/Darcs/Local/PatchInfo/Parser.hs index a4b8e25..3811664 100644 --- a/src/Darcs/Local/PatchInfo/Parser.hs +++ b/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 diff --git a/src/Data/Either/Local.hs b/src/Data/Either/Local.hs new file mode 100644 index 0000000..202a80c --- /dev/null +++ b/src/Data/Either/Local.hs @@ -0,0 +1,30 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 9adba89..558e090 100644 --- a/src/Data/Git/Local.hs +++ b/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 diff --git a/src/Data/Paginate/Local.hs b/src/Data/Paginate/Local.hs index d541d28..517d8a6 100644 --- a/src/Data/Paginate/Local.hs +++ b/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) diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 8dfe408..e8ed775 100644 --- a/src/Vervis/Darcs.hs +++ b/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]) - -- ^ View of change log -readChangesView path = do - eps <- readPatchInfo path - case eps of - Left _err -> return Nothing - Right ps -> do - now <- getCurrentTime - let toLE pi h = LogEntry - { leAuthor = - T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi - , leHash = decodeStrict $ B16.encode h - , leMessage = piTitle pi - , leTime = - intervalToEventTime $ - FriendlyConvert $ - now `diffUTCTime` piTime pi - } - return $ Just $ map (uncurry toLE) $ reverse $ psPatches ps + -> 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 + , leHash = decodeStrict $ B16.encode h + , leMessage = piTitle pi + , leTime = + intervalToEventTime $ + FriendlyConvert $ + now `diffUTCTime` piTime pi + } + return (total, map (uncurry toLE) $ reverse $ psPatches ps) diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index ff910ce..ca6a5ad 100644 --- a/src/Vervis/Git.hs +++ b/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]) - -- ^ 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) + -> 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]) + nodes = case mnodes of + 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 + { 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 (noNodes graph, map (uncurry mkrow) pairs') + +listRefs :: FilePath -> IO (Set Text, Set Text) +listRefs path = withRepo (fromString path) $ \ git -> + (,) <$> listBranches git <*> listTags git diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index bc716da..7631250 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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 - Nothing -> notFound - Just entries -> - let changes = changesW entries - in defaultLayout $(widgetFile "repo/changes-darcs") + (entries, navModel) <- getPageAndNav $ + \ o l -> do + mv <- liftIO $ D.readChangesView path o l + case mv of + Nothing -> notFound + 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 - 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 diff --git a/src/Vervis/Paginate.hs b/src/Vervis/Paginate.hs index 4d8bfd7..c0d7915 100644 --- a/src/Vervis/Paginate.hs +++ b/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 diff --git a/templates/repo/changes-darcs.hamlet b/templates/repo/changes-darcs.hamlet index 5890cb7..1060e07 100644 --- a/templates/repo/changes-darcs.hamlet +++ b/templates/repo/changes-darcs.hamlet @@ -16,4 +16,8 @@ $# .

TODO +^{pageNav} + ^{changes} + +^{pageNav} diff --git a/templates/repo/changes-git.hamlet b/templates/repo/changes-git.hamlet index e0faba2..a532c95 100644 --- a/templates/repo/changes-git.hamlet +++ b/templates/repo/changes-git.hamlet @@ -14,4 +14,8 @@ $# . ^{refSelect} +^{pageNav} + ^{changes} + +^{pageNav} diff --git a/vervis.cabal b/vervis.cabal index eca287d..a13870b 100644 --- a/vervis.cabal +++ b/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