wip

fixme-new/lib/Fixme/Types.hs

@@ -717,6 +717,9 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
 
 fixmeDerivedFields :: Fixme -> Fixme
 fixmeDerivedFields fx = do
+  -- TODO: refactor-this-out
+  --   чревато ошибками, надо как-то переписать
+  --   по-человечески.
   fxEnd
   <> fx
   <> fxKey
@@ -724,6 +727,7 @@ fixmeDerivedFields fx = do
   <> tag
   <> fxLno
   <> fxTs
+  -- always last
   <> fxMisc
   where
     email = HM.lookup "commiter-email" (fixmeAttr fx)

hbs2-git-dashboard/app/GitDashBoard.hs

@@ -110,7 +110,13 @@ instance HasLimit (FromParams 'FixmeDomain [Param]) where
       limits   = (fromIntegral offset, fromIntegral pageSize)
 
 instance HasPredicate (FromParams 'FixmeDomain [Param]) where
-  predicate _ = All
+  predicate (FromParams args) = do
+    flip fix seed $ \next -> \case
+      [] -> All
+      ( clause : rest ) -> And clause (next rest)
+
+    where
+      seed = [ AttrLike a b | (a,b) <- args, a /= "$page" ]
 
 readConfig :: DashBoardPerks m => m [Syntax C]
 readConfig = do
@@ -304,7 +310,7 @@ runDashboardWeb WebOptions{..} = do
       lift $ renderHtml (repoForks lww)
       -- lift $ renderHtml (toHtml $ show $ pretty lww)
 
-  get (routePattern (RepoFixmeHtmx "lww")) do
+  get (routePattern (RepoFixmeHtmx mempty "lww")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
     p <- queryParams
     debug $ "FIXME: GET QUERY" <+> pretty p

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

@@ -19,6 +19,8 @@ import HBS2.Git.Web.Assets
 
 -- import Data.Text.Fuzzy.Tokenize as Fuzz
 
+import Data.Map qualified as Map
+import Data.Map (Map)
 import Data.ByteString.Lazy qualified as LBS
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
@@ -39,6 +41,7 @@ import Data.List qualified as List
 import Data.List (sortOn)
 
 import Web.Scotty.Trans as Scotty
+import Network.URI.Encode
 
 import Data.Kind
 
@@ -74,6 +77,7 @@ data RepoPageTabs =  CommitsTab (Maybe GitHash)
                    | TreeTab (Maybe GitHash)
                    | IssuesTab
                    | ForksTab
+                   | PinnedTab (Maybe (Text, Text, GitHash))
                     deriving stock (Eq,Ord,Show)
 
 data RepoPage s a = RepoPage s a
@@ -96,7 +100,7 @@ newtype RepoCommits repo = RepoCommits repo
 
 data Paged q = Paged QueryOffset q
 
-newtype RepoFixmeHtmx repo = RepoFixmeHtmx repo
+data RepoFixmeHtmx repo = RepoFixmeHtmx (Map Text Text) repo
 
 data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim
 
@@ -126,6 +130,7 @@ instance Pretty RepoPageTabs where
     TreeTab{}      -> "tree"
     ForksTab{}     -> "forks"
     IssuesTab{}    -> "issues"
+    PinnedTab{}    -> "pinned"
 
 instance FromStringMaybe RepoPageTabs where
   fromStringMay = \case
@@ -134,6 +139,7 @@ instance FromStringMaybe RepoPageTabs where
     "tree"     -> pure (TreeTab Nothing)
     "forks"    -> pure ForksTab
     "issues"   -> pure IssuesTab
+    "pinned"   -> pure $ PinnedTab Nothing
     _          -> pure (CommitsTab Nothing)
 
 instance ToRoutePattern RepoListPage where
@@ -144,9 +150,11 @@ instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where
   toURL (RepoPage s w)  = path @String [ "/", show (pretty s), show (pretty w)]
                             <> pred_
     where
+     -- FIXME: use-uri-encode
      pred_ = case s of
       CommitsTab (Just p)       -> Text.pack $ "?ref=" <> show (pretty p)
       TreeTab (Just p)          -> Text.pack $ "?tree=" <> show (pretty p)
+      PinnedTab (Just (s,n,h))  -> Text.pack $ "?ref=" <> show (pretty h)
       _ -> mempty
 
 instance ToRoutePattern (RepoPage String String) where
@@ -269,18 +277,19 @@ instance ToURL (RepoForksHtmx (LWWRefKey 'HBS2Basic))  where
       repo = show $ pretty k
 
 instance ToRoutePattern (RepoFixmeHtmx  String) where
-  routePattern (RepoFixmeHtmx r) =
+  routePattern (RepoFixmeHtmx _ r) =
     path ["/", "htmx", "fixme", toArg r] & toPattern
 
 instance ToURL (RepoFixmeHtmx RepoLww)  where
-  toURL (RepoFixmeHtmx k) = path ["/", "htmx", "fixme", repo]
+  toURL (RepoFixmeHtmx argz' k) = path ["/", "htmx", "fixme", repo] <> "?" <> filtPart
     where
       repo = show $ pretty k
+      filtPart = Text.intercalate "&" [ [qc|{encodeText k}={encodeText v}|] | (k,v) <- argz ]
+      argz = Map.toList argz'
 
 instance ToURL (Paged (RepoFixmeHtmx RepoLww))  where
-  toURL (Paged p (RepoFixmeHtmx k)) = path ["/", "htmx", "fixme", repo] <> [qc|?$page={p}|]
+  toURL (Paged p (RepoFixmeHtmx a k)) = toURL (RepoFixmeHtmx paged k)
-    where
+    where paged = Map.insert "$page" (Text.pack (show p)) a
-      repo = show $ pretty k
 
 instance ToRoutePattern (RepoForksHtmx String) where
   routePattern (RepoForksHtmx r) =
@@ -932,12 +941,15 @@ repoFixme :: ( MonadReader DashBoardEnv m
              , DashBoardPerks m
              , HasLimit q
              , HasPredicate q
+             , q ~ FromParams 'FixmeDomain [Param]
              )
           => q
           -> LWWRefKey HBS2Basic
           -> HtmlT m ()
 
-repoFixme q lww = do
+repoFixme q@(FromParams p') lww = do
+
+  let p = Map.fromList p'
 
   now <- liftIO $ getPOSIXTime <&> round
 
@@ -965,7 +977,7 @@ repoFixme q lww = do
 
   unless (List.null fme) do
     tr_ [ class_ "commit-brief-last"
-        , hxGet_ (toURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx (RepoLww lww))))
+        , hxGet_ (toURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx p (RepoLww lww))))
         , hxTrigger_ "revealed"
         , hxSwap_ "afterend"
         ] do
@@ -1043,9 +1055,7 @@ repoTopInfoBlock lww TopInfoBlock{..} = do
         case ref of
           PinnedRefBlob s n hash -> small_ do
             li_ $ a_ [class_ "secondary"
-              , href_ "#"
+              , href_ (toURL (RepoPage (PinnedTab (Just (s,n,hash))) lww))
-              , hxGet_ (toURL (RepoSomeBlob lww s hash))
-              , hxTarget_ "#repo-tab-data"
               ] do
                   span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned
                   toHtml (Text.take 12 n)
@@ -1096,12 +1106,15 @@ repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
          -> [(Text,Text)]
          -> HtmlT m ()
 
-repoPage IssuesTab lww _ = rootPage do
+repoPage IssuesTab lww p' = rootPage do
+
+  let p = Map.fromList p'
 
   topInfoBlock@TopInfoBlock{..} <- getTopInfoBlock lww
   tot <- lift $ countFixme (RepoLww lww)
   fmw <- lift $ countFixmeByAttribute (RepoLww lww) "workflow"
   fmt <- lift $ countFixmeByAttribute (RepoLww lww) "fixme-tag"
+  ass <- lift $ countFixmeByAttribute (RepoLww lww) "assigned"
 
   main_ [class_ "container-fluid"] do
     div_ [class_ "wrapper"] do
@@ -1125,7 +1138,10 @@ repoPage IssuesTab lww _ = rootPage do
           ul_ do
             for_ fmt $ \(s,n) -> do
               li_ [] $ small_ [] do
-                a_ [class_ "secondary"] do
+                a_ [ class_ "secondary"
+                   , hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "fixme-tag" (coerce s) p) (RepoLww lww))))
+                   , hxTarget_ "#fixme-tab-data"
+                   ] do
                   span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
                     toHtml $ show $ pretty n
 
@@ -1136,7 +1152,10 @@ repoPage IssuesTab lww _ = rootPage do
           ul_ do
 
             li_ [] $ small_ [] do
-              a_ [class_ "secondary"] do
+              a_ [ class_ "secondary"
+                 , hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.delete "workflow" p) (RepoLww lww))))
+                 , hxTarget_ "#fixme-tab-data"
+                 ] do
                 span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
                   toHtml $ show $ pretty (fromMaybe 0 tot)
 
@@ -1144,7 +1163,24 @@ repoPage IssuesTab lww _ = rootPage do
 
             for_ fmw $ \(s,n) -> do
               li_ [] $ small_ [] do
-                a_ [class_ "secondary"] do
+                a_ [ class_ "secondary"
+                   , hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "workflow" (coerce s) p) (RepoLww lww))))
+                   , hxTarget_ "#fixme-tab-data"
+                   ] do
+                  span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
+                    toHtml $ show $ pretty n
+
+                  span_ [] $ toHtml $ show $ pretty s
+
+
+          summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Assigned"
+
+          for_ ass $ \(s,n) -> do
+            li_ [] $ small_ [] do
+              a_ [ class_ "secondary"
+                 , hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "assigned" (coerce s) p) (RepoLww lww))))
+                 , hxTarget_ "#fixme-tab-data"
+                 ] do
                 span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
                   toHtml $ show $ pretty n
 
@@ -1166,7 +1202,7 @@ repoPage IssuesTab lww _ = rootPage do
         div_ [ id_ "repo-tab-data"
              , hxTrigger_ "load"
              , hxTarget_ "#fixme-tab-data"
-             , hxGet_ (toURL (RepoFixmeHtmx (RepoLww lww)))
+             , hxGet_ (toURL (RepoFixmeHtmx mempty (RepoLww lww)))
              ] mempty
 
         div_ [id_ "repo-tab-data-embedded"] mempty
@@ -1258,5 +1294,26 @@ repoPage tab lww params = rootPage do
             ForksTab -> do
               repoForks lww
 
+            PinnedTab w -> do
+
+              pinned' <- S.toList_ $ for_ pinned $ \(_,ref) ->  case ref of
+                              PinnedRefBlob s n hash -> do
+                                S.yield (hash, (s,n))
+
+              let pinned = Map.fromList pinned'
+
+              void $ runMaybeT do
+                ref  <- [ fromStringMay @GitHash (Text.unpack v)
+                        | ("ref", v) <- params
+                        ] & catMaybes
+                          & headMay
+                          & toMPlus
+
+                (s,n) <- Map.lookup ref pinned & toMPlus
+
+                lift $ repoSomeBlob lww s ref
+
+              mempty
+
         div_ [id_ "repo-tab-data-embedded"] mempty
 

hbs2-git-dashboard/hbs2-git-dashboard.cabal

@@ -11,6 +11,7 @@ common shared-properties
         -Wall
         -fno-warn-type-defaults
         -fno-warn-unused-matches
+        -fno-warn-name-shadowing
         -O2
 
   default-language: GHC2021
@@ -123,6 +124,7 @@ library hbs2-git-dashboard-core
       , unliftio
       , unliftio-core
       , unordered-containers
+      , uri-encode
       , vector
       , wai
       , wai-extra