uri handling refactoring

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

@@ -22,10 +22,11 @@ import HBS2.Git.Web.Html.Root
 
 import HBS2.Peer.CLI.Detect
 
-import Lucid (renderTextT)
+import Lucid (renderTextT,HtmlT(..),toHtml)
 import Options.Applicative as O
 import Data.Either
 import Data.Text qualified as Text
+import Data.Text.Lazy qualified as LT
 import Data.ByteString.Lazy qualified as LBS
 import Network.HTTP.Types.Status
 import Network.Wai.Middleware.Static hiding ((<|>))
@@ -170,6 +171,9 @@ data WebOptions =
 orFall :: m r -> Maybe a -> ContT r m a
 orFall a mb = ContT $ maybe1 mb a
 
+renderHtml :: MonadIO m => HtmlT (ActionT m) a -> ActionT m ()
+renderHtml m = renderTextT m >>= html
+
 runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) ()
 runDashboardWeb wo = do
   middleware logStdout
@@ -182,13 +186,15 @@ runDashboardWeb wo = do
     Just f -> do
       middleware $ staticPolicy (noDots >-> addBase f)
 
-  get "/" do
+  get (routePattern RepoListPage) do
-    html =<< lift (renderTextT dashboardRootPage)
+    renderHtml dashboardRootPage
+
+  get (routePattern (RepoPage "lww")) do
+    lww' <- captureParam @String "lww"  <&> fromStringMay @(LWWRefKey HBS2Basic)
 
-  get "/repo/:lww" do
-    lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
     flip runContT pure do
-      lww <- lwws' & orFall (status status404)
+
+      lww <- lww' & orFall (status status404)
 
       item <- lift (selectRepoList ( mempty
                                       & set repoListByLww (Just lww)
@@ -197,9 +203,9 @@ runDashboardWeb wo = do
                  <&> listToMaybe
                  >>= orFall (status status404)
 
-      lift $ html =<< renderTextT (repoPage item)
+      lift $ renderHtml (repoPage item)
 
-  get "/repo/:lww/manifest" do
+  get (routePattern (RepoManifest "lww")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
     flip runContT pure do
       lww <- lwws' & orFall (status status404)
@@ -214,22 +220,21 @@ runDashboardWeb wo = do
       lift $ html =<< renderTextT (thisRepoManifest item)
 
 
-  get "/repo/:lww/refs" do
+  get (routePattern (RepoRefs "lww")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
 
-    setHeader "HX-Push-Url" [qc|/repo/{show $ pretty lwws'}|]
+    setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|]
 
     flip runContT pure do
       lww <- lwws' & orFall (status status404)
       refs <- lift $ gitShowRefs lww
-      lift $ html =<< renderTextT (repoRefs lww refs)
+      lift $ renderHtml (repoRefs lww refs)
 
-  get "/repo/:lww/tree/:co/:hash" do
+  get (routePattern (RepoTree "lww" "co" "hash")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
     hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
     co'   <- captureParam @String "co" <&> fromStringMay @GitHash
 
-
     flip runContT pure do
       lww  <- lwws' & orFall (status status404)
       hash <- hash' & orFall (status status404)
@@ -242,7 +247,7 @@ runDashboardWeb wo = do
       debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back
       lift $ html =<< renderTextT (repoTree ctx lww co hash tree (coerce <$> back))
 
-  get "/repo/:lww/blob/:co/:hash/:blob" do
+  get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
     hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
     co'   <- captureParam @String "co" <&> fromStringMay @GitHash
@@ -257,13 +262,13 @@ runDashboardWeb wo = do
       blobInfo <- lift (selectBlobInfo (BlobHash blobHash))
                     >>= orFall (status status404)
 
-      lift $ html =<< renderTextT (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo)
+      lift $ renderHtml (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo)
 
-  get "/repo/:lww/commit/:hash" (commitRoute RepoCommitSummary)
+  get (routePattern (RepoCommitDefault  "lww" "hash")) (commitRoute RepoCommitSummary)
-  get "/repo/:lww/commit/summary/:hash" (commitRoute RepoCommitSummary)
+  get (routePattern (RepoCommitSummaryQ "lww" "hash")) (commitRoute RepoCommitSummary)
-  get "/repo/:lww/commit/patch/:hash" (commitRoute RepoCommitPatch)
+  get (routePattern (RepoCommitPatchQ   "lww" "hash")) (commitRoute RepoCommitPatch)
 
-  get "/repo/:lww/commits" do
+  get (routePattern (RepoCommits "lww")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
 
     let pred = mempty & set commitPredOffset 0
@@ -273,7 +278,7 @@ runDashboardWeb wo = do
       lww       <- lwws' & orFall (status status404)
       lift $ html =<< renderTextT (repoCommits lww (Right pred))
 
-  get "/repo/:lww/commits/:off/:lim" do
+  get (routePattern (RepoCommitsQ "lww" "off" "lim")) do
     lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
     off   <- captureParam  @Int "off"
     lim   <- captureParam  @Int "lim"
@@ -285,10 +290,13 @@ runDashboardWeb wo = do
 
       lww       <- lwws' & orFall (status status404)
 
+      -- FIXME: this
       referrer <- lift (Scotty.header "Referer")
-                    >>= orFall (redirect $ fromString $ Text.unpack $ path ["repo", show $ pretty  lww])
+                    >>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage lww))
 
-      lift $ html =<< renderTextT (repoCommits lww (Left pred))
+      lift $ renderHtml (repoCommits lww (Left pred))
+
+  -- "pages"
 
   where
     commitRoute style = do
@@ -301,9 +309,7 @@ runDashboardWeb wo = do
       flip runContT pure do
         lww   <- lwws' & orFall (status status404)
         hash  <- co & orFall (status status404)
-        lift $ html =<< renderTextT (repoCommit style lww hash)
+        lift $ renderHtml (repoCommit style lww hash)
-
-
 
 
 runScotty :: DashBoardPerks m => DashBoardM m ()

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

@@ -31,6 +31,9 @@ import Data.Either
 import Data.List qualified as List
 import Data.List (sortOn)
 
+import Web.Scotty.Trans as Scotty
+
+import Data.Kind
 
 import Streaming.Prelude qualified as S
 
@@ -46,9 +49,139 @@ instance Serialise ViewContext
 rootPath :: [String] -> [String]
 rootPath = ("/":)
 
-path :: [String] -> Text
+class Path a where
+  path :: [a] -> Text
+
+instance Path String where
   path = Text.pack . joinPath . rootPath
 
+class ToRoutePattern a where
+  routePattern :: a -> RoutePattern
+
+class ToURL a where
+  toURL :: a -> Text
+
+data family Tabs a :: Type
+
+data RepoListPage = RepoListPage
+
+newtype RepoPage a = RepoPage a
+
+data RepoRefs repo = RepoRefs repo
+
+data RepoTree repo commit tree = RepoTree repo commit tree
+
+data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob
+
+newtype RepoManifest repo = RepoManifest repo
+
+newtype RepoCommits repo = RepoCommits repo
+
+data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim
+
+data RepoCommitDefault repo commit = RepoCommitDefault repo commit
+
+data RepoCommitSummaryQ repo commit = RepoCommitSummaryQ repo commit
+
+data RepoCommitPatchQ repo commit = RepoCommitPatchQ repo commit
+
+toArg :: (Semigroup a, IsString a) => a -> a
+toArg s = ":" <> s
+
+instance ToRoutePattern RepoListPage where
+  routePattern = \case
+    RepoListPage -> "/"
+
+instance ToURL (RepoPage (LWWRefKey 'HBS2Basic)) where
+  toURL (RepoPage w)  = path @String [ "/", show (pretty w) ]
+
+instance ToRoutePattern (RepoPage String) where
+  routePattern (RepoPage w) = fromString ("/" <> toArg w)
+
+instance ToURL RepoListPage where
+  toURL _ =  "/"
+
+instance ToURL (RepoRefs (LWWRefKey 'HBS2Basic))  where
+  toURL (RepoRefs repo') = path ["/", "htmx", "refs", repo]
+    where
+      repo = show $ pretty repo'
+
+instance ToRoutePattern (RepoRefs String) where
+  routePattern (RepoRefs s) = path ["/", "htmx", "refs", toArg s] & Text.unpack & fromString
+
+
+instance ToURL (RepoTree (LWWRefKey 'HBS2Basic) GitHash GitHash)  where
+  toURL (RepoTree k co tree') = path ["/", "htmx", "tree", repo, commit, tree]
+    where
+      repo = show $ pretty k
+      commit = show $ pretty co
+      tree = show $ pretty tree'
+
+instance ToRoutePattern (RepoTree String String String) where
+  routePattern (RepoTree r co tree) =
+    path ["/", "htmx", "tree", toArg r, toArg co, toArg tree] & Text.unpack & fromString
+
+instance ToURL (RepoBlob (LWWRefKey 'HBS2Basic) GitHash GitHash GitHash)  where
+  toURL (RepoBlob k co t bo) = path ["/", "htmx", "blob", repo, commit, tree, blob]
+    where
+      repo = show $ pretty k
+      commit = show $ pretty co
+      tree   = show $ pretty t
+      blob = show $ pretty bo
+
+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] & Text.unpack & fromString
+
+instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic))  where
+  toURL (RepoManifest repo') = path ["/", "htmx", "manifest", repo]
+    where
+      repo = show $ pretty repo'
+
+instance ToRoutePattern (RepoManifest String) where
+  routePattern (RepoManifest s) = path ["/", "htmx", "manifest", toArg s] & Text.unpack & fromString
+
+instance ToURL (RepoCommits (LWWRefKey 'HBS2Basic))  where
+  toURL (RepoCommits repo') = path ["/", "htmx", "commits", repo]
+    where
+      repo = show $ pretty repo'
+
+instance ToRoutePattern (RepoCommits String) where
+  routePattern (RepoCommits s) = path ["/", "htmx", "commits", toArg s] & Text.unpack & fromString
+
+instance ToURL (RepoCommitsQ (LWWRefKey 'HBS2Basic) Int Int)  where
+  toURL (RepoCommitsQ repo' off lim) = path ["/", "htmx", "commits", repo, show off, show lim]
+    where
+      repo = show $ pretty repo'
+
+instance ToRoutePattern (RepoCommitsQ String String String) where
+  routePattern (RepoCommitsQ r o l) = path ["/", "htmx", "commits", toArg r, toArg o, toArg l] & Text.unpack & fromString
+
+instance ToURL (RepoCommitDefault (LWWRefKey 'HBS2Basic) GitHash)  where
+  toURL (RepoCommitDefault repo' h) = toURL (RepoCommitSummaryQ repo' h)
+
+instance ToRoutePattern (RepoCommitDefault String String) where
+  routePattern (RepoCommitDefault r h) = routePattern (RepoCommitSummaryQ r h)
+
+instance ToURL (RepoCommitSummaryQ (LWWRefKey 'HBS2Basic) GitHash)  where
+  toURL (RepoCommitSummaryQ repo' h) = path ["/", "htmx", "commit", "summary", repo, ha]
+    where
+      repo = show $ pretty repo'
+      ha = show $ pretty h
+
+instance ToRoutePattern (RepoCommitSummaryQ String String) where
+  routePattern (RepoCommitSummaryQ r h) = path ["/", "htmx", "commit", "summary", toArg r, toArg h] & Text.unpack & fromString
+
+instance ToURL (RepoCommitPatchQ (LWWRefKey 'HBS2Basic) GitHash)  where
+  toURL (RepoCommitPatchQ repo' h) = path ["/", "htmx", "commit", "patch", repo, ha]
+    where
+      repo = show $ pretty repo'
+      ha = show $ pretty h
+
+instance ToRoutePattern (RepoCommitPatchQ String String) where
+  routePattern (RepoCommitPatchQ r h) = path ["/", "htmx", "commit", "patch", toArg r, toArg h] & Text.unpack & fromString
+
+
 myCss :: Monad m => HtmlT m ()
 myCss = do
   link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])]
@@ -56,8 +189,6 @@ myCss = do
 hyper_ :: Text -> Attribute
 hyper_  = makeAttribute "_"
 
--- makeGetQuery :: String -> Attribute
--- makeGetQuery _ = termRaw "jop"
 
 onClickCopy :: Text -> Attribute
 onClickCopy s =
@@ -102,7 +233,8 @@ instance ToHtml (WithTime RepoListItem) where
 
     let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0
 
-    let url = path ["repo", Text.unpack $ view rlRepoLwwAsText it]
+    let url = toURL (RepoPage (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww))
+    -- path ["repo", Text.unpack $ view rlRepoLwwAsText it]
     let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq
 
     let updated = agePure t now
@@ -138,7 +270,7 @@ rootPage content  = do
 
     body_ do
       header_ do
-        div_ [class_ "header-title"] $ h1_ [] $ a_ [href_ "/"] "hbs2-peer dashboard"
+        div_ [class_ "header-title"] $ h1_ [] $ a_ [href_ (toURL RepoListPage)] "hbs2-peer dashboard"
       content
 
 
@@ -228,7 +360,7 @@ repoRefs lww refs = do
     for_ refs $ \(r,h) -> do
       let r_ = Text.pack $ show $ pretty r
       let co = show $ pretty h
-      let uri = path [ "repo", show $ pretty lww, "tree", co, co ]
+      let uri = toURL (RepoTree lww h h)
 
       let showRef = Text.isPrefixOf "refs" r_
 
@@ -250,13 +382,6 @@ repoRefs lww refs = do
                  ] (toHtml $ show $ pretty h)
 
 
-showRefsHtmxAttribs :: String -> [Attribute]
-showRefsHtmxAttribs repo =
-  [ hxGet_ (path ["repo", repo, "refs"])
-  , hxTarget_ "#repo-tab-data"
-  ]
-
-
 treeLocator :: DashBoardPerks m
             => LWWRefKey 'HBS2Basic
             -> GitHash
@@ -272,19 +397,22 @@ treeLocator lww co locator next = do
 
   let prefixSlash x = if fromIntegral x > 1 then span_ "/" else ""
   let showRoot =
-        [ hxGet_ (path ["repo", repo, "tree", co_, co_])
+        [ hxGet_ (toURL (RepoTree lww co co))
         , hxTarget_ "#repo-tab-data"
         , href_ "#"
         ]
 
-  span_ [] $ a_ (showRefsHtmxAttribs repo <> [href_ "#" ]) $ toHtml (take 10 repo <> "..")
+  span_ [] $ a_ [ hxGet_ (toURL (RepoRefs lww))
+                , hxTarget_ "#repo-tab-data"
+                , href_ "#"
+                ] $ toHtml (take 10 repo <> "..")
   span_ [] "/"
   span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..")
   unless (List.null locator) do
     span_ [] "/"
     for_ locator $ \(_,this,level,name) -> do
       prefixSlash level
-      let uri = path [ "repo", show $ pretty lww, "tree", co_, show (pretty this) ]
+      let uri = toURL (RepoTree lww co (coerce @_ @GitHash this))
       span_ [] do
         a_ [ href_ "#"
            , hxGet_ uri
@@ -303,13 +431,8 @@ repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
 
 repoTree ctx lww co root tree back' = do
 
-  let repo = show $ pretty $ lww
-
   let syntaxMap = Sky.defaultSyntaxMap
 
-  let co_ = show $ pretty co
-  let this_ = show $ pretty $ root
-
   let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree
         where
           tpOrder Tree = (0 :: Int)
@@ -329,7 +452,7 @@ repoTree ctx lww co root tree back' = do
     tr_ mempty do
 
       for_ back' $ \root -> do
-        let rootLink = path [ "repo", show $ pretty lww, "tree", co_, show (pretty root) ]
+        let rootLink = toURL (RepoTree lww co root)
         td_ $ img_ [src_ "/icon/tree-up.svg"]
         td_ ".."
         td_ do a_ [ href_ "#"
@@ -340,7 +463,7 @@ repoTree ctx lww co root tree back' = do
     for_ sorted $ \(tp,h,name) -> do
       let itemClass = pretty tp & show & Text.pack
       let hash_ = show $ pretty h
-      let uri = path [ "repo", show $ pretty lww, "tree", co_, hash_ ]
+      let uri = toURL $ RepoTree lww co h
       tr_ mempty do
         td_  $ case tp of
           Commit -> mempty
@@ -370,7 +493,7 @@ repoTree ctx lww co root tree back' = do
         td_ [class_ "mono"] do
           case tp of
             Blob -> do
-              let blobUri = path ["repo", repo, "blob", co_, this_, hash_ ]
+              let blobUri = toURL $ RepoBlob lww co root h
               a_ [ href_ "#"
                  , hxGet_ blobUri
                  , hxTarget_ "#repo-tab-data"
@@ -399,10 +522,6 @@ repoCommit :: (DashBoardPerks m, MonadReader DashBoardEnv m)
 repoCommit style lww hash = do
   let syntaxMap = Sky.defaultSyntaxMap
 
-  let repo = show $ pretty lww
-  let co_ = show $ pretty hash
-  let root = co_
-
   txt <- lift $ getCommitRawBrief lww hash
 
   let header = Text.lines txt & takeWhile (not . Text.null)
@@ -417,7 +536,7 @@ repoCommit style lww hash = do
     tr_ do
       th_ [width_ "16rem"] $ strong_ "commit"
       td_ $ a_ [ href_ "#"
-               , hxGet_ (path [ "repo", show $ pretty lww, "tree", co_, co_ ])
+               , hxGet_ (toURL (RepoTree lww hash hash))
                , hxTarget_ "#repo-tab-data"
                ] $ toHtml $ show $ pretty hash
 
@@ -432,12 +551,12 @@ repoCommit style lww hash = do
         ul_ [class_ "misc-menu"]do
           unless (style == RepoCommitSummary ) do
             li_ $ a_ [ href_ "#"
-                     , hxGet_ (path ["repo", repo, "commit", "summary", co_])
+                     , hxGet_ (toURL (RepoCommitSummaryQ lww hash))
                      , hxTarget_ "#repo-tab-data"
                      ] "summary"
           unless (style == RepoCommitPatch ) do
             li_ $ a_ [ href_ "#"
-                     , hxGet_ (path ["repo", repo, "commit", "patch", co_])
+                     , hxGet_ (toURL (RepoCommitPatchQ lww hash))
                      , hxTarget_ "#repo-tab-data"
                      ] "patch"
 
@@ -481,7 +600,6 @@ repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
 
 repoCommits lww predicate' = do
   now <- getEpoch
-  let repo = show $ pretty lww
 
   let predicate = either id id predicate'
 
@@ -491,7 +609,7 @@ repoCommits lww predicate' = do
   let lim = view commitPredLimit  predicate
   let noff = off + lim
 
-  let query = path ["repo", repo, "commits", show noff, show lim]
+  let query = RepoCommitsQ lww noff lim --) path ["repo", repo, "commits", show noff, show lim]
 
   let rows = do
         for_ co $ \case
@@ -500,12 +618,12 @@ repoCommits lww predicate' = do
               td_ $ img_ [src_ "/icon/git-commit.svg"]
               td_ $ small_ $ toHtml (agePure (coerce @_ @Integer commitListTime) now)
               td_ [class_ "mono", width_ "20rem"] do
-                  let hash = show $ pretty $ coerce @_ @GitHash commitListHash
+                  let hash = coerce @_ @GitHash commitListHash
                   a_ [ href_ "#"
-                     , hxGet_ (path ["repo",repo,"commit",hash])
+                     , hxGet_ (toURL (RepoCommitDefault lww hash))
                      , hxTarget_ "#repo-tab-data"
-                     , hxPushUrl_ query
+                     , hxPushUrl_ (toURL query)
-                     ] (toHtml hash)
+                     ] (toHtml $ show $ pretty hash)
               td_ do
                 small_ $ toHtml $ coerce @_ @Text commitListAuthor
             tr_ [class_ "commit-brief-details"] do
@@ -515,7 +633,7 @@ repoCommits lww predicate' = do
 
         unless (List.null co) do
           tr_ [ class_ "commit-brief-last"
-              , hxGet_ query
+              , hxGet_ (toURL query)
               , hxTrigger_ "revealed"
               , hxSwap_ "afterend"
               ] do
@@ -606,7 +724,6 @@ repoBlob lww co tree BlobInfo{..} = do
               let code = renderText (Lucid.formatHtmlBlock fo tokens)
               toHtmlRaw code
 
-
 repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
 repoPage it@RepoListItem{..} = rootPage do
 
@@ -618,9 +735,6 @@ repoPage it@RepoListItem{..} = rootPage do
 
   (meta, manifest) <- lift $ parsedManifest it
 
-  debug $ yellow "HEAD" <+> pretty rlRepoTx
-  debug $ yellow "META" <+> pretty meta
-
   let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ]
   let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
 
@@ -657,15 +771,17 @@ repoPage it@RepoListItem{..} = rootPage do
        repoMenu do
         repoMenuItem  mempty $ a_ [href_ "/"] "root"
 
-        repoMenuItem0 [ hxGet_ (path ["repo", repo, "commits"])
+        repoMenuItem0 [ hxGet_ (toURL (RepoCommits lww))
                       , hxTarget_ "#repo-tab-data"
                       ] "commits"
 
-        repoMenuItem [ hxGet_ (path ["repo", repo, "manifest"])
+        repoMenuItem [ hxGet_ (toURL (RepoManifest lww))
                      , hxTarget_ "#repo-tab-data"
                      ] "manifest"
 
-        repoMenuItem (showRefsHtmxAttribs repo) "tree"
+        repoMenuItem [ hxGet_ (toURL (RepoRefs lww))
+                     , hxTarget_ "#repo-tab-data"
+                     ] "tree"
 
       section_ [id_ "repo-data"] do
         h1_ (toHtml $ rlRepoName)