diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index f0176ec6..d2851eb0 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/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) diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index 26768d45..c799d86f 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/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 ]