path: root/hs/Html.hs

{-# LANGUAGE OverloadedStrings
           , ImportQualifiedPost
           , ScopedTypeVariables
           #-}

module Html
( main
) where

import System.Environment (getArgs, lookupEnv)
import System.FilePath
    ( joinPath
    , takeDirectory
    , (</>)
    , (-<.>)
    , (<.>)
    , hasExtension
    , dropExtension
    , takeBaseName
    )
import System.Directory (copyFile)

import Text.Pandoc
    ( PandocMonad
    , PandocIO
    -- , ReaderOptions( readerStandalone
    --                )
    -- , WriterOptions( writerTemplate
    --                , writerTableOfContents
    --                , writerVariables
    --                )
    , runIOorExplode
    -- , compileDefaultTemplate
    -- , compileTemplate
    -- , getTemplate
    , writeHtml5
    , readVimwiki
    , toLang
    , setTranslations
    )

-- import Text.Pandoc.Class
--     ( getsCommonState
--     , CommonState(stLog)
--     )

import Text.Pandoc.Shared (stringify)

import Text.Pandoc.Writers.Shared
    ( toTableOfContents
    , lookupMetaString
    )

import System.IO (readFile')
import Data.Text (Text, unpack, pack)
import Data.Text.IO qualified as T
import Data.Text.Lazy (toStrict)
--import Network.URI --(parseURI, uriPath, uriScheme, uriFragment, uriQuery, uriAuthority, URI, URIAuth)
import Network.URI hiding (query)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.List (partition)

import Control.Monad.IO.Class (liftIO)

import Data.Default (def)

-- import Text.Blaze
import Text.Blaze.Html ()
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Pandoc.Walk
    ( Walkable (..)
    , walk )

import Text.Blaze.Html5 hiding (main, html)
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes
import Text.Blaze.Html5.Attributes qualified as A

import Text.Pandoc.Definition
    ( Pandoc (Pandoc)
    , Inline (..)
    , Block (..)
    , Format(Format)
    )
-- import Text.Pandoc.Builder

import Files
import Links
import Util

-- import Text.DocTemplates (Context(..), ToContext(toVal))
import Data.Map qualified as M
import Data.Set (Set)
import Data.Set qualified as S
import Data.String (IsString)


isWikiFile = isFiletype "wiki"

-- TODO
-- Colorful headers?
-- All headers should link to themselves

{-
vimwikiToHTML :: Text -> IO Text
-- vimwikiToHTML txt = runIOorExplode $ do
--     pdoc <- readVimwiki def txt
--     html <- writeHtml5 def pdoc
--     return $ toStrict . renderHtml $ html
vimwikiToHTML txt = do
    pdoc <- runIOorExplode $ readVimwiki def txt
    print pdoc
    html <- runIOorExplode $ writeHtml5 def pdoc
    return $ toStrict . renderHtml $ html
-}

data Configuration = Configuration
    { inputDir :: FilePath
    , outputDir :: FilePath
    -- Are we in a subdirectory from the web root?
    -- /tmp/wiki
    , webPath :: Text
    -- http://localhost:8090/
    , mu4eURL :: Text
    -- http://wiki.gandalf.adrift.space/search
    , xapianOmega :: Text
    } deriving (Read, Show)

type UrlRewriter = [Inline] -> URI -> ([Inline], Text)

mailRewriter :: Configuration -> UrlRewriter
mailRewriter conf body uri = (body, (mu4eURL conf) <> "?id=" <> (pack $ uriPath uri))

-- Comparison of online man pages:
-- https://gist.github.com/rixx/6cb5fa38f694009ad0bd50c275bb61f2

archMan :: (Semigroup a, IsString a) => a -> Maybe a -> Maybe a -> a
archMan page section' language'
    = "https://man.archlinux.org/man/" <> page <> f section' <> f language'
    where f = fromMaybe "" . fmap ("." <>)

mannedMan :: (Semigroup a, IsString a) => a -> Maybe a -> Maybe a -> a
mannedMan page section' language'
    = "https://manned.org/man" <> f language' <> "/" <> page <> f section'
    where f = fromMaybe "" . fmap ("." <>)

manRewriter :: UrlRewriter
manRewriter _ uri
    = ([Str $ path <> "(" <> (fromMaybe "?" section') <> ")"]
      , mannedMan path section' language')
    where path :: Text
          path = pack $ uriPath uri
          section'  = pack . tail <$> nullToMaybe (uriFragment uri)
          language' = pack . tail <$> nullToMaybe (uriQuery uri)

urlRewrites :: Configuration -> M.Map String UrlRewriter
urlRewrites conf = M.fromList [ ("mail", mailRewriter conf)
                              , ("man", manRewriter)
                              ]


-- -- TODO don't do this for inter-page links
-- | otherwise = Link attributes body (url <> ".html", title)

fixExtension url
    | hasExtension url = url
    | otherwise = url <.> "html"


-- TODO make this part of the configuration
resolveInterwiki :: String -> URI -> String
resolveInterwiki wikiname uri =
    case wikiname of
        "public"  -> show $ uri { uriScheme = "http:", uriAuthority = Just $ URIAuth "" "//wiki.gandalf.adrift.space" "", uriPath = "/" <> uriPath uri <> ".html" }
        "private" -> show $ uri { uriScheme = "http:", uriAuthority = Just $ URIAuth "" "//wiki.gandalf.adrift.space" "", uriPath = "/private/" <> uriPath uri <> ".html" }
        _         -> error $ "Unknown Wiki name: '" <> wikiname <> "'"



rebuildLinks :: Configuration -> Inline -> Inline
rebuildLinks conf l@(Link attributes body (url, title@"wikilink"))
    = case parseURI . unpack $ url of
        Just uri -> case uriScheme uri of
                        ('w':'n':'.':wikiname') -> let wikiname = init wikiname'
                                                   in Link attributes
                                                       [ Str . pack . uriPath $ uri
                                                       , Superscript [Str $ pack wikiname]]
                                                       (pack $ resolveInterwiki wikiname uri, title)
                        _ -> case M.lookup (init . uriScheme $ uri) (urlRewrites conf) of
                                Just proc -> (proc body uri) & (\(body, url) -> Link attributes body (url, title))
                                Nothing   -> l -- Link attributes body (url <> ".html", title)
        Nothing -> case break (== '#') (unpack url) of
                ("", '#':_)       -> Link attributes body (url, title)
                (page, "")        -> Link attributes body (pack $ fixExtension page, title)
                (page, '#':local) -> Link attributes body (pack $ fixExtension page <> "#" <> local, title)
                _                 -> l
rebuildLinks _ l = l

-- Link ("",[],[]) [Str "#M\246te 7"] ("#M\246te 7","wikilink")
-- Link ("",[],[]) [Str "https://styrdokument.liu.se/Regelsamling/Fil/1513619"] ("https://styrdokument.liu.se/Regelsamling/Fil/1513619","")
-- Link ("",[],[]) [Str "Beslut",Space,Str "LIU-2020-02033"] ("file:LinTek/2021/Beslut om riktlinjer och rutiner f\246r genomf\246rande av skriftliga salsskrivningar inklusive digitala tent.pdf","wikilink")

checkbox extra = RawInline (Format "html")
               $ "<input type='checkbox' disabled='true' " <> extra <> "/>"

-- buildCheckboxes s@(Span (ids, cls, kvs) _)
buildCheckboxes s@(Span (_, cls, _) _)
    | "done0" `elem` cls = checkbox ""
    | "done1" `elem` cls = checkbox ""
    | "done2" `elem` cls = checkbox ""
    | "done3" `elem` cls = checkbox ""
    | "done4" `elem` cls = checkbox "checked"
    | otherwise = s
buildCheckboxes l = l

buildCheckboxes' (Plain (Str "[-]" : Space : xs))
    = Plain [ checkbox "checked", Strikeout xs ]
buildCheckboxes' l = l

applyFilters :: Configuration -> Pandoc -> Pandoc
applyFilters conf pandoc = pandoc
                         & walk (rebuildLinks conf)
                         & walk buildCheckboxes
                         & walk buildCheckboxes'

handleSourceText :: PandocMonad m => Configuration -> Text -> m Pandoc
handleSourceText conf text = do
    pandoc <- readVimwiki def text

    --runIO $ print . show $ pandoc
    -- Pandoc (Meta {unMeta = fromList [ ("date",MetaInlines [Str "2000-01-01"])
    --                                 , ("title",MetaInlines [Str "Custom",Space,Str "Title"])]})
    --         [ Header 1 ("Test Wiki",[],[]) [Str "Test",Space,Str "Wiki"]
    --         , Header 1 ("Generated Tags",[],[]) [Str "Generated",Space,Str "Tags"]]

    let Pandoc meta blocks = pandoc
    -- let pandoc = Pandoc (meta & setMeta "lang" ("sv-SE"::Text)) blocks
    let pandoc = Pandoc meta blocks

    let pandoc' = pandoc
                & (applyFilters conf)
                -- & setTitle (str "Some form of title")
                -- & setAuthors [ str "Hugo Hörnquist" ]
                -- & setDate (str "2022-01-26")

    -- template <- compileDefaultTemplate "html5"
    {-
    templateData <- getTemplate "template.html5"
    template' <- compileTemplate "template.html5" templateData
    template <- case template' of
      Left err       -> error err
      Right template -> return template
      -}

    return pandoc'

-- Becomes wikilink when the URI scheme doesn't match one of
-- Text.Pandoc.Shared (schemes)
-- Link (_,_,_) _ (_, "wikilink")

breadcrumbLinks :: Configuration -> [FilePath] -> [String]
breadcrumbLinks conf parts = f <$> (accumulate $ (unpack $ webPath conf) : parts)
    where f parts = joinBy "/" parts -<.> "html"

buildBreadcrumbs :: [String] -> [Html]
buildBreadcrumbs links = f <$> links
    where f :: String -> Html
          f link = H.a ! href (textValue . pack $ link)
                        $ H.string (takeBaseName link)


htmlWrap :: Configuration -> String -> [FilePath] -> Html -> Html -> Html -> Html
htmlWrap conf title parts backlinks toc main = docTypeHtml $ do
  H.head $ do
    H.meta ! charset "utf-8"
    H.meta ! name "generator" ! content "pandoc"
    H.meta ! name "viewport" ! content "width=device-width, initial-scale=1.0, user-scalable=yes"
    H.link ! rel "stylesheet" ! (href . textValue $ webPath conf <> "/style.css")
    H.script ! (A.src . textValue $ (webPath conf <> "/script.js")) $ mempty
    H.title $ H.string $ title <> " — Vimwiki"
  H.body $ do
    H.header $ do
        H.nav ! A.id "breadcrumb" $ do
            let bc = (buildBreadcrumbs . breadcrumbLinks conf $ init parts)
            let all = mconcat [ [ H.a ! (href . textValue $ webPath conf <> "/index.html")
                                      $ "⌂" ]
                              , tail bc
                              , [ H.span $ H.string . takeBaseName . last $ parts ] ]
            mconcat $ intersperse (H.string "»") all
        H.nav ! A.id "search" $ do
            H.form ! A.method "GET"
                   ! A.action (textValue . xapianOmega $ conf)
                   $ do
                     H.input ! A.type_ "search" ! A.name "P" ! A.placeholder "Sök..."
                     H.input ! A.type_ "submit" ! A.value "Sök"
    H.div ! A.id "with-resizer" $ do
        H.main $ main
        H.div ! A.id "resizer" $ do
            H.div ! A.id "resize-handle" $ "<>"
        H.nav ! A.id "TOC" ! role "doc-toc" $ do
          H.div $ do
              H.h2 ! A.id "toc-title" $ "Table of Contents"
              toc
    H.footer $ do
        backlinks



allHeaders :: Pandoc -> [Block]
allHeaders = query f
    where f h@(Header {}) = [h]
          f _ = []


headerContent :: Block -> Maybe Text
headerContent (Header _ _ inlines) = Just $ stringify inlines
headerContent _ = Nothing



handlePart :: Configuration -> FilePath -> M.Map Text (Set FilePath) -> FilePath -> [FilePath] -> PandocIO ()
handlePart conf outdir backlinks wiki_root parts = do
    let item_path = joinPath parts
    let inTarget  = wiki_root   </> item_path
    let outTarget = outdir </> item_path -<.> "html"
    liftIO $ mkdirP . takeDirectory $ outTarget

    text <- liftIO $ T.readFile inTarget

    bl <- case M.lookup (pack . dropExtension $ item_path) backlinks of
      Just links -> return $ (H.h2 . H.string  $ "Backlinks")
                             <> (H.ul . mconcat $ (H.li . toHtml) <$> (S.toList links))
      Nothing -> return $ H.b "No backlinks"

    pandoc <- handleSourceText conf text
    let Pandoc meta blocks = pandoc
    toc <- writeHtml5 def $ Pandoc meta $ [toTableOfContents def blocks]
    -- writeHtml5 htmlAttr pandoc
    html <- writeHtml5 def pandoc
    -- Since we (explicitly) don't reset the state between invocations
    -- the list of log entries continues to grow. We could check if
    -- before and after, and check if it is langer
    -- log <- getsCommonState stLog
    -- liftIO $ print meta
    let title :: Text = firstJust (pack $ takeBaseName item_path)
                          [ nullToMaybe $ lookupMetaString "title" meta
                          , headerContent =<< (listToMaybe $ allHeaders pandoc)
                          ]

    -- liftIO $ print log
    let htmlString = toStrict . renderHtml . htmlWrap conf (unpack title) parts bl toc $ html
    liftIO $ T.writeFile outTarget htmlString



main = do
    args <- getArgs
    (indir, outdir) <- case args of
        [indir, outdir] -> return (indir, outdir)
        _ -> error "Usage: vimwiki <indir> <outdir>"
    (wiki_files, other_files) <- partition (uncurry isWikiFile) <$> fileTree [ indir ]
    -- TODO copy remaining files verbatim
    -- st <- getFileStatus $ indir </> "Vimwiki.wiki"
    -- wiki_files <- return $ [(st, snoc [ indir ] "Vimwiki.wiki")]
    let relative_paths = tail . snd <$> wiki_files

    webPath <- pack . fromMaybe "" <$> lookupEnv "WEB_PATH"

    conf' <- (read :: String -> Configuration) <$> readFile' "config.hs"
    let conf = conf' { inputDir = indir
                     , outputDir = outdir
                     -- , webPath = "/tmp/wiki"
                     , webPath = webPath
                     }

    copyFile "style2.css" (outputDir conf <> "/style.css")
    copyFile "script.js" (outputDir conf <> "/script.js")

    -- What each page links to
    -- forwardLinks :: [(FilePath, [String])]
    forwardLinks <- runIOorExplode $ mapM (findLinks indir) relative_paths
    -- TODO backlinks should look at basename of filename, for both
    -- link and target.
    -- http://wiki.gandalf.adrift.space/Lysator/Styrelse/wi_1233359070.html
    let backlinks = M.unions $ uncurry buildBacklinkSet <$> forwardLinks

    --print backlinks

    runIOorExplode $ do
        mlang <- toLang $ Just "sv-SE"
        case mlang of
            Nothing -> return ()
            Just l -> setTranslations l

        mapM_ (handlePart conf outdir backlinks indir) relative_paths
    -- mapM_ (putStrLn . show) wiki_files