{-# LANGUAGE OverloadedStrings #-}

module Language.Ltml.HTML.Export
    ( -- * Build ZIP Archive
      renderZip
    ) where

import Clay (render)
import Codec.Archive.Zip
import Data.ByteString.Lazy (ByteString)
import Data.Text (unpack)
import Data.Text.IO (writeFile)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Language.Ltml.AST.DocumentContainer (DocumentContainer)
import Language.Ltml.Common (Flagged')
import Language.Ltml.HTML
import Language.Ltml.HTML.CSS.Util
import Language.Ltml.HTML.Common
import Language.Ltml.HTML.Util
import Lucid
import System.Directory
import System.FilePath.Posix
import Prelude hiding (writeFile)

-- ReaderState felder mit wrapperFunktionen für:
--  - <a> für Section Headings (Sprung zur Einzelansicht)

-- @
-- <path>/
--     <mainDirectoryName>/
--         <realtiveCssFilePath>/
--             style.css
--         index.html
--         <relativeSectionDir>/
--             section1.html
--             section2.html
--             ...
-- @

mainDirectoryName :: FilePath
mainDirectoryName :: FilePath
mainDirectoryName = FilePath
"doc"

-- | Path to main CSS file relative to the index.html
relativeCssFilePath :: FilePath
relativeCssFilePath :: FilePath
relativeCssFilePath = FilePath
"css" FilePath -> FilePath -> FilePath
</> FilePath
"style.css"

-- | Directory which holds all subppages relative to the index.html
relativeSectionsDir :: FilePath
relativeSectionsDir :: FilePath
relativeSectionsDir = FilePath
"sections"

exportReaderState :: ReaderState
exportReaderState :: ReaderState
exportReaderState =
    ReaderState
initReaderState
        { shouldRender = True
        , labelWrapperFunc = anchorLink
        , footnoteWrapperFunc = anchorLink
        , tocEntryWrapperFunc = const anchorLink -- ignore category
        , tocButtonWrapperFunc = pageLink relativeSectionsDir
        , exportLinkWrapper = exportLink relativeSectionsDir
        }

exportSectionReaderState :: ReaderState
exportSectionReaderState :: ReaderState
exportSectionReaderState =
    ReaderState
exportReaderState
        { labelWrapperFunc =
            mainPageAnchorLink (disjointRelative relativeSectionsDir "index.html")
        , exportLinkWrapper = const mempty -- no export links in exported view
        }

-------------------------------------------------------------------------------

-- TODO: Maybe for instantly self hosting

-- | Exports WHOLE document structure as HTML pages to given directory path
exportDocument :: Flagged' DocumentContainer -> FilePath -> IO ()
exportDocument :: Flagged' DocumentContainer -> FilePath -> IO ()
exportDocument Flagged' DocumentContainer
docCon FilePath
path =
    let mainDir :: FilePath
mainDir = FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
mainDirectoryName
        absCssFilePath :: FilePath
absCssFilePath = FilePath
mainDir FilePath -> FilePath -> FilePath
</> FilePath
relativeCssFilePath
        absSectionsDir :: FilePath
absSectionsDir = FilePath
mainDir FilePath -> FilePath -> FilePath
</> FilePath
relativeSectionsDir
        (Html ()
body, Css
css) = ReaderState
-> GlobalState -> Flagged' DocumentContainer -> (Html (), Css)
renderHtmlCssWith ReaderState
exportReaderState GlobalState
initGlobalState Flagged' DocumentContainer
docCon
        -- TODO: Get real Doc Title
        mainHtml :: Html ()
mainHtml = FilePath -> FilePath -> Html () -> Html ()
forall title.
ToHtml title =>
title -> FilePath -> Html () -> Html ()
addHtmlHeader (FilePath
"Temp Title" :: String) FilePath
relativeCssFilePath Html ()
body
     in do
            Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
path
            Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
absCssFilePath)
            Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
absSectionsDir

            FilePath -> Text -> IO ()
writeFile FilePath
absCssFilePath (LazyText -> Text
toStrict (LazyText -> Text) -> LazyText -> Text
forall a b. (a -> b) -> a -> b
$ Css -> LazyText
render Css
css)
            FilePath -> Html () -> IO ()
forall a. FilePath -> Html a -> IO ()
renderToFile (FilePath
mainDir FilePath -> FilePath -> FilePath
</> FilePath
"index.html") Html ()
mainHtml

-- | Renders WHOLE document structure as HTML pages to zip archive (as 'ByteString');
--   Returns @Nothing@, if AST contains any parse errors.
renderZip :: Flagged' DocumentContainer -> IO (Maybe ByteString)
renderZip :: Flagged' DocumentContainer -> IO (Maybe ByteString)
renderZip Flagged' DocumentContainer
docCon =
    -- TODO: check if Label "errors" occured not only parse erros
    let relativeHomePath :: FilePath
relativeHomePath = FilePath -> FilePath -> FilePath
disjointRelative FilePath
relativeSectionsDir FilePath
"index.html"
        mHtmlCssParts :: Maybe (Html (), Css, [(Text, Text, Html ())], Text)
mHtmlCssParts =
            FilePath
-> ReaderState
-> GlobalState
-> ReaderState
-> Flagged' DocumentContainer
-> Maybe (Html (), Css, [(Text, Text, Html ())], Text)
renderHtmlCssExport
                FilePath
relativeHomePath
                ReaderState
exportReaderState
                GlobalState
initGlobalState
                ReaderState
exportSectionReaderState
                Flagged' DocumentContainer
docCon
     in IO (Maybe ByteString)
-> ((Html (), Css, [(Text, Text, Html ())], Text)
    -> IO (Maybe ByteString))
-> Maybe (Html (), Css, [(Text, Text, Html ())], Text)
-> IO (Maybe ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing) ((ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (IO ByteString -> IO (Maybe ByteString))
-> ((Html (), Css, [(Text, Text, Html ())], Text) -> IO ByteString)
-> (Html (), Css, [(Text, Text, Html ())], Text)
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html (), Css, [(Text, Text, Html ())], Text) -> IO ByteString
forall {title} {d}.
(ToHtml title, ToHtml d) =>
(Html (), Css, [(Text, title, Html ())], d) -> IO ByteString
buildZip) Maybe (Html (), Css, [(Text, Text, Html ())], Text)
mHtmlCssParts
  where
    buildZip :: (Html (), Css, [(Text, title, Html ())], d) -> IO ByteString
buildZip (Html ()
mainBody, Css
css, [(Text, title, Html ())]
sectionBodies, d
rawTitle) =
        let
            mainHtml :: Html ()
mainHtml = d -> FilePath -> Html () -> Html ()
forall title.
ToHtml title =>
title -> FilePath -> Html () -> Html ()
addHtmlHeader d
rawTitle FilePath
relativeCssFilePath Html ()
mainBody
            mainBS :: ByteString
mainBS = Html () -> ByteString
forall a. Html a -> ByteString
renderBS Html ()
mainHtml
            stylesheetBS :: ByteString
stylesheetBS = LazyText -> ByteString
encodeUtf8 (LazyText -> ByteString) -> LazyText -> ByteString
forall a b. (a -> b) -> a -> b
$ Css -> LazyText
render Css
css
            sectionRelativeCssPath :: FilePath
sectionRelativeCssPath = FilePath -> FilePath -> FilePath
disjointRelative FilePath
relativeSectionsDir FilePath
relativeCssFilePath
            sectionPathBS :: [(FilePath, ByteString)]
sectionPathBS =
                ((Text, title, Html ()) -> (FilePath, ByteString))
-> [(Text, title, Html ())] -> [(FilePath, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map
                    ( \(Text
tocId, title
title, Html ()
html) ->
                        ( FilePath
relativeSectionsDir FilePath -> FilePath -> FilePath
</> Text -> FilePath
unpack Text
tocId FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".html"
                        , Html () -> ByteString
forall a. Html a -> ByteString
renderBS (Html () -> ByteString) -> Html () -> ByteString
forall a b. (a -> b) -> a -> b
$ title -> FilePath -> Html () -> Html ()
forall title.
ToHtml title =>
title -> FilePath -> Html () -> Html ()
addHtmlHeader title
title FilePath
sectionRelativeCssPath Html ()
html
                        )
                    )
                    [(Text, title, Html ())]
sectionBodies
            files :: [(FilePath, ByteString)]
files =
                [ (FilePath
"index.html", ByteString
mainBS)
                , (FilePath
relativeCssFilePath, ByteString
stylesheetBS)
                ]
                    [(FilePath, ByteString)]
-> [(FilePath, ByteString)] -> [(FilePath, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, ByteString)]
sectionPathBS
         in
            do
                Integer
currentTime <- POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer) -> IO POSIXTime -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
                let entries :: [Entry]
entries = ((FilePath, ByteString) -> Entry)
-> [(FilePath, ByteString)] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map (\(FilePath
path, ByteString
bs) -> FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
path Integer
currentTime ByteString
bs) [(FilePath, ByteString)]
files
                    archive :: Archive
archive = (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
emptyArchive [Entry]
entries
                ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Archive -> ByteString
fromArchive Archive
archive