{-# LANGUAGE OverloadedStrings, TemplateHaskell, FlexibleContexts #-}
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(..), fromFunction)
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 Hearth.Tagging
import Network.URI (uriToString, parseAbsoluteURI, isUnescapedInURIComponent, escapeURIString)
import Data.Aeson (Value(..), Object, toJSON)
import Data.List (sortOn)
import qualified Data.Map as M
import Data.Tuple (Solo(..))

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, k' == k]
            | (k, _) <- query
        ]
    ctxt "D" = toGVal db
    ctxt "tags" = list' $ reverse $ sortOn getCount [
            orderedDict ["label"~>k, "count"~>v,
                "selected"~>(k `elem` map utf8' tags)]
            | (k, v) <- M.toList $ gatherTagsFromProperty "favs" db tags
        ]
    ctxt "alltags" = list' $ reverse $ sortOn getCount [
            orderedDict ["label"~>k, "count"~>v]
            | (k, v) <- M.toList $ gatherTagsFromProperty "favs" db []
        ]
    ctxt "_" = toGVal $ translations langs
    ctxt "tops" = list' [hist2gval entry | entry <- take 20 $ topsites hist]
    ctxt "hist" = list' $ map hist2gval $ siteHistory hist
    ctxt "sortByVisits" = fromFunction sortByVisits
    ctxt "containsAll" = fromFunction containsAll
    ctxt "urlquery" = fromFunction $ return . toGVal . urlquery
    ctxt _ = toGVal ()
    hist2gval entry@(label, href, time) = orderedDict [
            "label"~>label,
            "href"~>uriToString id href "",
            "time"~>time,
            "count"~>countVisits entry hist]
    sortByVisits [(_, self)]
        | Just self' <- asList self = return $ toGVal $ reverse $ sortOn inner self'
      where
        inner entry
            | Just get <- asLookup entry, Just page <- get "href",
                    Just href <- parseAbsoluteURI $ Txt.unpack $ asText page =
                countVisitsPage href hist
            | otherwise = 0
    sortByVisits _ = return $ toGVal ()
    getCount self
        | Just get <- asLookup self, Just ret <- asNumber =<< get "count" = ret
        | otherwise = 0
    containsAll [(_, haystack), (_, needles)] =
        let needles' = filter (/= "") $ map asText $ fromMaybe [] $ asList needles
            haystack' = map asText $ fromMaybe [haystack] $ asList haystack
        in return $ toGVal $ all (flip elem haystack') needles'
    containsAll _ = return $ toGVal ()
    urlquery [(_, self)] | Just self' <- asDictItems self = Txt.intercalate "&" [
            Txt.concat [k, "=", escapeURIText $ asText v]
            | (k, vs) <- self', v <- fromMaybe [vs] $ asList vs
        ] where
            escapeURIText = withString $ escapeURIString isUnescapedInURIComponent
            withString f = Txt.pack . f . Txt.unpack
    urlquery _ = ""
    getQuery key = [v | (k, Just v) <- query, k == key]
    tags = getQuery "tag"

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 "/bookmarks/new.html" query (Object db) =
    return ("/", Object $ insertConcat "favs" (query2json query) $
            removeFav (lookup "href" query) db)
handleForm "/bookmarks/del" query (Object db) =
    return ("/", Object $ removeFav (lookup "href" 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]
removeFav :: Maybe ByteString -> Object -> Object
removeFav (Just href) db | Solo ret <- JS.alterF inner "favs" db = ret
  where
    inner (Just (Array favs)) = Solo $ Just $ toJSON $ V.filter isn'tTarget favs
    inner (Just fav) | isn'tTarget fav = Solo $ Just fav
    inner _ = Solo $ Nothing
    isn'tTarget (Object record) =
        JS.lookup "href" record /= Just (String $ utf8' href)
    isn'tTarget _ = True
removeFav _ db = db