content: {-# 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 (threadDelay)
  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.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.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 Nothing sourceChatId shouldNotify Nothing msgId
      waitAndRetry fwdMsgRequest
      return ()
  
    AInlineGame queryId msg -> model <# do
      let genericResult = (defInlineQueryResultGeneric (InlineQueryResultId msg))
            { inlineQueryResultTitle = Just msg
            , inlineQueryResultInputMessageContent = Just gameMsg
            }
          gameMsg = InputTextMessageContent
            { inputMessageContentMessageText = gameMessageText
            , inputMessageContentParseMode = Just "HTML"
            , inputMessageContentDisableWebPagePrefiew = Nothing
            }
          inlineQueryResult = InlineQueryResultGame
            { inlineQueryResultGameGeneric = genericResult
            , inlineQueryResultGameGameShortName = gameName
            }
          answerInlineQueryRequest = defAnswerInlineQuery  queryId [inlineQueryResult]
  
      _ <- runTG answerInlineQueryRequest
      return ()
    AGame targetChatId _msg -> model <# do
      let sendGameRequest = defSendGame (coerce targetChatId) gameId
      waitAndRetry sendGameRequest
      return ()
    ACallback callback -> model <# do
      let queryId = coerce (callbackQueryId callback)
          queryData = callbackQueryData callback
          answerCallbackQueryRequest = (defAnswerCallbackQuery queryId)
            { answerCallbackQueryText            = queryData
            , answerCallbackQueryUrl             = Just gameUrl
            }
      waitAndRetry answerCallbackQueryRequest
      return ()
  
    where
      gameMessageText = "<a href=\"" <> gameUrl <> "\">" <> gameName <> "</a>"
  
  data Command = CmdBot | CmdServer
  
  waitAndRetry :: RunTG a (Response b) => a -> BotM ()
  waitAndRetry request = do
    result <- runTG request
    if responseOk result
      then pure ()
      else case responseParameters result >>= responseParametersRetryAfter of
        Nothing -> pure ()
        Just sec -> do
          liftIO . threadDelay $ coerce sec * 1000000
          _ <- runTG request
          return ()
  
  -- * 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 PictureSettings = PictureSettings
    { theGood :: Text
    , theBad  :: Text
    , theUgly :: Text
    , goodScore :: Double
    , badScore  :: Double
    } deriving (Generic, FromDhall)
  
  data ServerSettings = ServerSettings
    { serverPort       :: Natural
    , serverUrlPrefix  :: Text
    , questionsPerGame :: Natural
    , usersPath        :: Text
    , questionsPath    :: Text
    , analyticsPath    :: Text
    , pageStyle        :: Text
    , quizDescription  :: Text
    , quizFooterBegin  :: Text
    , quizFooterCode   :: Text
    , quizFooterEnd    :: Text
    , quizPicture      :: Maybe PictureSettings
    } 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
    :: ServerSettings
    -> Maybe Text
    -> (GameUserId -> Handler (WithCookie Html))
    -> Handler (WithCookie Html)
  withUser settings Nothing _action = redirectToRoot settings
  withUser settings (Just cookie) action
    = maybe (redirectToRoot settings) 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 (settings env) 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 settings
          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 (settings env) 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 settings 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 :: ServerSettings -> Handler (WithCookie Html)
  redirectToRoot settings
    = noHeader @"Set-Cookie"
    <$> throwError (err301WithLoc $ encodeUtf8 $ makeAbsoluteUrl settings "/")
  
  redirectToStart :: ServerSettings -> GameUserId -> Handler (WithCookie Html)
  redirectToStart settings user
    =   addHeader @"Set-Cookie" (userToSetCookie user)
    <$> throwError (err301WithLoc $ encodeUtf8 $ makeAbsoluteUrl settings "/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 s@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.link
        ! A.href (toValue $ makeAbsoluteUrl s "/fonts/HalvarBreitschriftDEMO-Regular.woff")
        ! A.rel "stylesheet"
      H.link
        ! A.href (toValue $ makeAbsoluteUrl s "/fonts/HalvarBreitschriftDEMO-Bold.woff")
        ! A.rel "stylesheet"
      H.style $ toMarkup pageStyle
    H.body $ content
  
  -- **** Home page
  
  renderTextLogo1 :: Text -> Html
  renderTextLogo1 txt =
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "text-logo-line1 position-logo-line1" $ toMarkup txt
  
  renderTextLogo2 :: Text -> Html
  renderTextLogo2 txt =
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "text-logo-line2 position-logo-line2" $ toMarkup txt
  
  renderDescription :: Text -> Html
  renderDescription txt= do
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "text-description position-text" $ toMarkup txt
  
  renderFooterText :: Text -> Html
  renderFooterText txt= do
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "text-footer position-text" $ toMarkup txt
  
  renderFooterCode :: Text -> Html
  renderFooterCode txt= do
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "text-footer-code position-text" $ toMarkup txt
  
  renderStartPage :: ServerSettings -> Html
  renderStartPage settings = withGameTemplate settings $ do
    renderTextLogo1 "Haskell"
    renderTextLogo2 "Quiz Game"
    renderDescription (quizDescription settings)
    renderLink settings "Play"
    renderFooterText (quizFooterBegin settings)
    renderFooterCode (quizFooterCode settings)
    renderFooterText (quizFooterEnd settings)
  
  -- **** Question page
  
  renderProgress :: Bool -> Int -> Integer -> Html
  renderProgress isResult current total =
    H.div ! A.class_ "qbox pad" $ do
      let currentClass = if isResult then "text-current-result" else "text-current-number"
          positionClass = if isResult then "position-progress-result" else "position-progress"
      H.div ! A.class_ positionClass $ do
        H.span ! A.class_ currentClass $ toMarkup (show current)
        H.span ! A.class_ "text-total-number" $ toMarkup $ "/ " <> show total
  
  renderQuestionText :: Bool -> Text -> Html
  renderQuestionText forExplanation txt =
    H.div ! A.class_ "qbox pad" $ do
      let positionStyle = if forExplanation then "position-explanation" else "position-question"
          questionStyle = "text-question " <> positionStyle :: Text
      H.div ! A.class_ (toValue questionStyle) $ toMarkup txt
  
  renderAnswer :: Bool -> Int -> Text -> Html
  renderAnswer ch num txt =
    H.div ! A.class_ "qbox position-answer" $ 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_ "text-answer position-text-answer" $ toMarkup txt
  
  renderQuestionPage :: ServerSettings -> UserData -> Html
  renderQuestionPage settings UserData{..} = withGameTemplate settings $ do
    case userDataCurrentQuestion of
      Nothing -> do
        renderQuestionText False "No more questions left."
        renderAgainLink settings "Play again"
  
      Just QuestionBool{..} -> do
        renderProgress False (length userDataAnswers + 1) userDataTotalQuestions
        renderQuestionText False questionBoolText
        H.form ! A.action (toValue $ makeAbsoluteGameUrl settings) ! A.method "post" $ do
          renderAnswer True 1 "True"
          renderAnswer False 0 "False"
          renderButton "Next"
  
      Just QuestionChoice{..} -> do
        renderProgress False (length userDataAnswers + 1) userDataTotalQuestions
        renderQuestionText False 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"
  
  -- **** Score page
  
  renderExplanation :: Bool -> Text -> Html
  renderExplanation True txt = renderQuestionText True txt
  renderExplanation False txt =
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "text-wrong-answer position-explanation" $ toMarkup txt
  
  chooseScorePicture :: PictureSettings -> Double -> Text
  chooseScorePicture PictureSettings{..} userScore =
    if goodScore < userScore
      then theGood
      else if badScore < userScore
             then theBad
             else theUgly
  
  renderPicture :: ServerSettings -> Int -> Integer -> Html
  renderPicture ServerSettings{..} score total = case quizPicture of
    Nothing -> return ()
    Just ps@PictureSettings{..} -> case goodScore < badScore of
      -- invalid settings
      True -> return ()
      False -> do
        let userScore :: Double
            userScore = fromIntegral score / fromIntegral total
  
            pictureUrl = chooseScorePicture ps userScore
        H.div ! A.class_ "qbox pad" $ do
          H.img ! A.src (toValue pictureUrl) ! A.class_ "score-img"
  
  renderBrightLine, renderDarkLine :: Html
  renderBrightLine = H.div ! A.class_ "qbox pad" $ do
    H.hr ! A.class_ "bright-line"
  renderDarkLine = H.div ! A.class_ "qbox pad" $ do
    H.hr ! A.class_ "dark-line"
  
  renderUserScore :: ServerSettings -> UserData -> Html
  renderUserScore settings UserData{..} = withGameTemplate settings $ do
    case userDataAnswers of
      [] -> do
        renderDescription
          "Sorry. Looks like no answers available at the moment. Try again maybe?"
        renderAgainLink settings "Play again"
      _  -> do
        let score = length $ filter answerIsRight userDataAnswers
        renderTextLogo1 "Your"
        renderTextLogo2 "Score is"
        renderProgress True score userDataTotalQuestions
        renderPicture settings score userDataTotalQuestions
        renderBrightLine
        H.div $ do
          forM_ userDataAnswers $ \Answer{..} -> H.tr $ do
            H.div $ renderQuestionText True (questionText answerQuestion)
            H.div $ if answerIsRight
              then renderExplanation True "OK"
              else renderExplanation False $ explainError answerQuestion
            renderDarkLine
        renderAgainLink settings "Play again"
  
  -- **** Helpers
  
  renderButton :: Text -> Html
  renderButton txt =
    H.div ! A.class_ "qbox pad" $ do
      H.div ! A.class_ "position-button" $ do
        H.input
          ! A.class_ "qel-button text-button"
          ! A.type_ "submit"
          ! A.value (toValue 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_ "position-link" $ do
          H.div ! A.class_ "qel-button text-button text-play-button"
            $ toMarkup txt
  
  renderAgainLink :: ServerSettings -> Text -> Html
  renderAgainLink settings txt = do
    H.a ! A.href (toValue $ makeAbsoluteGameUrl settings) $ do
      H.div ! A.class_ "qbox pad" $ do
        H.div ! A.class_ "position-link" $ do
          H.div ! A.class_ "qel-button text-button text-again-button"
            $ toMarkup txt
  