wip

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -260,6 +260,16 @@ runDashboardWeb wo = do
 
       lift $ renderHtml (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo)
 
+  get (routePattern (RepoSomeBlob "lww" "syntax" "blob")) do
+    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
+    syn   <- captureParamMaybe @Text "syntax" <&> fromMaybe "default"
+    blob' <- captureParam @String "blob" <&> fromStringMay @GitHash
+
+    flip runContT pure do
+      lww  <- lwws' & orFall (status status404)
+      blob <- blob' & orFall (status status404)
+      lift $ renderHtml (repoSomeBlob lww syn blob)
+
   get (routePattern (RepoCommitDefault  "lww" "hash")) (commitRoute RepoCommitSummary)
   get (routePattern (RepoCommitSummaryQ "lww" "hash")) (commitRoute RepoCommitSummary)
   get (routePattern (RepoCommitPatchQ   "lww" "hash")) (commitRoute RepoCommitPatch)

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

@@ -1,4 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
 {-# Language MultiWayIf #-}
 module HBS2.Git.Web.Html.Root where
 
@@ -76,6 +78,8 @@ data RepoTreeEmbedded repo commit tree = RepoTreeEmbedded repo commit tree
 
 data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob
 
+data RepoSomeBlob repo blob tp = RepoSomeBlob repo blob tp
+
 data RepoForksHtmx repo = RepoForksHtmx repo
 
 newtype RepoManifest repo = RepoManifest repo
@@ -169,6 +173,18 @@ instance ToRoutePattern (RepoBlob String String String String) where
   routePattern (RepoBlob r c t b) =
     path ["/", "htmx", "blob", toArg r, toArg c, toArg t, toArg b] & toPattern
 
+
+instance ToURL (RepoSomeBlob (LWWRefKey 'HBS2Basic) Text GitHash)  where
+  toURL (RepoSomeBlob k tp' blo) = path ["/", "htmx", "some-blob", repo, tp, blob]
+    where
+      repo = show $ pretty k
+      tp = Text.unpack tp'
+      blob = show $ pretty blo
+
+instance ToRoutePattern (RepoSomeBlob String String String) where
+  routePattern (RepoSomeBlob r t b) =
+    path ["/", "htmx", "some-blob", toArg r, toArg t, toArg b] & toPattern
+
 instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic))  where
   toURL (RepoManifest repo') = path ["/", "htmx", "manifest", repo]
     where
@@ -772,6 +788,16 @@ repoCommits lww predicate' = do
   else do
     rows
 
+
+repoSomeBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
+         => LWWRefKey 'HBS2Basic
+         -> Text
+         -> GitHash
+         -> HtmlT m ()
+
+repoSomeBlob lww syn blob = do
+  toHtml "JOPAKITA"
+
 repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
          => LWWRefKey 'HBS2Basic
          -> TreeCommit
@@ -874,6 +900,19 @@ instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where
   toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
 
 
+pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c
+pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "markdown"
+                                              , SymbolVal (Id syn)
+                                              , LitStrVal name
+                                              , asGitHash -> Just hash
+                                              ]
+{-# COMPLETE PinnedRefBlob #-}
+
+asGitHash :: forall c . Syntax c -> Maybe GitHash
+asGitHash  = \case
+  LitStrVal s -> fromStringMay (Text.unpack s)
+  _ -> Nothing
+
 repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
          => RepoPageTabs
          -> LWWRefKey 'HBS2Basic
@@ -896,7 +935,7 @@ repoPage tab lww params = rootPage do
 
   let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ]
   let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
-
+  let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5
 
   div_ [class_ "container main"] $ do
     nav_ [class_ "left"] $ do
@@ -941,6 +980,15 @@ repoPage tab lww params = rootPage do
             a_ [ href_ (toURL (RepoPage (CommitsTab Nothing) lww))] "Commits"
           div_ [ class_ "attrval"] $ toHtml (show $ rlRepoCommits)
 
+        for_ pinned $ \(name,ref) ->  do
+          div_ [ class_ "attr" ] do
+            div_ [ class_ "attrname"] $ do
+              case ref of
+                PinnedRefBlob s n hash -> do
+                  a_ [ href_ "#"
+                     , hxGet_ (toURL (RepoSomeBlob lww s hash))
+                     ] $ toHtml n
+
       for_ mbHead $ \rh -> do
 
         let theHead = headMay [ v | (GitRef "HEAD", v) <- view repoHeadRefs rh ]