gonito/Handler/Score.hs

module Handler.Score where

import Import

import Handler.Shared
import Handler.Tables

import Control.Monad.Extra

import Handler.AchievementUtils

import qualified Database.Esqueleto      as E
import           Database.Esqueleto      ((^.))

import qualified Yesod.Table as Table

import Data.Text as T

getMyScoreR :: Handler Html
getMyScoreR = do
  entUser <- requireAuth
  doScore entUser

getScoreR :: UserId -> Handler Html
getScoreR userId = do
  user <- runDB $ get404 userId
  doScore (Entity userId user)

scoreTable :: Table.Table App (AchievementInfo, (Entity Submission, Bool))
scoreTable = mempty
  ++ Table.text "name" (achievementInfoName . fst)
  ++ achievementDescriptionCell fst
  ++ timestampCell "deadline" (achievementInfoDeadline . fst)
  ++ timestampCell "submitted" (submissionStamp . entityVal . fst . snd)
  ++ Table.linked "submission" (submissionDescription . entityVal . fst . snd) (EditSubmissionR . entityKey . fst . snd)
  ++ Table.text "status" getStatus

getStatus :: (AchievementInfo, (Entity Submission, Bool)) -> Text
getStatus (_, (_, False)) = ""
getStatus (aInfo, (_, True)) = T.pack $ show $ achievementInfoPoints aInfo

doScore :: Entity User -> Handler Html
doScore (Entity userId user) = do
  entries <- runDB $ E.select
                     $ E.from $ \(working_on, achievement, submission) -> do
                       E.where_ (working_on ^. WorkingOnAchievement E.==. achievement ^. AchievementId
                                 E.&&. E.just (submission ^. SubmissionId) E.==. working_on ^. WorkingOnFinalSubmission
                                 E.&&. working_on ^. WorkingOnUser E.==. E.val userId)
                       E.orderBy [E.asc (submission ^. SubmissionStamp)]
                       return (achievement, submission)

  entries' <- mapM (processEntry (Entity userId user)) entries

  defaultLayout $ do
    setTitle "Score"
    $(widgetFile "score")

processEntry :: Entity User -> (Entity Achievement, Entity Submission) -> Handler (AchievementInfo, (Entity Submission, Bool))
processEntry entUser (entAchievement, entSubmission) = do
  aInfo <- runDB $ getAchievementInfo (Just entUser) entAchievement

  accepted <- allM (checkSubmissionTag entSubmission) (achievementInfoTags aInfo)

  return (aInfo, (entSubmission, accepted))


checkSubmissionTag :: Entity Submission -> Entity Tag -> Handler Bool
checkSubmissionTag (Entity submissionId _) (Entity tagId _) = do
  mSubmissionTag <- runDB $ getBy $ UniqueSubmissionTag submissionId tagId
  return $ case mSubmissionTag of
    Just (Entity _ submissionTag) -> case submissionTagAccepted submissionTag of
      Just b -> b
      Nothing -> False
    Nothing -> False