{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where

import Control.Concurrent.STM
import Control.Monad (void, forM_)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.Char (isSpace)
import Data.Coerce (coerce)
import Data.Function ((&))
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
import Data.HashMap.Strict (HashMap)
import Data.Maybe (isJust)
import Data.Text.Encoding (encodeUtf8)
import Dhall hiding (maybe, void)
import Network.HTTP.Types (hLocation)
import Network.Wai.Handler.Warp (defaultSettings, runSettings, setInstallShutdownHandler, setPort)
import Options.Applicative hiding (command, action)
import Prettyprinter.Internal   (pretty)
import Servant
import Servant.HTML.Blaze
import System.Random (randomIO)
import Test.QuickCheck (generate, shuffle)
import Text.Blaze.Html
import Web.Internal.FormUrlEncoded (ToForm, FromForm)
import Web.Cookie

import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.UUID as UUID
import qualified Options.Applicative as Optparse (command)
-- import qualified System.Posix.Signals as Sig
import qualified System.Signal as Sig
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

import Telegram.Bot.API
import Telegram.Bot.API.Games
import Telegram.Bot.API.InlineMode.InlineQueryResult
import Telegram.Bot.API.InlineMode.InputMessageContent
import Telegram.Bot.Simple
import Telegram.Bot.Simple.UpdateParser

type Model = ()

data Action
  = NoOp
  | AGame ChatId Text
  | AInlineGame InlineQueryId Text
  | AFeedback SomeChatId MessageId
  | ACallback CallbackQuery

gameBot :: BotSettings -> BotApp Model Action
gameBot settings = BotApp
  { botInitialModel = ()
  , botAction = flip (updateToAction settings)
  , botHandler = handleAction settings
  , botJobs = []
  }

updateToAction :: BotSettings -> Model -> Update -> Maybe Action
updateToAction BotSettings{..}  _ update
  | isJust $ parseUpdate (command "game") update = game update
  | isJust $ parseUpdate (command "feedback") update = do
      msg <- updateMessage update
      let msgId = messageMessageId msg
          chat  = SomeChatId $ chatId $ messageChat msg
      pure $ AFeedback chat msgId
  | isJust $ updateInlineQuery update = do
      query <- updateInlineQuery update
      let queryId = inlineQueryId query
          msg     = inlineQueryQuery query
      Just $ AInlineGame queryId msg
  | isJust $ updateCallbackQuery update = ACallback <$> updateCallbackQuery update
  | otherwise = Nothing
  where
    game upd = AGame <$> (updateChatId upd) <*> (Just gameUrl)

handleAction :: BotSettings -> Action -> Model -> Eff Action Model
handleAction BotSettings{..} action model = case action of
  NoOp -> pure model
  AFeedback sourceChatId msgId -> model <# do
    let shouldNotify  = Just True
        targetChatId  = SomeChatId (ChatId (fromIntegral supportChatId))
        fwdMsgRequest = ForwardMessageRequest targetChatId sourceChatId shouldNotify Nothing msgId
    _ <- liftClientM (forwardMessage fwdMsgRequest)
    return ()

  AInlineGame queryId msg -> model <# do
    let inlineQueryResult =
          InlineQueryResult
            InlineQueryResultGame
            (InlineQueryResultId msg)
            (Just msg)
            (Just gameMsg)
            Nothing
        gameMsg = (defaultInputTextMessageContent gameMessageText) { inputMessageContentParseMode = Just "HTML" }
        answerInlineQueryRequest = AnswerInlineQueryRequest
          { answerInlineQueryRequestInlineQueryId = queryId
          , answerInlineQueryRequestResults       = [inlineQueryResult]
          , answerInlineQueryCacheTime            = Nothing
          , answerInlineQueryIsPersonal           = Nothing
          , answerInlineQueryNextOffset           = Nothing
          , answerInlineQuerySwitchPmText         = Nothing
          , answerInlineQuerySwitchPmParameter    = Nothing
          }

    _ <- liftClientM (answerInlineQuery answerInlineQueryRequest)
    return ()
  AGame targetChatId msg -> model <# do
    let sendGameRequest = SendGameRequest
          { sendGameRequestChatId                   = coerce targetChatId
          , sendGameRequestGameShortName            = gameId
          , sendGameRequestDisableNotification      = Nothing
          , sendGameProtectContent                  = Nothing
          , sendGameRequestReplyToMessageId         = Nothing
          , sendGameRequestAllowSendingWithoutReply = Nothing
          , sendGameRequestReplyMarkup              = Nothing
          }
    _ <- liftClientM $ sendGame sendGameRequest
    return ()
  ACallback callback -> model <# do
    let queryId = coerce (callbackQueryId callback)
        queryData = callbackQueryData callback
        answerCallbackQueryRequest = AnswerCallbackQueryRequest
          { answerCallbackQueryCallbackQueryId = queryId
          , answerCallbackQueryText            = queryData
          , answerCallbackQueryShowAlert       = Nothing
          , answerCallbackQueryUrl             = Just gameUrl
          , answerCallbackQueryCacheTime       = Nothing
          }
    _ <- liftClientM $ answerCallbackQuery answerCallbackQueryRequest
    return ()
    
  where
    gameMessageText = "<a href=\"" <> gameUrl <> "\">" <> gameName <> "</a>"
data Command = CmdBot | CmdServer

-- * Main

main :: IO ()
main = execParser (info (commands <**> helper) idm) >>= \case
  CmdBot -> runTelegramBot
  CmdServer -> runServer

commands :: Parser Command
commands = subparser
    (Optparse.command "bot"    (info botOpts    (progDesc botDesc)) <>
     Optparse.command "server" (info serverOpts (progDesc serverDesc)))
  where
    botDesc = "Run Telegram Game Bot"
    serverDesc = "Run HTML5 Game Server"

    botOpts = pure CmdBot
    serverOpts = pure CmdServer

-- * Bot

runTelegramBot :: IO ()
runTelegramBot = do
  botSettings <- loadBotSettings
  let token = Token (botToken botSettings)
  env <- defaultTelegramClientEnv token
  startBot_ (conversationBot updateChatId (gameBot botSettings)) env

data BotSettings = BotSettings
  { botToken      :: Text
  , gameUrl       :: Text
  , gameId        :: Text
  , gameName      :: Text
  , supportChatId :: Integer
  }
  deriving (Generic, FromDhall)

loadBotSettings :: IO BotSettings
loadBotSettings = input Dhall.auto "./examples/game-bot-settings.dhall"

-- * Server

runServer :: IO ()
runServer = do
  serverSettings <- loadServerSettings
  env <- loadEnv serverSettings
  let shutdownHandler closeSocket = void $ Sig.installHandler Sig.sigTERM handler
        where
          shutdownAction = storeEnv env
          handler _sig = shutdownAction >> closeSocket
      warpSettings = defaultSettings
        & setPort port
        & setInstallShutdownHandler shutdownHandler
      port = fromIntegral (serverPort serverSettings)
  runSettings warpSettings (serverApp env)

data ServerSettings = ServerSettings
  { serverPort       :: Natural
  , serverUrlPrefix  :: Text
  , questionsPerGame :: Natural
  , usersPath        :: Text
  , questionsPath    :: Text
  , analyticsPath    :: Text
  , pageStyle        :: Text
  , quizDescription  :: Text
  } deriving (Generic, FromDhall)

serverSettingsPath :: Text
serverSettingsPath = "./examples/game-server-settings.dhall"

loadServerSettings :: IO ServerSettings
loadServerSettings = input Dhall.auto serverSettingsPath

data AnswerInt = AnswerInt { q :: Int } deriving (Eq, Show, Generic)

instance ToForm AnswerInt

instance FromForm AnswerInt

type WithCookie x = Headers '[ Header "Set-Cookie" SetCookie ] x

type API
  =  Header "Cookie" Text
  :> (     Get '[HTML] (WithCookie Html)
     :<|> "game"  :>
        (    Get '[HTML] (WithCookie Html)
        :<|> ReqBody' '[Required, Strict] '[FormUrlEncoded] AnswerInt :> Post '[HTML] (WithCookie Html)
        )
     )

api :: Proxy API
api = Proxy

server :: Env -> Server API
server env = \cookie ->
  (    startHandler env cookie
  :<|> (firstQuestionHandler env cookie :<|> nextQuestionHandler env cookie)
  )

serverApp :: Env -> Application
serverApp env = serve api (server env)

-- *** Questions

data Choice = Choice
  { choiceText      :: Text
  , choiceNumber    :: Integer
  , choiceIsCorrect :: Bool
  }
  deriving (Eq, Show, Generic, Hashable, Ord, FromDhall, ToDhall)

data Question
  = QuestionBool
      { questionBoolText         :: Text
      , questionBoolAnswerIsTrue :: Bool
      , questionBoolExplanation  :: Text
      }
  | QuestionChoice
      { questionChoiceText        :: Text
      , questionChoiceChoices     :: [Choice]
      , questionChoiceExplanation :: Text
      }
  deriving (Eq, Show, Generic, Hashable, Ord, FromDhall, ToDhall)

questionText :: Question -> Text
questionText (QuestionBool txt _ _)  = txt
questionText (QuestionChoice txt _ _) = txt

questionExists :: Text -> HashSet Question -> Bool
questionExists questionTxt = not . HashSet.null . HashSet.filter exists
  where
    exists (QuestionBool txt _isTrue _) = txt == questionTxt
    exists (QuestionChoice txt _choices _) = txt == questionTxt

explainError :: Question -> Text
explainError QuestionBool{..} = questionBoolExplanation
explainError QuestionChoice{..} = questionChoiceExplanation

validateQuestion :: Question -> Bool
validateQuestion (QuestionBool _ _ _) = True
validateQuestion (QuestionChoice _ choices _) = checkConsistency choices
  where
    checkAnswerConsistency = (== 1) . length . filter choiceIsCorrect
    checkIdConsistency x = (HashSet.size . HashSet.fromList . fmap choiceNumber) x == length x
    checkConsistency x = checkIdConsistency x && checkAnswerConsistency x

shuffleQuestions :: Int -> HashSet Question -> IO [Question]
shuffleQuestions limit questions
  = generate $ take limit <$> shuffle (HashSet.toList questions)

solveQuestion :: Int -> Question -> Bool
solveQuestion result QuestionBool{..} = intToBool result == questionBoolAnswerIsTrue
  where
    intToBool 0 = False
    intToBool _ = True
solveQuestion result QuestionChoice{..}
  = not . null . filter (byNumber result) $ questionChoiceChoices
  where
    byNumber x Choice{..} = choiceNumber == fromIntegral x

-- ** Answer

data Answer = Answer
  { answerQuestion           :: Question
  , answerIsRight            :: Bool
  , answerExplanationOnError :: Text
  }
  deriving (Eq, Show, Generic, FromDhall, ToDhall)

registerAnswer :: Int -> Maybe Question -> [Answer] -> [Answer]
registerAnswer userAnswer prevQuestion oldAnswers = case prevQuestion of
  Nothing -> oldAnswers
  Just q  -> newAnswer q : oldAnswers
  where
    newAnswer q = Answer q (solveQuestion userAnswer q) (explainError q)

-- *** UserData

newtype GameUserId = GameUserId Text
  deriving (Eq, Show, Generic, Hashable, FromDhall, ToDhall)

data UserData = UserData
  { userDataCurrentQuestion :: Maybe Question
  , userDataQuestions       :: [Question]
  , userDataAnswers         :: [Answer]
  , userDataTotalQuestions  :: Integer
  }
  deriving (Eq, Show, Generic, FromDhall, ToDhall)

createUser :: Handler GameUserId
createUser = liftIO (GameUserId . UUID.toText <$> randomIO)

getOrCreateUser :: Maybe Text -> Handler GameUserId
getOrCreateUser Nothing       = createUser
getOrCreateUser (Just cookie) =
  case parseUser cookie of
    Nothing   -> createUser
    Just user -> pure user

parseUser :: Text -> Maybe GameUserId
parseUser = fmap GameUserId
  . HashMap.lookup "HUID"
  . HashMap.fromList
  . fmap (fmap (Text.drop 1) . Text.span (/= '='))
  . Text.splitOn ";"
  . Text.filter (not . isSpace)

userToSetCookie :: GameUserId -> SetCookie
userToSetCookie user = defaultSetCookie
  { setCookieName = "HUID"
  , setCookieValue = encodeUtf8 (coerce user)
  }

findUserData :: GameUserId -> HashMap GameUserId UserData -> Maybe UserData
findUserData = HashMap.lookup

initUserData :: [Question] -> Maybe UserData
initUserData [] = Nothing
initUserData total@(q : qs) = Just $ UserData
  { userDataCurrentQuestion = Just q
  , userDataQuestions       = qs
  , userDataAnswers         = []
  , userDataTotalQuestions  = fromIntegral $ length total
  }

alterUserData :: Int -> UserData -> GameState
alterUserData userAnswer old = case (userDataCurrentQuestion old, userDataQuestions old) of
  (Nothing, []) -> GameNotFound
  (Just q, [])  -> GameOver $ old
    { userDataCurrentQuestion = Just q
    , userDataQuestions       = []
    , userDataAnswers         =
        registerAnswer userAnswer (userDataCurrentQuestion old) (userDataAnswers old)
    }
  (_, q : qs) -> GameInProgress $ old
    { userDataCurrentQuestion = Just q
    , userDataQuestions       = qs
    , userDataAnswers         =
        registerAnswer userAnswer (userDataCurrentQuestion old) (userDataAnswers old)
    }

gameDataFromState :: GameState -> Maybe UserData
gameDataFromState = \case
  GameNotFound -> Nothing
  GameOver game -> Just game
  GameInProgress game -> Just game

data GameState = GameOver UserData | GameNotFound | GameInProgress UserData
  deriving Eq

-- *** Analytics

data Analytics = Analytics
  { rootPageCounter         :: Integer
  , nextQuestionPageCounter :: Integer
  }
  deriving (Eq, Show, Generic, FromDhall, ToDhall)

incrementRootPage :: Analytics -> Analytics
incrementRootPage a = a { rootPageCounter = 1 + rootPageCounter a }

incrementNextQuestionPage :: Analytics -> Analytics
incrementNextQuestionPage a = a { nextQuestionPageCounter = 1 + nextQuestionPageCounter a }

-- *** Env

data Env = Env
  { settings       :: ServerSettings
  , userState      :: TVar (HashMap GameUserId UserData)
  , questionsState :: TVar (HashSet Question)
  , analytics      :: TVar Analytics
  }

loadEnv :: ServerSettings -> IO Env
loadEnv settings@ServerSettings{..} = do
  userState <- newTVarIO =<< loadUserState
  questionsState <- newTVarIO =<< loadQuestionsState
  analytics <- newTVarIO =<< loadAnalytics
  pure Env{..}
  where
    loadUserState      = input Dhall.auto usersPath
    loadQuestionsState = input Dhall.auto questionsPath
    loadAnalytics      = input Dhall.auto analyticsPath

storeEnv :: Env -> IO ()
storeEnv Env{..} = do
  let ServerSettings{..} = settings
  storeState @(HashMap GameUserId UserData) usersPath userState
  storeState @Analytics analyticsPath analytics
  where
    storeState :: forall a. ToDhall a => Text -> TVar a -> IO ()
    storeState path state = do
      stateData <- readTVarIO state
      Text.writeFile (Text.unpack path) (renderDhall stateData)
    renderDhall :: forall a. ToDhall a => a -> Text
    renderDhall = Text.pack . show . pretty . Dhall.embed Dhall.inject

-- *** Handlers

withUser
  :: Maybe Text
  -> (GameUserId -> Handler (WithCookie Html))
  -> Handler (WithCookie Html)
withUser Nothing _action = redirectToRoot
withUser (Just cookie) action = maybe redirectToRoot action (parseUser cookie)

startHandler :: Env -> Maybe Text -> Handler (WithCookie Html)
startHandler Env{..} mCookie = do
  user <- getOrCreateUser mCookie
  pure
    $ addHeader @"Set-Cookie" (userToSetCookie user)
    $ renderStartPage settings

firstQuestionHandler :: Env -> Maybe Text -> Handler (WithCookie Html)
firstQuestionHandler env mCookie = withUser mCookie (firstQuestionForUser env)
  where
    ServerSettings{..} = settings env
    limit = fromIntegral questionsPerGame

    firstQuestionForUser Env{..} user = do
      mNewUserData <- liftIO $ do
        newQuestions <- shuffleQuestions limit =<< readTVarIO questionsState
        atomically $ do
          modifyTVar' analytics incrementNextQuestionPage
          let newUserData = initUserData newQuestions
          case newUserData of
            Nothing       -> pure ()
            Just userData -> modifyTVar' userState $! HashMap.insert user userData
          pure newUserData
      case mNewUserData of
        Nothing -> redirectToRoot
        Just newUserData -> pure
          $ addHeader @"Set-Cookie" (userToSetCookie user)
          $ renderQuestionPage settings newUserData

nextQuestionHandler :: Env -> Maybe Text -> AnswerInt -> Handler (WithCookie Html)
nextQuestionHandler env mCookie (AnswerInt answer)
  = withUser mCookie (nextQuestionForUser env answer)
  where
    nextQuestionForUser Env{..} numAnswer user = do
      newGameState <- liftIO $ atomically $ do
        modifyTVar' analytics incrementNextQuestionPage
        oldUserState <- readTVar userState
        case findUserData user oldUserState of
          Nothing -> pure GameNotFound
          Just oldUserData -> do
            let newUserState = alterUserData numAnswer oldUserData
            case gameDataFromState newUserState of
              Nothing -> writeTVar userState $! HashMap.delete user oldUserState
              Just newUserData ->
                writeTVar userState $! HashMap.insert user newUserData oldUserState
            pure newUserState
      case newGameState of
        GameNotFound -> redirectToStart user
        GameOver oldUserData -> pure
          $ addHeader @"Set-Cookie" (userToSetCookie user)
          $ renderUserScore settings oldUserData
        GameInProgress newUserData -> pure
          $ addHeader @"Set-Cookie" (userToSetCookie user)
          $ renderQuestionPage settings newUserData

-- *** Redirects

redirectToRoot :: Handler (WithCookie Html)
redirectToRoot = noHeader @"Set-Cookie" <$> throwError (err301WithLoc "/")

redirectToStart :: GameUserId -> Handler (WithCookie Html)
redirectToStart user
  =   addHeader @"Set-Cookie" (userToSetCookie user)
  <$> throwError (err301WithLoc "/game")

err301WithLoc :: ByteString -> ServerError
err301WithLoc loc = err301 { errHeaders = [(hLocation, loc)] }

-- *** Renderers

makeAbsoluteUrl :: ServerSettings -> Text -> Text
makeAbsoluteUrl ServerSettings{..} uri = serverUrlPrefix <> uri

makeAbsoluteRootUrl :: ServerSettings -> Text
makeAbsoluteRootUrl = flip makeAbsoluteUrl "/"

makeAbsoluteGameUrl :: ServerSettings -> Text
makeAbsoluteGameUrl = flip makeAbsoluteUrl "/game"

withGameTemplate :: ServerSettings -> Html -> Html
withGameTemplate ServerSettings{..} content = toHtml $ H.html $ do
  H.head $ do
    H.title $ "Game"
    H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"
    H.style $ toMarkup pageStyle
  H.body $ content

renderText :: Text -> Html
renderText txt =
  H.div ! A.class_ "qbox pad" $ do
    H.div ! A.class_ "qel" $ do
      H.div ! A.class_ "text" $ toMarkup txt

renderExplanation :: Bool -> Text -> Html
renderExplanation True txt = renderText txt
renderExplanation False txt = 
  H.div ! A.class_ "qbox pad" $ do
    H.div ! A.class_ "wel" $ do
      H.div ! A.class_ "text" $ toMarkup txt

renderButton :: Text -> Html
renderButton txt = 
  H.div ! A.class_ "qbox pad" $ do
    H.button ! A.class_ "qel text button" ! A.type_ "submit"  ! A.value "submit" $ toMarkup txt

renderLink :: ServerSettings -> Text -> Html
renderLink settings txt = do
  H.a ! A.href (toValue $ makeAbsoluteGameUrl settings) $ do 
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "qel button" $ do
        H.div ! A.class_ "text" 
          $ toMarkup txt

renderAnswer :: Bool -> Int -> Text -> Html
renderAnswer ch num txt =
  H.div ! A.class_ "qbox pad" $ do
    H.div ! A.class_ "qel" $ do
      H.label ! A.class_ "container" ! A.for (toValue num) $ do
        H.input
          ! A.id (toValue num)
          ! A.type_ "radio"
          ! A.name "q"
          !? (ch, A.checked "")
          ! A.value (toValue num)
        H.div ! A.class_ "checkmark" $ ""
        H.div ! A.class_ "ctext text typing" $ toMarkup txt

renderProgress :: Text -> Html
renderProgress txt =
  H.div ! A.class_ "qbox pad" $ do
    H.div $ do
      H.div ! A.class_ "text" $ toMarkup txt

renderStartPage :: ServerSettings -> Html
renderStartPage settings = withGameTemplate settings $ do
  renderText "Haskell Quiz Game"
  renderText (quizDescription settings)
  renderLink settings "Play"

renderQuestionPage :: ServerSettings -> UserData -> Html
renderQuestionPage settings UserData{..} = withGameTemplate settings $ do
  let progress = show (length userDataAnswers + 1) <> "/" <> show userDataTotalQuestions
  case userDataCurrentQuestion of
    Nothing -> do
      renderText "No more questions left."
      renderLink settings "Play again"

    Just QuestionBool{..} -> do
      renderText questionBoolText
      H.form ! A.action (toValue $ makeAbsoluteGameUrl settings) ! A.method "post" $ do
        renderAnswer True 1 "True"
        renderAnswer False 0 "False"
        renderButton "Next question"
        renderProgress $ Text.pack progress

    Just QuestionChoice{..} -> do
      renderText questionChoiceText
      H.form ! A.action (toValue $ makeAbsoluteGameUrl settings) ! A.method "post" $ do
        forM_ questionChoiceChoices $
          \Choice{..} -> renderAnswer
            (if choiceNumber == 1 then True else False)
            (fromIntegral choiceNumber)
            choiceText
        renderButton "Next question"
        renderProgress $ Text.pack progress

renderUserScore :: ServerSettings -> UserData -> Html
renderUserScore settings UserData{..} = withGameTemplate settings $ do
  case userDataAnswers of
    [] -> do
      renderText "Sorry. Looks like no answers available at the moment. Try again maybe?"
      renderLink settings "Play again"
    _  -> do
      let total = show userDataTotalQuestions
          current = show (length $ filter answerIsRight userDataAnswers)
          score = Text.pack (current <> "/" <> total)
      H.b $ do
        renderText $ "Your score is: " <> score
      H.div $ do
        forM_ userDataAnswers $ \Answer{..} -> H.tr $ do
          H.div $ renderText (questionText answerQuestion)
          H.div $ if answerIsRight
            then renderExplanation True "OK"
            else renderExplanation False $ explainError answerQuestion
      renderLink settings "Play again"