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.Clock import Data.Time.LocalTime import Data.Text import qualified Yesod.Table as Table 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 \ start working $if canGiveUpWorkingOn \ give up |] 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 user) <- 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 user) <- 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 user)) peopleWorkingOn maxWinners = (Import.all (\e -> (userId /= entityKey e)) peopleWorkingOn) && (checkLimit peopleWorkingOn maxWinners) determineWhetherCanGiveUpWorkingOn Nothing _ = False determineWhetherCanGiveUpWorkingOn (Just (Entity userId user)) 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 achievement <- runDB $ get404 achievementId ((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")