gonito/Handler/Achievements.hs

module Handler.Achievements where

import Import
import Handler.Common (checkIfAdmin)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)

import Handler.TagUtils

import Handler.Tables
import Handler.Shared

import Handler.AchievementUtils

import Data.Time.LocalTime

import Data.Text

import qualified Yesod.Table as Table

getGonitoInClassR :: Handler Html
getGonitoInClassR = do
  defaultLayout $ do
    setTitle "Achievements"
    $(widgetFile "gonito-in-class")

getAchievementsR :: Handler Html
getAchievementsR = do
  (formWidget, formEnctype) <- generateFormPost (achievementForm Nothing Nothing)
  mUser <- maybeAuth
  doAchievements mUser formWidget formEnctype

postAchievementsR :: Handler Html
postAchievementsR = do
  ((result, formWidget), formEnctype) <- runFormPost (achievementForm Nothing Nothing)
  mUser <- maybeAuth
  when (checkIfAdmin mUser) $ do
     case result of
      FormSuccess (name, description, points, deadlineDay, deadlineTime, maxSubmitters, mTags, challengeId, courseId) -> do
                            achievementId <- runDB $ insert $ Achievement name challengeId points description (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) maxSubmitters courseId

                            tids <- runDB $ tagsAsTextToTagIds mTags

                            _ <- mapM (\tid -> runDB $ insert $ AchievementTag achievementId tid) tids

                            return ()
      _ -> do
           return ()
  doAchievements mUser formWidget formEnctype

doAchievements mUser formWidget formEnctype = do
  achievements <- runDB $ selectList [] [Asc AchievementName]
  mUser <- maybeAuth
  achievementInfos'' <- runDB $ mapM (getAchievementInfo mUser) achievements
  let achievementInfos' = Import.filter (not . courseClosed . entityVal . achievementInfoCourse) achievementInfos''

  courses <- case mUser of
    Just (Entity userId _) -> do
      ents <- runDB $ selectList [ParticipantUser ==. userId] []
      return $ Import.map (participantCourse . entityVal) ents
    Nothing -> do
      return []

  let achievementInfos = Import.filter (isParticipant courses) achievementInfos'

  tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON

  defaultLayout $ do
    setTitle "Achievements"
    $(widgetFile "achievements")

isParticipant :: [CourseId] -> AchievementInfo -> Bool
isParticipant [] _ = True
isParticipant courses info = (entityKey $ achievementInfoCourse info) `elem` courses

achievementsTable :: Bool -> Table.Table App (AchievementInfo)
achievementsTable canEdit = mempty
  ++ achievementNameEntry canEdit
  ++ Table.text "course" (courseName . entityVal . achievementInfoCourse)
  ++ Table.linked "challenge" (challengeTitle . entityVal . achievementInfoChallenge) (ShowChallengeR . challengeName . entityVal . achievementInfoChallenge)
  ++ achievementDescriptionCell id
  ++ Table.int "points" achievementInfoPoints
  ++ timestampCell "deadline" achievementInfoDeadline
  ++ Table.string "max submitters" (formatMaxSubmitters . achievementInfoMaxWinners)
  ++ workingOnCell

achievementNameEntry True = Table.linked "achievement" (achievementInfoName) (EditAchievementR . achievementInfoId)
achievementNameEntry False = Table.text "achievement" achievementInfoName

workingOnCell = Table.widget "who's working on it?" workingOnWidget

workingOnWidget ainfo = [whamlet|
#{srs}

$if canStartWorkingOn
   \ <a href=@{StartWorkingOnR (achievementInfoId ainfo)}>start working</a>
$if canGiveUpWorkingOn
   \ <a href=@{GiveUpWorkingOnR (achievementInfoId ainfo)}>give up</a>
|]
  where srs = formatSubmitters $ achievementInfoWorkingOn ainfo
        canStartWorkingOn = determineWhetherCanStartWorkingOn (achievementInfoCurrentUser ainfo) (achievementInfoWorkingOn ainfo) (achievementInfoMaxWinners ainfo)
        canGiveUpWorkingOn = determineWhetherCanGiveUpWorkingOn (achievementInfoCurrentUser ainfo) (achievementInfoWorkingOn ainfo)

getSubmissionForAchievementR :: SubmissionId -> WorkingOnId -> Handler Html
getSubmissionForAchievementR submissionId workingOnId = do
   (Entity userId _) <- requireAuth
   submission <- runDB $ get404 submissionId
   workingOn <- runDB $ get404 workingOnId
   if submissionSubmitter submission == userId && workingOnUser workingOn == userId
     then
       do
        runDB $ update workingOnId [WorkingOnFinalSubmission =. Just submissionId]
        setMessage $ toHtml ("OK! Your submission now awaits being accepted by a human reviewer" :: Text)
     else
       do
        setMessage $ toHtml ("Not your submission" :: Text)
   redirect $ EditSubmissionR submissionId

getStartWorkingOnR :: AchievementId -> Handler Html
getStartWorkingOnR achievementId = do
  (Entity userId user) <- requireAuth

  achievement <- runDB $ get404 achievementId
  let courseId = achievementCourse achievement

  alreadyWorkingOn <- runDB $ selectList [WorkingOnUser ==. userId, WorkingOnFinalSubmission ==. Nothing] []
  achievementsWorkingOn <- runDB $ mapM (get404 . workingOnAchievement . entityVal) alreadyWorkingOn
  let achievementsWorkingOnInTheSameCourse = Import.filter (\a -> achievementCourse a == courseId) achievementsWorkingOn

  if Import.null achievementsWorkingOnInTheSameCourse
    then
       do
        es <- runDB $ selectList [WorkingOnAchievement ==. achievementId] []
        let userIds = Import.map (workingOnUser . entityVal) es
        users <- runDB $ mapM get404 userIds
        let userEnts = Import.map (\(k,v) -> (Entity k v)) $ Import.zip userIds users

        if determineWhetherCanStartWorkingOn (Just (Entity userId user)) userEnts (achievementMaxWinners achievement)
          then
           do
            _ <- runDB $ insert $ WorkingOn achievementId userId Nothing
            setMessage $ toHtml ("OK!" :: Text)
          else
           do
            setMessage $ toHtml ("Too many people working on the achievement!" :: Text)
    else
       do
        setMessage $ toHtml ("Already working on another achievement in the same course!" :: Text)
  redirect $ AchievementsR


getGiveUpWorkingOnR :: AchievementId -> Handler Html
getGiveUpWorkingOnR achievementId = do
  (Entity userId _) <- requireAuth

  alreadyWorkingOn <- runDB $ selectList [WorkingOnUser ==. userId,
                                         WorkingOnAchievement ==. achievementId,
                                         WorkingOnFinalSubmission ==. Nothing] []
  if not (Import.null alreadyWorkingOn)
    then
       do
        runDB $ deleteWhere [WorkingOnUser ==. userId,
                             WorkingOnAchievement ==. achievementId,
                             WorkingOnFinalSubmission ==. Nothing]
        setMessage $ toHtml ("OK, you can take another achievement now!" :: Text)
    else
       do
        setMessage $ toHtml ("Not working on this achievement!" :: Text)
  redirect $ AchievementsR



determineWhetherCanStartWorkingOn Nothing _ _ = False
determineWhetherCanStartWorkingOn (Just (Entity userId _)) peopleWorkingOn maxWinners =
  (Import.all (\e -> (userId /= entityKey e)) peopleWorkingOn) && (checkLimit peopleWorkingOn maxWinners)

determineWhetherCanGiveUpWorkingOn Nothing _ = False
determineWhetherCanGiveUpWorkingOn (Just (Entity userId _)) peopleWorkingOn =
  (Import.any (\e -> (userId == entityKey e)) peopleWorkingOn)

checkLimit _ Nothing = True
checkLimit peopleWorkingOn (Just m) = (Import.length peopleWorkingOn) < m

formatSubmitters userEnts = Data.Text.intercalate ", " $ Import.map (formatSubmitter . entityVal) userEnts

formatMaxSubmitters :: Maybe Int -> String
formatMaxSubmitters Nothing = "no limit"
formatMaxSubmitters (Just m) = show m

achievementForm :: Maybe Achievement -> Maybe [Entity Tag] -> Form (Text, Maybe Text, Int, Day, TimeOfDay, Maybe Int, Maybe Text, ChallengeId, CourseId)
achievementForm mAchievement mTags = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,)
    <$> areq textField (bfs MsgAchievementName) (achievementName <$> mAchievement)
    <*> aopt textField (bfs MsgAchievementDescription) (achievementDescription <$> mAchievement)
    <*> areq intField (bfs MsgAchievementPoints) (achievementPoints <$> mAchievement)
    <*> areq dayField (bfs MsgAchievementDeadlineDay) (utctDay <$> achievementDeadline <$> mAchievement)
    <*> areq timeFieldTypeTime (bfs MsgAchievementDeadlineTime) (timeToTimeOfDay <$> utctDayTime <$> achievementDeadline <$> mAchievement)
    <*> aopt intField (bfs MsgAchievementMaxWinners) (achievementMaxWinners <$> mAchievement)
    <*> aopt textField (tagsfs MsgAchievementTags) (tagsToText <$> mTags)
    <*> challengesSelectFieldList (achievementChallenge <$> mAchievement)
    <*> coursesSelectFieldList (achievementCourse <$> mAchievement)

tagsToText [] = Nothing
tagsToText tags = Just $ Data.Text.intercalate ", " $ Import.map (tagName . entityVal) tags

challengesSelectFieldList mChallengeId = areq (selectField challenges) (bfs MsgChallenge) mChallengeId
    where
      challenges = do
        challengeEnts <- runDB $ selectList [] [Asc ChallengeTitle]
        optionsPairs $ Import.map (\ch -> (challengeTitle $ entityVal ch, entityKey ch)) challengeEnts


coursesSelectFieldList mCourseId = areq (selectField courses) (bfs MsgCourse) mCourseId
    where
      courses = do
        courseEnts <- runDB $ selectList [] [Asc CourseName]
        optionsPairs $ Import.map (\ch -> (courseName $ entityVal ch, entityKey ch)) courseEnts

getEditAchievementR :: AchievementId -> Handler Html
getEditAchievementR achievementId = do
  tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
  achievement <- runDB $ get404 achievementId
  tags <- runDB $ getAchievementTags achievementId
  (formWidget, formEnctype) <- generateFormPost (achievementForm (Just achievement) (Just tags))
  mUser <- maybeAuth

  defaultLayout $ do
    setTitle "Edit achievements"
    $(widgetFile "edit-achievement")

postEditAchievementR :: AchievementId -> Handler Html
postEditAchievementR achievementId = do
  tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
  ((result, formWidget), formEnctype) <- runFormPost (achievementForm Nothing Nothing)
  mUser <- maybeAuth

  when (checkIfAdmin mUser) $ do
     case result of
      FormSuccess (name, description, points, deadlineDay, deadlineTime, maxSubmitters, mTags, challengeId, courseId) -> do
        runDB $ do
          update achievementId [AchievementName =. name,
                                AchievementDescription =. description,
                                AchievementPoints =. points,
                                AchievementDeadline =. UTCTime { utctDay = deadlineDay,
                                                                 utctDayTime = timeOfDayToTime deadlineTime },
                                AchievementMaxWinners =. maxSubmitters,
                                AchievementChallenge =. challengeId,
                                AchievementCourse =. courseId]

          deleteWhere [AchievementTagAchievement ==. achievementId]
          tids <- tagsAsTextToTagIds mTags
          mapM (\tid -> insert $ AchievementTag achievementId tid) tids

        setMessage $ toHtml ("OK! Achievement modified" :: Text)
        return ()
      _ -> do
           return ()


  defaultLayout $ do
    setTitle "Edit achievements"
    $(widgetFile "edit-achievement")