{-#LANGUAGE DeriveGeneric #-}
{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE OverloadedLists #-}
{-#LANGUAGE LambdaCase #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE FlexibleContexts #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE TypeApplications #-}

module Web.Sprinkles.TemplateContext
where

import Web.Sprinkles.Prelude
import Text.Ginger
       (parseGinger, Template, runGingerT, GingerContext, GVal(..), ToGVal(..),
        (~>))
import Text.Ginger.Html
       (unsafeRawHtml, html)
import qualified Text.Ginger as Ginger
import qualified Data.Yaml as YAML
import Data.Aeson (ToJSON (..), FromJSON (..))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Aeson.Encode.Pretty as JSON
import Data.Default (Default, def)
import Data.Text (Text)
import qualified Data.Text as Text
import System.Locale.Read (getLocale)
import qualified Text.Pandoc as Pandoc
import qualified Text.Pandoc.Readers.CustomCreole as PandocCreole
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
import Data.ByteString.Builder (stringUtf8)
import qualified Network.Wai as Wai
import qualified Data.CaseInsensitive as CI
import Network.HTTP.Types.URI (queryToQueryText)
import qualified Crypto.BCrypt as BCrypt
import Control.Monad.Except (throwError)

import Web.Sprinkles.Pandoc (pandocReaderOptions)
import Web.Sprinkles.Backends
import Web.Sprinkles.Backends.Spec (backendSpecFromJSON)
import Web.Sprinkles.Exceptions
import Web.Sprinkles.Logger as Logger
import Web.Sprinkles.Backends.Loader.Type
       (RequestContext (..), pbsFromRequest, pbsInvalid)
import Web.Sprinkles.SessionHandle
import Data.RandomString (randomStr)

import Text.Printf (printf)

sprinklesGingerContext :: RawBackendCache
                       -> Wai.Request
                       -> Maybe SessionHandle
                       -> Logger
                       -> IO (HashMap Text (GVal (Ginger.Run p IO h)))
sprinklesGingerContext cache request session logger = do
    csrfTokenMay <- case session of
        Nothing -> return Nothing
        Just handle -> sessionGet handle "csrf"
    writeLog logger Debug . pack . printf "CSRF token: %s" . show $ csrfTokenMay
    let csrfTokenInput = case csrfTokenMay of
            Just token ->
                mconcat
                    [ unsafeRawHtml "<input type=\"hidden\" name=\"__form_token\" value=\""
                    , html token
                    , unsafeRawHtml "\"/>"
                    ]
            Nothing ->
                unsafeRawHtml "<!-- no form token defined -->"
    return $ mapFromList
        [ "request" ~> request
        , "session" ~> session
        , "formToken" ~> csrfTokenMay
        , "formTokenInput" ~> csrfTokenInput
        , ("load", Ginger.fromFunction (gfnLoadBackendData (writeLog logger) cache))
        ] <> baseGingerContext logger

baseGingerContext :: Logger
                  -> HashMap Text (GVal (Ginger.Run p IO h))
baseGingerContext logger =
    mapFromList
        [ ("ellipse", Ginger.fromFunction gfnEllipse)
        , ("json", Ginger.fromFunction gfnJSON)
        , ("yaml", Ginger.fromFunction gfnYAML)
        , ("getlocale", Ginger.fromFunction (gfnGetLocale (writeLog logger)))
        , ("pandoc", Ginger.fromFunction (gfnPandoc (writeLog logger)))
        , ("markdown", Ginger.fromFunction (gfnPandocAlias "markdown" (writeLog logger)))
        , ("textile", Ginger.fromFunction (gfnPandocAlias "textile" (writeLog logger)))
        , ("rst", Ginger.fromFunction (gfnPandocAlias "rst" (writeLog logger)))
        , ("creole", Ginger.fromFunction (gfnPandocAlias "creole" (writeLog logger)))
        , ("bcrypt", gnsBCrypt)
        , ("randomStr", Ginger.fromFunction gfnRandomStr)
        ]

gnsBCrypt :: GVal (Ginger.Run p IO h)
gnsBCrypt =
    Ginger.dict
        [ ("hash", Ginger.fromFunction gfnBCryptHash)
        , ("validate", Ginger.fromFunction gfnBCryptValidate)
        ]

gfnBCryptHash :: Ginger.Function (Ginger.Run p IO h)
gfnBCryptHash args = do
    let argSpec :: [(Text, Ginger.GVal (Ginger.Run p IO h))]
        argSpec = [ ("password", def)
                  , ("cost", toGVal (4 :: Int))
                  , ("algorithm", toGVal ("$2y$" :: Text))
                  ]
    case Ginger.extractArgsDefL argSpec args of
        Right [passwordG, costG, algorithmG] -> do
            let password = encodeUtf8 . Ginger.asText $ passwordG
                algorithm = encodeUtf8 . Ginger.asText $ algorithmG
            cost <- maybe
                        (throwM $ GingerInvalidFunctionArgs "bcrypt.hash" "int cost")
                        (return . ceiling)
                        (asNumber costG)
            let policy = BCrypt.HashingPolicy cost algorithm
            hash <- liftIO $ BCrypt.hashPasswordUsingPolicy policy password
            return . toGVal . fmap decodeUtf8 $ hash
        _ -> throwM $ GingerInvalidFunctionArgs "bcrypt.hash" "string password, int cost, string algorithm"

gfnRandomStr :: Ginger.Function (Ginger.Run p IO h)
gfnRandomStr args = do
    let defaultAlphabet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] :: String
        argSpec :: [(Text, Ginger.GVal (Ginger.Run p IO h))]
        argSpec = [ ("length", toGVal (8 :: Int))
                  , ("alphabet", toGVal defaultAlphabet)
                  ]
    case Ginger.extractArgsDefL argSpec args of
        Right [lengthG, alphabetG] -> do
            desiredLength :: Int <- case fmap round . asNumber $ lengthG of
                    Nothing -> throwM $ GingerInvalidFunctionArgs "randomStr" "int length"
                    Just l -> return l
            let alphabet :: String
                alphabet = unpack . Ginger.asText $ alphabetG
            when (null alphabet)
                (throwM $ GingerInvalidFunctionArgs "randomStr" "alphabet too small")
            liftIO $ toGVal <$> randomStr alphabet desiredLength
        _ -> throwM $ GingerInvalidFunctionArgs "randomStr" "int length, string alphabet"

gfnBCryptValidate :: Ginger.Function (Ginger.Run p IO h)
gfnBCryptValidate args = do
    let argSpec :: [(Text, Ginger.GVal (Ginger.Run p IO h))]
        argSpec = [ ("hash", def)
                  , ("password", def)
                  ]
    case Ginger.extractArgsDefL argSpec args of
        Right [hashG, passwordG] -> do
            let hash = encodeUtf8 . Ginger.asText $ hashG
                password = encodeUtf8 . Ginger.asText $ passwordG
            return . toGVal $ BCrypt.validatePassword hash password
        _ -> throwM $ GingerInvalidFunctionArgs "bcrypt.validate" "string password, int cost, string algorithm"

gfnPandoc :: forall p h. (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run p IO h)
gfnPandoc writeLog args = liftIO . catchToGinger writeLog $
    case Ginger.extractArgsDefL [("src", ""), ("reader", "markdown")] args of
        Right [src, readerName] -> toGVal <$> pandoc (Ginger.asText readerName) (Ginger.asText src)
        _ -> throwM $ GingerInvalidFunctionArgs "pandoc" "string src, string reader"

gfnPandocAlias :: forall p h. Text -> (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run p IO h)
gfnPandocAlias readerName writeLog args = liftIO . catchToGinger writeLog $
    case Ginger.extractArgsDefL [("src", "")] args of
        Right [src] -> toGVal <$> pandoc readerName (Ginger.asText src)
        _ -> throwM $ GingerInvalidFunctionArgs "pandoc" "string src, string reader"

pandoc :: Text -> Text -> IO Pandoc.Pandoc
pandoc readerName src = do
    reader <- either
        (\err -> fail $ "Invalid reader: " ++ show err)
        return
        (getReader $ unpack readerName)
    let read = case reader of
            Pandoc.TextReader r ->
              r pandocReaderOptions
            Pandoc.ByteStringReader r ->
              r pandocReaderOptions . encodeUtf8 . fromStrict
    (pure . Pandoc.runPure . read $ src) >>= either
        (\err -> fail $ "Reading " ++ show readerName ++ " failed: " ++ show err)
        return
    where
        getReader :: String -> Either String (Pandoc.Reader Pandoc.PandocPure)
        getReader "creole-tdammers" = customCreoleReader
        getReader readerName = fst <$> Pandoc.getReader readerName

customCreoleReader :: Either String (Pandoc.Reader Pandoc.PandocPure)
customCreoleReader =
  Right . Pandoc.TextReader $ reader
  where
    reader :: Pandoc.ReaderOptions -> Text -> Pandoc.PandocPure Pandoc.Pandoc
    reader opts src =
      either throwError return $
        PandocCreole.readCustomCreole opts (unpack src)

gfnGetLocale :: forall p h. (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run p IO h)
gfnGetLocale writeLog args = liftIO . catchToGinger writeLog $
    case Ginger.extractArgsDefL [("category", "LC_TIME"), ("locale", "")] args of
        Right [gCat, gName] ->
            case (Ginger.asText gCat, Text.unpack . Ginger.asText $ gName) of
                ("LC_TIME", "") -> toGVal <$> getLocale Nothing
                ("LC_TIME", localeName) -> toGVal <$> getLocale (Just localeName)
                (cat, localeName) -> return def -- valid call, but category not implemented
        _ -> throwM $ GingerInvalidFunctionArgs "getlocale" "string category, string name"

gfnEllipse :: Ginger.Function (Ginger.Run p IO h)
gfnEllipse [] = return def
gfnEllipse [(Nothing, str)] =
    gfnEllipse [(Nothing, str), (Nothing, toGVal (100 :: Int))]
gfnEllipse [(Nothing, str), (Nothing, len)] = do
    let txt = Ginger.asText str
        actualLen = Web.Sprinkles.Prelude.length txt
        targetLen = fromMaybe 100 $ ceiling <$> Ginger.asNumber len
        txt' = if actualLen + 3 > targetLen
                    then take (targetLen - 3) txt <> "..."
                    else txt
    return . toGVal $ txt'
gfnEllipse ((Nothing, str):xs) = do
    let len = fromMaybe (toGVal (100 :: Int)) $ lookup (Just "len") xs
    gfnEllipse [(Nothing, str), (Nothing, len)]
gfnEllipse xs = do
    let str = fromMaybe def $ lookup (Just "str") xs
    gfnEllipse $ (Nothing, str):xs

gfnJSON :: Ginger.Function (Ginger.Run p IO h)
gfnJSON ((_, x):_) =
    return . toGVal . LUTF8.toString . JSON.encodePretty $ x
gfnJSON _ =
    return def

gfnYAML :: Ginger.Function (Ginger.Run p IO h)
gfnYAML ((_, x):_) =
    return . toGVal . UTF8.toString . YAML.encode $ x
gfnYAML _ =
    return def

gfnLoadBackendData :: forall p h. (LogLevel -> Text -> IO ()) -> RawBackendCache -> Ginger.Function (Ginger.Run p IO h)
gfnLoadBackendData writeLog cache args =
    Ginger.dict <$> forM (zip [0..] args) loadPair
    where
        loadPair :: (Int, (Maybe Text, GVal (Ginger.Run p IO h)))
                 -> Ginger.Run p IO h (Text, GVal (Ginger.Run p IO h))
        loadPair (index, (keyMay, gBackendURL)) = do
            backendSpec <- either fail pure . JSON.parseEither backendSpecFromJSON . toJSON $ gBackendURL
            backendData :: Items (BackendData p IO h) <- liftIO $
                loadBackendData writeLog pbsInvalid cache backendSpec
            return
                ( fromMaybe (tshow @Text index) keyMay
                , toGVal backendData
                )

catchToGinger :: forall h m. (LogLevel -> Text -> IO ())
              -> IO (GVal m)
              -> IO (GVal m)
catchToGinger writeLog action =
    action
        `catch` (\(e :: SomeException) -> do
            writeLog Logger.Error . formatException $ e
            return . toGVal $ False
        )

instance ToGVal m Wai.Request where
    toGVal rq =
        Ginger.orderedDict
            [ "httpVersion" ~> tshow @Text (Wai.httpVersion rq)
            , "method" ~> decodeUtf8 @Text (Wai.requestMethod rq)
            , "path" ~> decodeUtf8 @Text (Wai.rawPathInfo rq)
            , "query" ~> decodeUtf8 @Text (Wai.rawQueryString rq)
            , "pathInfo" ~> Wai.pathInfo rq
            , ( "queryInfo"
              , Ginger.orderedDict
                    [ (key, toGVal val)
                    | (key, val)
                    <- queryToQueryText (Wai.queryString rq)
                    ]
              )
            , ( "headers"
              , Ginger.orderedDict
                    [ (decodeCI n, toGVal $ decodeUtf8 v)
                    | (n, v)
                    <- Wai.requestHeaders rq
                    ]
              )
            ]

decodeCI :: CI.CI ByteString -> Text
decodeCI = decodeUtf8 . CI.original