path: root/hs/src/Html.hs

{-# LANGUAGE OverloadedStrings
           , ScopedTypeVariables
           , TupleSections
           , CPP
           #-}

module Html
( main
) where

import System.FilePath
    ( joinPath
    , (-<.>)
    , (<.>)
    , (</>)
    , dropExtension
    , hasExtension
    , hasTrailingPathSeparator
    , isRelative
    , takeBaseName
    , takeDirectory
    )
import Control.Lens (_2)
import Control.Lens.Operators hiding ((<.>))
import Control.Lens.Setter (ASetter)

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)

import Data.Default (def)
import Data.List (partition)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (listToMaybe, fromMaybe, mapMaybe)
import Data.Set (Set, fromList)
import qualified Data.Set as S
import Data.Text (Text, pack)
import qualified Data.Text.IO as T
import Data.Text.Lazy (toStrict)
import Data.Text.Compat (PandocStr, conv, from)

import Network.URI hiding (query)
import Network.URI.Encode (encodeWith)

import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Environment.XDG.BaseDir
  ( getUserConfigDir
  , getUserDataDir
  , getSystemDataDirs
  )

import Text.Blaze (stringValue)
import Text.Blaze.Html5 (Html, toHtml, (!), textValue, docTypeHtml)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes (href, role, rel, content, name, charset)
import qualified Text.Blaze.Html5.Attributes as A

import Text.Blaze.Html.Renderer.Text (renderHtml)

import Text.Pandoc
    ( PandocMonad
    , PandocIO
    , runIOorExplode
    , writeHtml5
    , readVimwiki
    , toLang
    , setTranslations
    , Pandoc (Pandoc)
    , Inline (..)
    , Block (..)
    , Format(Format)
    )

import Text.Pandoc.Shared (stringify)
import Text.Pandoc.Walk (Walkable (..), walk)
import Text.Pandoc.Writers.Shared (
#if MIN_VERSION_pandoc(2, 6, 0)
    toTableOfContents,
#endif
    lookupMetaString)


import Files
import Links
import Util
import Config
-- import System.Home
import Vimwiki.Man

isWikiFile = isFiletype "wiki"

-- TODO
-- - Colorful headers?
-- - All headers should link to themselves
-- - Tilde-expand paths from filenames


mailRewriter :: String -> [Inline] -> URI -> ([Inline], PandocStr)
mailRewriter mu4eURL body uri = (body, conv $ mu4eURL <> "?id=" <> uriPath uri)

-- Pandoc converts local: uri's to file: uri's before we get to
-- them. Assume that relative refs are internal references, and
-- absolute references actual files.
fileRewriter :: [Inline] -> URI -> ([Inline], PandocStr)
fileRewriter inl uri = (inl,) . conv . show
    $ if isRelative (uriPath uri)
        then uri { uriScheme = "" }
        else uri

urlRewrites :: Configuration -> Map String ([Inline] -> URI -> ([Inline], PandocStr))
urlRewrites conf = M.fromList $ mapMaybe sequence
    [ ("mail",  mailRewriter <$> (conf ^. output . mu4eURL))
    -- TODO include descriptive text from
    -- original link
    , ("man", manRewriter <$> ((conf ^. output . manProvider) >>= flip M.lookup rewriters))
    , ("file", Just fileRewriter)
    ]

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


resolveInterwiki :: Map String URI -> String -> URI -> String
resolveInterwiki wikilinks wikiname uri =
    case M.lookup wikiname wikilinks of
        Just uri' ->  show $ uri' { uriPath = uriPath uri' <> fixExtension (uriPath uri) }
        Nothing   -> error $ "Unknown Wiki name: " <> wikiname <> ""


uriChars :: Set Char
uriChars = fromList $ ":/?#"  -- Allows us to modifiy existing URL
                    <> "-._~" -- URL safe
                    <> ['A'..'Z'] <> ['a'..'z'] <> ['0'..'9']

-- See also: Handlingar handleBilaga
rebuildLinks :: Configuration -> Inline -> Inline
rebuildLinks conf l@(Link attributes body (url, title@"wikilink"))
    = case parseURI . encodeWith (`elem` uriChars) . from $ url of
        Just uri -> case uriScheme uri of
                        ('w':'n':'.':wikiname') -> let wikiname = init wikiname'
                                                   in Link attributes
                                                       [ Str . conv . uriPath $ uri
                                                       , Superscript [Str $ conv wikiname]]
                                                       (conv $ resolveInterwiki (conf ^. wikis) 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
        Nothing -> case break (== '#') (from url) of
                ("", '#':_)       -> Link attributes body (url, title)
                (page, "")        -> Link attributes body (conv $ fixExtension page, title)
                (page, '#':local) -> Link attributes body (conv $ fixExtension page <> "#" <> local, title)
                _                 -> l
rebuildLinks _ l = l

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 = applyFilters conf <$> readVimwiki def text

breadcrumbLinks :: Configuration -> [FilePath] -> [String]
breadcrumbLinks conf parts = f <$> accumulate ((conf ^. output . webPath) : 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 -> Maybe Html -> Html -> Html
htmlWrap conf title parts backlinks mtoc 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 $ pack (conf ^. output . webPath <> "/style.css"))
    H.script ! (A.src . textValue $ pack (conf ^. output . webPath <> "/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 $ pack (conf ^. output . webPath) <> "/index.html")
                                      $ "⌂" ]
                              , tail bc
                              , [ H.span $ H.string . takeBaseName . last $ parts ] ]
            mconcat $ intersperse (H.string "»") all
        H.nav ! A.id "search" $
            case conf ^. output . xapianOmega of
                Nothing -> mempty
                Just url -> H.form ! A.method "GET"
                               ! A.action (textValue . pack $ url)
                               $ 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
        case mtoc of
            Just toc -> do
                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
            Nothing -> return mempty
    H.footer $ do
        backlinks



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


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

buildLink :: String -> String -> Html
buildLink disp url = H.a ! A.href (stringValue url)
                         $ toHtml disp


handlePart :: Configuration -> FilePath -> 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

    -- TODO put this behind verobse flag
    -- TODO replace this with a progress bar
    liftIO . putStrLn $ "Building " <> inTarget

    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 ! A.class_ "backlinks"
                                      $ mconcat $ H.li
                                                . uncurry buildLink
                                                . fmap ((<> ".html") . ((conf^.output.webPath) <>) )
                                                . dup <$> S.toList links)
      Nothing -> return $ H.b "No backlinks"

    pandoc <- handleSourceText conf text
    let Pandoc meta blocks = pandoc
#if MIN_VERSION_pandoc(2, 6, 0)
    toc <- fmap Just <$> writeHtml5 def $ Pandoc meta [toTableOfContents def blocks]
#else
    let toc = Nothing
#endif
    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 :: PandocStr = firstJust (conv $ takeBaseName item_path)
                          [ nullToMaybe $ lookupMetaString "title" meta
                          , headerContent =<< listToMaybe (allHeaders pandoc)
                          ]

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


-- Like '.~', but the RHS is only possibly a value. Set the value in
-- the structure when there is one, and do nothing when there isn't
-- one.
(.~?) :: ASetter s s a b -> Maybe b -> s -> s
_    .~? Nothing = id
lens .~? (Just x) = lens .~ x
infixr 4 .~?

stripTrailing :: (Show a, Eq a) => a -> [a] -> [a]
stripTrailing c s
  | null s      = s
  | c == last s = init s
  | otherwise   = s


dup a = (a, a)

filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
filterM f = fmap (fmap fst . filter snd)
          . mapM sequence
          . fmap ((_2 %~ f) . dup)

copyFromDatadir :: FilePath -> [FilePath] -> FilePath -> IO ()
copyFromDatadir filename datadirs destination = do
    let candidates = datadirs <&> (</> filename)
    existing <- filterM doesFileExist candidates
    case existing of
        []       -> error $ filename <> " not found in any of " <> show datadirs
        source:_ -> copyFile source destination


main :: [String] -> IO ()
main args = do
    args <- parseCmdline args

    confDir <- getUserConfigDir "vimwiki"

    confText <- T.readFile $ fromMaybe (confDir </> "config.ini") (conffile args)
    conf' <- case runParser confText of
        Left err -> error err
        Right conf -> return conf

    let conf = conf' & data' . inputDir  .~? indir args
                     & data' . outputDir .~? outdir args
                     & output . webPath  .~? webp args
                     & output . webPath %~ stripTrailing '/'

    -- indir'  <- expandTilde `mapM` indir args
    -- outdir' <- expandTilde `mapM` outdir args

    -- print conf
    when (null $ conf ^. data' . inputDir)
        $ error "No input directory given"

    when (null $ conf ^. data' . outputDir)
        $ error "No output directory given"

    print $ "input = " <> (conf ^. data' . inputDir)
    print $ "output = " <> (conf ^. data' . outputDir)

    (wikiFiles, otherFiles) <- partition (uncurry isWikiFile) <$> fileTree [ conf ^. data' . inputDir ]

    -- mapM_ print otherFiles
    -- TODO ignore hidden files
    copyFiles (conf ^. data' . outputDir) otherFiles

    createDirectoryIfMissing True $ conf ^. data' . outputDir

    userdd <- getUserDataDir "vimwiki"
    systemdds <- getSystemDataDirs "vimwiki"
    let dataDirs = "."
                 : userdd
                 : systemdds
    let od = conf ^. (data' . outputDir)
    copyFromDatadir "style.css" dataDirs $ od </> "style.css"
    copyFromDatadir "script.js" dataDirs $ od </> "script.js"

    -- What each page links to
    -- forwardLinks :: [(FilePath, [String])]
    let relative_paths = tail . snd <$> wikiFiles
    forwardLinks <- runIOorExplode $ mapM (findLinks $ conf ^. data' . inputDir) relative_paths

    let backlinks = M.unions $ uncurry buildBacklinkSet <$> forwardLinks

    runIOorExplode $ do
        mlang <- toLang $ Just "sv-SE"
        mapM_ setTranslations mlang

        mapM_ (handlePart conf (conf^.data'.outputDir) backlinks (conf ^. data' . inputDir)) relative_paths
    -- mapM_ (putStrLn . show) wikiFiles