fixme paging

fixme-new/lib/Fixme/Run/Internal.hs

@@ -304,7 +304,7 @@ report t q = do
   tpl <- asks fixmeEnvTemplates >>= readTVarIO
             <&> HM.lookup (maybe "default" fromString t)
 
-  fxs <- listFixme q
+  fxs <- listFixme (WithLimit Nothing q)
 
   case tpl of
     Nothing ->

fixme-new/lib/Fixme/State.hs

@@ -21,7 +21,12 @@ module Fixme.State
   , FixmeExported(..)
   , HasPredicate(..)
   , SelectPredicate(..)
+  , HasLimit(..)
   , LocalNonce(..)
+  , WithLimit(..)
+  , QueryOffset(..)
+  , QueryLimit(..)
+  , QueryLimitClause(..)
   ) where
 
 import Fixme.Prelude hiding (key)
@@ -157,6 +162,33 @@ createTables = do
          |]
 
 
+class HasPredicate a where
+  predicate :: a -> SelectPredicate
+
+class HasLimit a where
+  limit :: a -> Maybe QueryLimitClause
+
+-- TODO: move-to-db-pipe?
+newtype QueryOffset = QueryOffset Word64
+                      deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty)
+
+-- TODO: move-to-db-pipe?
+newtype QueryLimit = QueryLimit Word64
+                      deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty)
+
+type QueryLimitClause = (QueryOffset, QueryLimit)
+
+instance HasLimit () where
+  limit _ = Nothing
+
+data WithLimit q = WithLimit (Maybe QueryLimitClause) q
+
+instance HasPredicate q => HasPredicate (WithLimit q) where
+  predicate (WithLimit _ query) = predicate query
+
+instance HasLimit (WithLimit a) where
+  limit (WithLimit l _) = l
+
 data SelectPredicate =
     All
   | FixmeHashExactly Text
@@ -167,8 +199,6 @@ data SelectPredicate =
   | Ignored
   deriving stock (Data,Generic,Show)
 
-class HasPredicate a where
-  predicate :: a -> SelectPredicate
 
 instance HasPredicate () where
   predicate = const All
@@ -176,7 +206,6 @@ instance HasPredicate () where
 instance HasPredicate SelectPredicate where
   predicate = id
 
-
 instance IsContext c => HasPredicate [Syntax c] where
   predicate s = goPred $ unlist $ go s
     where
@@ -342,7 +371,11 @@ countFixme = do
   withState $ select_ @_ @(Only Int) sql
     <&> maybe 0 fromOnly . headMay
 
-listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q)
+listFixme :: ( FixmePerks m
+             , MonadReader FixmeEnv m
+             , HasPredicate q
+             , HasLimit q
+             )
           => q
           -> m [Fixme]
 listFixme expr = do
@@ -351,6 +384,10 @@ listFixme expr = do
 
   let present = [qc|and coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
 
+  let (limitClause, lbound) = case limit expr of
+                                 Just (o,l) -> ([qc|limit ? offset ?|] :: String, [Bound l, Bound o])
+                                 Nothing -> (mempty, [])
+
   let sql = [qc|
     with s1 as (
       select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob
@@ -364,11 +401,12 @@ listFixme expr = do
     order by
         json_extract(s1.blob, '$.commit-time') asc nulls last,
         json_extract(s1.blob, '$.w') asc nulls last
+    {limitClause}
     |]
 
   debug $ pretty sql
 
-  withState $ select @(Only Text) sql bound
+  withState $ select @(Only Text) sql (bound <> lbound)
         <&> fmap (sqliteToAeson . fromOnly)
         <&> catMaybes
 

hbs2-git-dashboard/app/GitDashBoard.hs

@@ -100,6 +100,18 @@ instance (DashBoardPerks m, HasDashBoardEnv m) => HandleMethod m IndexNowRPC whe
     debug $ "rpc: index:now"
     withDashBoardEnv e $ addJob (liftIO $ withDashBoardEnv e updateIndex)
 
+instance HasLimit (FromParams 'FixmeDomain [Param]) where
+  -- TODO: optimal-page-size
+  limit (FromParams p) = Just limits
+    where
+      pageSize = fromIntegral fixmePageSize
+      page     = fromMaybe 0 $ headMay [ readDef 0 (Text.unpack n) | ("$page", n) <- p ]
+      offset   = page
+      limits   = (fromIntegral offset, fromIntegral pageSize)
+
+instance HasPredicate (FromParams 'FixmeDomain [Param]) where
+  predicate _ = All
+
 readConfig :: DashBoardPerks m => m [Syntax C]
 readConfig = do
 
@@ -294,9 +306,11 @@ runDashboardWeb WebOptions{..} = do
 
   get (routePattern (RepoFixmeHtmx "lww")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
+    p <- queryParams
+    debug $ "FIXME: GET QUERY" <+> pretty p
     flip runContT pure do
       lww   <- lwws' & orFall (status status404)
-      lift $ renderHtml (repoFixme lww)
+      lift $ renderHtml (repoFixme (FromParams @'FixmeDomain p) lww)
 
   get (routePattern (RepoCommits "lww")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)

hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs

@@ -1,6 +1,10 @@
 module HBS2.Git.DashBoard.Fixme
   ( F.HasPredicate(..)
+  , F.HasLimit(..)
   , F.SelectPredicate(..)
+  , WithLimit(..)
+  , QueryOffset
+  , QueryLimit
   , runInFixme
   , countFixme
   , listFixme
@@ -13,6 +17,7 @@ module HBS2.Git.DashBoard.Fixme
   , FixmeAttrName(..)
   , FixmeAttrVal(..)
   , FixmeOpts(..)
+  , fixmePageSize
   ) where
 
 import HBS2.Git.DashBoard.Prelude
@@ -22,7 +27,7 @@ import HBS2.Git.DashBoard.State
 import HBS2.OrDie
 
 import Fixme.State qualified as F
-import Fixme.State (HasPredicate(..))
+import Fixme.State (HasPredicate(..),HasLimit(..),WithLimit(..),QueryOffset,QueryLimit)
 import Fixme.Types
 import Fixme.Config
 
@@ -37,6 +42,10 @@ data RunInFixmeError =
 
 instance Exception RunInFixmeError
 
+fixmePageSize :: QueryLimit
+fixmePageSize = 100
+
+
 -- TODO: less-hacky-approach
 --  этот код подразумевает, что мы знаем довольно много деталей
 --  реализации про fixme-new
@@ -81,9 +90,15 @@ runInFixme repo m = do
 
       m
 
-listFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m, HasPredicate q) => RepoLww -> q -> m [Fixme]
+listFixme :: ( DashBoardPerks m
+             , MonadReader DashBoardEnv m
+             , HasPredicate q
+             , HasLimit q
+             ) => RepoLww -> q -> m [Fixme]
 listFixme repo q = do
   runInFixme repo $ F.listFixme q
+    -- FIXME: error-handling
+    --   at least print log entry
     & try @_ @SomeException
     <&> fromRight mempty
 

hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs

@@ -49,6 +49,10 @@ import Network.HTTP.Types.Status
 rootPath :: [String] -> [String]
 rootPath = ("/":)
 
+data Domain = FixmeDomain
+
+newtype FromParams (e :: Domain) a = FromParams a
+
 class Path a where
   path :: [a] -> Text
 
@@ -90,6 +94,8 @@ newtype RepoManifest repo = RepoManifest repo
 
 newtype RepoCommits repo = RepoCommits repo
 
+data Paged q = Paged QueryOffset q
+
 newtype RepoFixmeHtmx repo = RepoFixmeHtmx repo
 
 data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim
@@ -271,6 +277,11 @@ instance ToURL (RepoFixmeHtmx RepoLww)  where
     where
       repo = show $ pretty k
 
+instance ToURL (Paged (RepoFixmeHtmx RepoLww))  where
+  toURL (Paged p (RepoFixmeHtmx k)) = path ["/", "htmx", "fixme", repo] <> [qc|?$page={p}|]
+    where
+      repo = show $ pretty k
+
 instance ToRoutePattern (RepoForksHtmx String) where
   routePattern (RepoForksHtmx r) =
     path ["/", "htmx", "forks", toArg r] & toPattern
@@ -917,13 +928,22 @@ instance ToHtml (H FixmeTitle) where
   toHtmlRaw (H k) = toHtmlRaw $ coerce @_ @Text k
   toHtml (H k)    = toHtml    $ coerce @_ @Text k
 
-repoFixme :: (MonadReader DashBoardEnv m, DashBoardPerks m)
-          => LWWRefKey HBS2Basic
+repoFixme :: ( MonadReader DashBoardEnv m
+             , DashBoardPerks m
+             , HasLimit q
+             , HasPredicate q
+             )
+          => q
+          -> LWWRefKey HBS2Basic
           -> HtmlT m ()
 
-repoFixme lww = do
+repoFixme q lww = do
 
-  fme <- lift $ listFixme (RepoLww lww) ()
+  debug $ blue "repoFixme" <+> "LIMITS" <+> viaShow (limit q)
+
+  let offset = maybe 0 fst (limit q)
+
+  fme <- lift $ listFixme (RepoLww lww) q
 
   for_ fme $ \fixme -> do
     tr_ [class_ "commit-brief-title"] $ do
@@ -937,6 +957,13 @@ repoFixme lww = do
       td_ [colspan_ "3"] do
         small_ "seconday shit"
 
+  unless (List.null fme) do
+    tr_ [ class_ "commit-brief-last"
+        , hxGet_ (toURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx (RepoLww lww))))
+        , hxTrigger_ "revealed"
+        , hxSwap_ "afterend"
+        ] do
+      td_ [colspan_ "3"] mempty
 
 data TopInfoBlock =
   TopInfoBlock