{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
module Quiz.Web ( quizApplication ) where

import Prelude hiding (id, (.))
import Control.Arrow
import Control.Category
import Quiz.Web.Prelude
import Servant
import Servant.Server
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text (toStrict, fromStrict)
import Web.Cookie
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Base64 as B64
import qualified Data.Binary as B
import Control.Concurrent.MVar
import Control.Concurrent.STM
import qualified Data.IntMap as IntMap
import Data.Text.Encoding
import Data.Monoid
import Servant.Utils.Links
import Network.HTTP.Types.URI
import Data.Maybe
import Text.Blaze.Renderer.Utf8
import Text.Markdown
import Data.Default

-- import Quiz.Web.Home
-- import Quiz.Web.Quiz
-- import Quiz.Web.Style

-- class Help h where
--     help :: h -> Text -> Maybe Text -> Handler Html
-- 
-- instance Monad m => Help (ReaderT a m) where
--     help m = run

instance (HasServer a, HasServer b) => HasServer (Prefix a (x :<|> y)) where
    type ServerT (Prefix a (x :<|> y)) m = (a :> ServerT x m) :<|> (Prefix a (ServerT y m))

    route Proxy context server =
        route (Proxy )

-- | Execute the core QuickQuiz Wai application.
quizApplication :: TVar SessionMap -> TVar (Map Text Quiz) -> TVar StdGen -> Application
quizApplication sessionMap quizMap stdGen req respond = do
    -- Create a new MVar for storing Set-Cookie response hints
    setSessionMVar <- newEmptyMVar
    -- Define a new respond function which accounts for session cookies
    let respondSession response = respond . maybe response (flip mapResponseHeaders response . (:) . ("Set-Cookie",) . ("SESSION=" <>)) =<< tryReadMVar setSessionMVar
        setSession = void . tryPutMVar setSessionMVar
    -- Run the web handler
    serve (Proxy :: Proxy WebAPI) (server $ WebEnv sessionMap quizMap stdGen setSession) req respondSession

-- | Servant server for the entirety of the QuickQuiz web server.
server :: (Maybe Session -> Maybe QuizSession -> WebEnv) -> Server WebAPI
server mkEnv = enter (runReaderTNat $ mkEnv Nothing Nothing) (toMarkup . DefaultLayout <$> webHome)
        :<|> webQuiz
        :<|> webStatic
    where
        -- | Concatenation of the separate QuickQuiz route handlers.
        webQuiz :: Server QuizAPI
        webQuiz = (\w x     -> getQuizEnv w x >>= run webQuizOpen)
             :<|> (\w x y   -> getQuizEnv w x >>= run (webQuizGet y))
             :<|> (\w x y z -> getQuizEnv w x >>= run (webQuizPost y z))
             :<|> (\w x     -> getQuizEnv w x >>= run webQuizReview)
             :<|> (\w x     -> getQuizEnv w x >>= run webQuizFinalize)

        run x y = toMarkup . DefaultLayout <$> (runReaderT x y)

        getQuizEnv :: Text -> Maybe Text -> Handler WebEnv
        getQuizEnv sym cookie = do
            let env = mkEnv Nothing Nothing
            s@(Session self _ qmap) <- runReaderT (getSession cookie) env
            -- Look for quiz among active session quizzes
            case Map.lookup sym qmap of
                Just qs ->
                    return $ mkEnv (Just s) (Just qs)
                Nothing -> do
                    -- Look for quiz among all quizzes
                    env <- liftIO $ atomically $ do
                        qmap' <- readTVar $ _env_quiz_map_tvar env
                        s' <- readTVar self
                        case Map.lookup sym qmap' of
                            Just quiz -> do
                                let qs = QuizSession quiz 1 IntMap.empty
                                -- Add quiz to session 
                                let s'' = s' { _session_quiz_map = 
                                    Map.insert (_quiz_symbol quiz)
                                               qs
                                               (_session_quiz_map s') }
                                writeTVar self s''
                                return $ Just $ mkEnv (Just s'') (Just qs)
                            Nothing ->
                                return Nothing
                    case env of
                        Just env' ->
                            return env'
                        Nothing ->
                            notFound $ "Quiz with symbol '" <> sym <> "' not found."

notFound :: ToMarkup m => m -> Handler a
notFound msg = throwError err404 { errBody = renderMarkup $ toMarkup $ DefaultLayout $ [shamlet|
    <h1>
        <span class="subject">404
        <span class="topic">#{msg}
|] }

-- | Home page route handler.
webHome :: Web HomeAPI
webHome = do
    -- Get all quizzes
    qs <- get_quizzes
    -- Render the Home page
    return $ [shamlet|
         <div class="quizzes">
             $forall q <- qs
                 <a href=#{"/quiz/" <> _quiz_symbol q} class="quiz">
                     <span class="subject">#{_quiz_subject q}
                     <span class="topic">#{_quiz_topic q}
                     <p class="description">#{_quiz_description q} |]

webQuizOpen :: Web QuizOpenAPI
webQuizOpen = do
    qmap <- _session_quiz_map . fromJust <$> reader _env_session
    quizSym <- _quiz_symbol . _quiz_session_quiz . fromJust <$> reader _env_quiz_session
    case _quiz_session_current_problem_index <$> Map.lookup quizSym qmap of
        Just probIdx ->
            -- Redirect to the current Quiz problem
            redirect (Proxy :: Proxy (QuizPrefix QuizGetAPI)) (\mk -> mk quizSym probIdx)
        Nothing ->
            lift $ notFound [shamlet|Quiz with symbol '#{quizSym}' not found. Please help.|]

    
-- |  GET request handler for a specific quiz problem.
webQuizGet :: Web QuizGetAPI
webQuizGet probIdx = do
    (Session _ _ qmap) <- fromJust <$> reader _env_session
    curQuiz <- _quiz_session_quiz . fromJust <$> reader _env_quiz_session
    let quizSym = _quiz_symbol curQuiz
    -- Lookup the current problem within the current quiz
    let probs    = _quiz_problems curQuiz
        probsCnt = length probs
    -- Render the current quiz problem page
    if probIdx < 1 || probIdx > probsCnt then
        lift $ notFound $ "Quiz problem number " <> Text.pack (show probIdx) <> " not found in '" <> quizSym <> "' quiz."
    else do
        let Problem desc (Solution sol) = probs !! (probIdx - 1)
        return $ [shamlet|
            <h1>
                <span class="subject"> #{_quiz_subject curQuiz}
                <span class="topic">   #{_quiz_topic   curQuiz}
            <div class="quiz-problem">
                <div class="quiz-problem-number">
                    <span>#{probIdx}
                <div class="quiz-problem-content">
                    #{renderMarkdown "" desc}
                <form id="response-form" method="post">
                    #{either toMarkup toMarkup sol}
                    <input type="submit" class="submit-button" value="Next">
                    <div class="clear">
        |]

webQuizPost :: Web QuizPostAPI
webQuizPost probIdx msg = do
    (Session self _ qmap) <- fromJust <$> reader _env_session
    (QuizSession quiz _ _) <- fromJust <$> reader _env_quiz_session
    let quizSym = _quiz_symbol quiz
    -- Parse form serialized form data
    let getParam = flip Map.lookup $ Map.fromList msg
    -- Acquire the current problem solution
    -- TODO: Remove exception here. (w.r.t. !! and Just _)
    let probs = _quiz_problems quiz
        probsCnt = length probs
        prob = probs !! (probIdx - 1)
        Solution sol = _problem_solution prob
    case sol of
        Left (MultiChoice _ cs) ->
            return undefined
        Right (Explanation maybeExp) -> do
            liftIO $ atomically $ modifyTVar self $ \s@(Session _ _ qmap) ->
                s { _session_quiz_map = fromMaybe qmap $ do
                    exp <- getParam "explanation"
                    return (Map.adjust (\q@(QuizSession _ _ ans) -> q { _quiz_session_answers = IntMap.insert probIdx (Right exp) ans }) quizSym qmap) }
            if probsCnt == probIdx then
                redirect (Proxy :: Proxy (QuizPrefix QuizReviewAPI)) ($ quizSym)
            else
                redirect (Proxy :: Proxy (QuizPrefix QuizGetAPI)) (\mk -> mk quizSym (probIdx + 1))

webQuizReview :: Web QuizReviewAPI
webQuizReview = do
    (QuizSession quiz _ ans) <- fromJust <$> reader _env_quiz_session
    let xs = zip (_quiz_problems quiz) [1..]
        answer prob i =
            case (fromJust $ IntMap.lookup i ans, _problem_solution prob) of
                        (Left choiceIdx, Solution (Left mc)) ->
                              let xs = zip [1..] $ _multiple_choice_choices mc
                              in [shamlet|
                                  <ul>
                                      $forall (i, choice) <- xs
                                                $if i == choiceIdx
                                                    <li class="selected">
                                                        #{_choice_body choice}
                                                $else
                                                    <li>
                                                        #{_choice_body choice}
                                    |]
                        (Right resp, Solution (Right exp)) ->
                              [shamlet|
                                  <div class="explanation">
                                      #{renderMarkdown (show i ++ "-explanation--") resp}
                                  |]
    return $ [shamlet|
        <h1>
            <span class="subject"> #{_quiz_subject quiz}
            <span class="topic">   #{_quiz_topic   quiz}
        <div id="quiz-review">
            $forall (prob, i) <- xs
                <div class="quiz-problem">
                    <div class="quiz-problem-number">
                        <span>#{i}
                    <div class="quiz-problem-content">
                        #{renderMarkdown (show i ++ "--") $ _problem_body prob}
                    <div class="quiz-problem-answer">
                        #{answer prob i}
            <a href=#{("/quiz/" <> _quiz_symbol quiz) <> "/finalize"} class="submit-button" id="finalize-button">
                Finalize
            <div class="clear">
    |]
    -- let Just (QuizSession curQuiz _ _) = Map.lookup quizSym qmap

webQuizFinalize :: Web QuizFinalizeAPI
webQuizFinalize = do
    return $ [shamlet|
        |]

handleSession :: (Session -> WebM a) -> Maybe Text -> WebM a
handleSession action = (action =<<) . getSession

-- | Find existing session data. If a client has no existing session, create a new one.
getSession :: Maybe Text -> WebM Session
getSession getCookies = do
    -- Acquire the session map
    smapvar <- reader _env_session_map_tvar
    sessionMap <- liftIO $ readTVarIO smapvar
    -- Lookup an existing session --
    let session = do
            -- Acquire cookie string
            cookies <- getCookies
            -- Extract the session identifier from the cookie string
            reqSessionId <- Map.lookup "SESSION" $ Map.fromList $ parseCookies $ encodeUtf8 cookies
            -- Lookup session identifier in map of cookies
            IntMap.lookup (B.decode $ BL.fromStrict $ B64.decodeLenient reqSessionId) sessionMap
    case session of
        Just s ->
            -- Return the existing session
            liftIO $ readTVarIO s
        Nothing -> do
            rndgenvar <- reader _env_stdgen_tvar
            -- Create a new session
            newSession <- liftIO $ atomically $ do
                -- Acquire the session map
                smap <- readTVar smapvar
                -- Acquire the random number generator
                rndgen <- readTVar rndgenvar
                -- Generate a new session identifier
                let genId (i, g) =
                        if IntMap.member i smap then
                            -- Identifier exists
                            genId $ next g
                        else
                            -- New identifier found
                            (i, g)
                    (newId, rndgen') = genId $ next rndgen
                -- Generate the new session map
                let newSession' = Session undefined newId def
                newSessionTVar <- newTVar newSession'
                let newSession = newSession' { _session_self = newSessionTVar }
                writeTVar newSessionTVar newSession
                let newMap = IntMap.insert newId newSessionTVar smap
                -- Write out the new session map
                writeTVar smapvar newMap
                -- Write out the new random number generator
                writeTVar rndgenvar rndgen'
                -- Return the new session
                return newSession
            -- Set the Set-Cookie header (for sending with the response)
            liftIO . ($ B64.encode $ BL.toStrict $ B.encode $ _session_id newSession) =<< reader _env_set_session
            -- Return the new session (into the request handler)
            return newSession

-- handleQuiz :: ToMarkup a => (Session -> WebM a) -> Maybe Text -> WebM a
-- handleQuiz action getCookies = do
--     (body, curQuiz) <- handleSession (\s@(Session _ _ qmap)-> do
--         let Just (QuizSession curQuiz _ _) = Map.lookup quizSym qmap
--         body <- action s
--         return (body, curQuiz)) getCookies
--     return $ DefaultLayout $ [shamlet|
--         <h1>
--             <span class="subject"> #{_quiz_subject curQuiz}
--             <span class="topic">   #{_quiz_topic   curQuiz}
--         <div>#{body}
--     |]

instance ToMarkup Explanation where
    toMarkup (Explanation _) = [shamlet|<textarea name="explanation">|]

instance ToMarkup MultiChoice where
    toMarkup (MultiChoice isRadio cs) = 
        [shamlet|
            <ul>
                $forall c <- cs
                    <li>#{c}
        |]

instance ToMarkup Choice where
    toMarkup (Choice desc _) = renderMarkdown "" desc

renderMarkdown :: String -> Text -> Html
renderMarkdown prefix = markdown def . Text.fromStrict -- toMarkup -- either (error . show) (writeHtml def { writerIdentifierPrefix = prefix, writerHTMLMathMethod = MathJax "" }) . readMarkdown def . Text.unpack

webStatic :: Web StaticAPI
webStatic = serveDirectory "www"

redirect :: (IsElem endpoint WebAPI, HasLink endpoint) => Proxy endpoint -> (MkLink endpoint -> URI) -> WebM a
redirect p f = throwError err302 { errHeaders = [("Location", BSC.pack $ ('/':) $ uriPath $ f $ safeLink (Proxy :: Proxy WebAPI) p)] }

-- instance ToMarkup a => ToMarkup [a] where
--     toMarkup xs = [shamlet|
--         <ul>
--             $forall x <- xs
--                 <li>#{x}|]

-- instance ToMarkup a => ToMarkup QuizSummary where
--     toMarkup (QuizSummary q) = [shamlet|
--         <div class="quizzes">
--             $forall q <- qs
--                 <a href=#{"/quiz/" <> _quiz_symbol q} class="quiz">
--                     <span class="subject">#{_quiz_subject q}
--                     <span class="topic">#{_quiz_topic q}
--                     <p class="description">#{_quiz_description q}
--         |]

-- instance ToMarkup a => ToMarkup (x ) where

-- getQuizMap :: (QuizMap Quiz -> a) -> WebM a
-- getQuizMap = flip fmap (liftIO . readTVarIO =<< reader _env_quiz_map_tvar)

-- getSessQuizMap :: Int -> (QuizMap (Quiz, Int, [Answer]) -> a) -> WebM a
-- getSessQuizMap sid f = do
--     fmap (f . sessionState) (liftIO . readTVarIO =<< reader _env_session_map_tvar)

-- getQuizzes :: WebM [Quiz]
-- getQuizzes = getQuizMap qmAll

-- cookieToSessionId :: Text -> Int
-- cookieToSessionId cookie = 
-- getQuiz
