{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Hearth (renderPage, handleForm, markAsRead, utf8, Link) where

import Text.Ginger.Parse (parseGingerFile, SourcePos)
import Text.Ginger.Run (runGinger, makeContextHtml, Run)
import Text.Ginger.Html (htmlSource, Html)
import Text.Ginger.GVal as V (toGVal, orderedDict, (~>), GVal)
import Control.Monad.Writer.Lazy (Writer)

import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Txt
import qualified Data.Text.Encoding as Txt
import Data.FileEmbed
import System.FilePath (normalise, (</>))

import qualified Data.Aeson as JS
import qualified Data.Aeson.KeyMap as JS
import qualified Data.Vector as V
import Data.String (fromString)
import Data.Maybe (fromMaybe)
import Debug.Trace (traceShow) -- For error reporting!

import Hearth.TopSites
import Network.URI (uriToString)
import Data.Aeson (Value(..), Object, toJSON)

renderPage :: ByteString -> [(ByteString, Maybe ByteString)] -> [Txt.Text] ->
        [Link] -> Value -> Maybe Txt.Text
renderPage path query langs hist db = case parseGingerFile resolveSource $ utf8 path of
    Just (Right tpl) -> do
      Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt
    Just (Left err) -> traceShow err Nothing
    Nothing -> Nothing
  where
    ctxt :: Txt.Text -> GVal (Run SourcePos (Writer Html) Html)
    ctxt "Q" = orderedDict [utf8' k~>v | (k, v) <- query]
    ctxt "D" = toGVal db
    ctxt "_" = toGVal $ translations langs
    ctxt "tops" = list' [hist2gval entry | entry <- take 20 $ topsites hist]
    ctxt "hist" = list' $ map hist2gval $ siteHistory hist
    ctxt _ = toGVal ()
    hist2gval entry@(label, href, time) = orderedDict [
            "label"~>label,
            "href"~>uriToString id href "",
            "time"~>time,
            "count"~>countVisits entry hist]

resolveSource :: FilePath -> Maybe (Maybe [Char])
resolveSource path
    | ret@(Just _) <- resolveSource' path = Just ret
    | ret@(Just _) <- resolveSource' (path </> "index.html") = Just ret
    | otherwise = Nothing
resolveSource' :: FilePath -> Maybe [Char]
resolveSource' = fmap utf8 .
    flip lookup $(makeRelativeToProject "tpl" >>= embedDir) . tail . normalise

-- | Convert from UTF-8 bytestring to a string.
utf8 :: ByteString -> String
utf8 = Txt.unpack . Txt.decodeUtf8
utf8' :: ByteString -> Txt.Text
utf8' = Txt.decodeUtf8

translations :: [Txt.Text] -> JS.Value
translations (lang:langs)
    | Just file <- lookup (Txt.unpack lang ++ ".json") files,
        Just ret <- JS.decode $ LBS.fromStrict file = ret
    | "-" `Txt.isInfixOf` lang = let (lang', _) = Txt.breakOn "-" lang
        in translations (lang':langs)
    | otherwise = translations langs
  where files = $(makeRelativeToProject "i18n" >>= embedDir)
translations [] = JS.Null

-- | Type-constrained conversion of a list to Ginger's datamodel,
-- serves to avoid type-inference issues.
list' :: [GVal m] -> GVal m
list' = toGVal

------
--- Interactive features
------

markAsRead :: ByteString -> Value -> Value
markAsRead dest Null = markAsRead dest $ Object $ JS.empty
markAsRead dest (Object db) = Object $ JS.insert "readingList" readingList' db
  where
    readingList' | Just (Array list) <- JS.lookup "readingList" db =
            toJSON $ V.filter isn'tDest list
        | otherwise = Array V.empty
    isn'tDest (Object record) = JS.lookup "href" record /= Just (String $ utf8' dest)
    isn'tDest _ = True
markAsRead _ db = db

handleForm :: ByteString -> [(ByteString, ByteString)] -> Value -> IO (ByteString, Value)
handleForm path query Null = handleForm path query $ Object $ JS.empty
handleForm "/" query db = return (fromMaybe "/" $ lookup "url" query, db)
handleForm "/index.html" query db = return (fromMaybe "/" $ lookup "url" query, db)
handleForm "/bookmarks/read-later" query (Object db) =
    return ("/", Object $ insertConcat "readingList" (query2json query) db)
handleForm path _ db = return (path, db)

query2json :: [(ByteString, ByteString)] -> Value
query2json query = Object $ JS.fromListWith gatherArray
        [(fromString $ utf8 k, toJSON $ utf8 v) | (k, v) <- query]
    where
        gatherArray (Array a) (Array b) = Array $ b V.++ a
        gatherArray a (Array b) = Array $ V.snoc b a
        gatherArray (Array a) b = Array $ V.cons b a
        gatherArray a b = Array $ V.fromList [b, a]
insertConcat :: JS.Key -> Value -> Object -> Object
insertConcat key val = JS.insertWith prependJSON key (toJSON [val])
  where
    prependJSON (Array a) (Array b) = Array $ a V.++ b
    prependJSON a (Array b) = Array $ V.cons a b
    prependJSON (Array a) b = Array $ V.snoc a b
    prependJSON a b = Array $ V.fromList [a, b]