module HBS2.Git.Oracle.Html where import HBS2.Git.Oracle.Prelude import HBS2.Git.Oracle.State import HBS2.Git.Oracle.Facts import HBS2.Peer.HTTP.Root import HBS2.Peer.Proto.BrowserPlugin import Data.HashMap.Strict (HashMap) import Lucid hiding (for_) import Lucid.Base import Lucid.Html5 hiding (for_) import Lucid.Html5 qualified as Html import Data.Coerce import Data.Text (Text) import Data.Maybe import Data.Text qualified as Text import Data.Word import Data.List qualified as List import Data.HashMap.Strict qualified as HM import Data.ByteString.Lazy import Text.Pandoc import Text.Pandoc.Error (handleError) import Text.InterpolatedString.Perl6 (qc) markdownToHtml :: Text -> Either PandocError String markdownToHtml markdown = runPure $ do doc <- readMarkdown def {readerExtensions = pandocExtensions} markdown html <- writeHtml5String def {writerExtensions = pandocExtensions} doc return $ Text.unpack html renderMarkdown :: Text -> Html () renderMarkdown markdown = case markdownToHtml markdown of Left{} -> blockquote_ (toHtml markdown) Right html -> toHtmlRaw $ Text.pack html -- -- -- -- -- -- -- FIXME: move-to-hbs2-browser-lib hyper_ :: Text -> Attribute hyper_ = makeAttribute "_" tabClick :: Attribute tabClick = hyper_ "on click take .active from .tab for event's target" -- FIXME: move-to-hbs2-browser-lib onClickCopy :: Text -> Attribute onClickCopy s = hyper_ [qc|on click writeText('{s}') into the navigator's clipboard add .clicked to me wait 2s remove .clicked from me|] renderEntries :: Monad m => PluginMethod -> [(HashVal, Text, Text, Word64)] -> m ByteString renderEntries (Method _ kw) items = pure $ renderBS do -- TODO: ugly let hrefBase = HM.lookup "URL_PREFIX" kw & List.singleton . maybe "/" Text.unpack wrapped do main_ do section_ do h1_ "Git repositories" form_ [class_ "search"] do input_ [type_ "search", id_ "search"] button_ [class_ "search"] mempty section_ [id_ "repo-search-results"] do for_ items $ \(h,n,b,t) -> do let s = if Text.length n > 2 then n else "unnamed" let refpart = Text.take 8 $ Text.pack $ show $ pretty h let sref = show $ pretty h let ref = Text.pack sref let suff = ["repo", sref] let url = path (hrefBase <> suff) div_ [class_ "repo-list-item"] do div_ [class_ "repo-info"] do h2_ [class_ "xclip", onClickCopy ref] $ toHtml (s <> "-" <> refpart) p_ $ a_ [href_ url] (toHtml ref) renderMarkdown b wrapped :: Monad m => HtmlT m a -> HtmlT m a wrapped f = do doctypehtml_ do head_ mempty do meta_ [charset_ "utf-8"] body_ mempty f renderRepoHtml :: Monad m => PluginMethod -> GitRepoPage -> m ByteString renderRepoHtml (Method _ kw) page@(GitRepoPage{..}) = pure $ renderBS $ wrapped do let mf = headDef "" [ fromMaybe "" s | GitManifest s <- universeBi page ] & Text.lines & List.dropWhile (not . Text.null) & Text.unlines let name' = coerce @_ @(Maybe Text) repoPageName let brief = coerce @_ @(Maybe Text) repoPageBrief & fromMaybe "" main_ do nav_ [ role_ "tab-control", tabClick ] do ul_ do li_ [] $ label_ [Html.for_ "tab1", class_ "tab active"] "manifest" li_ [] $ label_ [Html.for_ "tab2", class_ "tab"] "Tab 2" li_ [] $ label_ [Html.for_ "tab3", class_ "tab"] "Tab 3" li_ [] $ label_ [Html.for_ "tab4", class_ "tab"] "Tab 4" div_ [ role_ "tabs" ] do pure () -- div_ [ id_ "tabs" -- , term "hx-get" "manifest" -- , term "hx-trigger" "load delay:100ms" -- , term "hx-target" "#tabs" -- , term "hx-swap" "innerHTML" -- ] do -- div_ [class_ "tab-list", role_ "tablist"] do -- button_ [ class_ "selected" -- , role_ "tab" -- , term "hx-get" "manifest" -- , term "aria-selected" "false" -- , term "aria-controls" "tab-content" -- ] "Manifest" -- div_ [id_ "tab-content", role_ "tabpanel", class_ "tab-content"] do -- [qc| -- Commodo normcore truffaut VHS duis gluten-free keffiyeh iPhone taxidermy godard ramps anim pour-over. -- Pitchfork vegan mollit umami quinoa aute aliquip kinfolk eiusmod live-edge cardigan ipsum locavore. -- Polaroid duis occaecat narwhal small batch food truck. -- PBR&B venmo shaman small batch you probably haven't heard of them hot chicken readymade. -- Enim tousled cliche woke, typewriter single-origin coffee hella culpa. -- Art party readymade 90's, asymmetrical hell of fingerstache ipsum. -- |] -- pure () -- section_ [id_ "repo-data"] do -- for_ name' $ \name -> do -- h1_ (toHtml name) -- renderMarkdown brief -- table_ do -- tr_ do -- th_ "code/hbs2:" -- td_ mempty -- pure () -- section_ [id_ "repo-manifest-text"] do -- renderMarkdown mf