diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 2cc1db74..d18955d2 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/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 -> diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index fa2dea05..6405c6b8 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/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 diff --git a/hbs2-git-dashboard/app/GitDashBoard.hs b/hbs2-git-dashboard/app/GitDashBoard.hs index 8277a1be..80431148 100644 --- a/hbs2-git-dashboard/app/GitDashBoard.hs +++ b/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) diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs index fc9fa94b..03867e0d 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs +++ b/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 diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs index b5160529..151af197 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs +++ b/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