gonito/Handler/Achievements.hs

261 lines
11 KiB
Haskell
Raw Normal View History

2017-02-26 21:40:38 +01:00
module Handler.Achievements where
import Import
import Handler.Common (checkIfAdmin)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import Handler.TagUtils
import Handler.Tables
2017-03-13 12:00:38 +01:00
import Handler.Shared
2017-02-26 21:40:38 +01:00
2017-05-15 13:55:56 +02:00
import Handler.AchievementUtils
2017-02-26 21:40:38 +01:00
import Data.Time.LocalTime
2017-03-13 12:00:38 +01:00
import Data.Text
2017-02-26 21:40:38 +01:00
import qualified Yesod.Table as Table
2018-04-07 18:51:58 +02:00
getGonitoInClassR :: Handler Html
getGonitoInClassR = do
defaultLayout $ do
setTitle "Achievements"
$(widgetFile "gonito-in-class")
2017-02-26 21:40:38 +01:00
getAchievementsR :: Handler Html
getAchievementsR = do
2017-10-20 09:24:36 +02:00
(formWidget, formEnctype) <- generateFormPost (achievementForm Nothing Nothing)
2017-02-26 21:40:38 +01:00
mUser <- maybeAuth
doAchievements mUser formWidget formEnctype
postAchievementsR :: Handler Html
postAchievementsR = do
2017-10-20 09:24:36 +02:00
((result, formWidget), formEnctype) <- runFormPost (achievementForm Nothing Nothing)
2017-02-26 21:40:38 +01:00
mUser <- maybeAuth
when (checkIfAdmin mUser) $ do
case result of
FormSuccess (name, description, points, deadlineDay, deadlineTime, maxSubmitters, mTags, challengeId, courseId) -> do
2017-10-03 07:23:52 +02:00
achievementId <- runDB $ insert $ Achievement name challengeId points description (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) maxSubmitters courseId
2017-02-26 21:40:38 +01:00
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]
2017-03-13 12:00:38 +01:00
mUser <- maybeAuth
2017-10-20 10:00:03 +02:00
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'
2017-02-26 21:40:38 +01:00
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
defaultLayout $ do
setTitle "Achievements"
$(widgetFile "achievements")
2017-10-20 10:00:03 +02:00
isParticipant :: [CourseId] -> AchievementInfo -> Bool
isParticipant [] _ = True
isParticipant courses info = (entityKey $ achievementInfoCourse info) `elem` courses
2017-10-20 09:24:36 +02:00
achievementsTable :: Bool -> Table.Table App (AchievementInfo)
achievementsTable canEdit = mempty
++ achievementNameEntry canEdit
2017-10-03 07:23:52 +02:00
++ Table.text "course" (courseName . entityVal . achievementInfoCourse)
2017-03-18 19:53:32 +01:00
++ Table.linked "challenge" (challengeTitle . entityVal . achievementInfoChallenge) (ShowChallengeR . challengeName . entityVal . achievementInfoChallenge)
2017-05-15 13:55:56 +02:00
++ achievementDescriptionCell id
2017-03-13 12:00:38 +01:00
++ Table.int "points" achievementInfoPoints
++ timestampCell "deadline" achievementInfoDeadline
++ Table.string "max submitters" (formatMaxSubmitters . achievementInfoMaxWinners)
2017-03-18 21:33:41 +01:00
++ workingOnCell
2017-10-20 09:24:36 +02:00
achievementNameEntry True = Table.linked "achievement" (achievementInfoName) (EditAchievementR . achievementInfoId)
achievementNameEntry False = Table.text "achievement" achievementInfoName
2017-03-18 21:33:41 +01:00
workingOnCell = Table.widget "who's working on it?" workingOnWidget
workingOnWidget ainfo = [whamlet|
#{srs}
$if canStartWorkingOn
\ <a href=@{StartWorkingOnR (achievementInfoId ainfo)}>start working</a>
2017-04-03 11:27:08 +02:00
$if canGiveUpWorkingOn
\ <a href=@{GiveUpWorkingOnR (achievementInfoId ainfo)}>give up</a>
2017-03-18 21:33:41 +01:00
|]
where srs = formatSubmitters $ achievementInfoWorkingOn ainfo
canStartWorkingOn = determineWhetherCanStartWorkingOn (achievementInfoCurrentUser ainfo) (achievementInfoWorkingOn ainfo) (achievementInfoMaxWinners ainfo)
2017-04-03 11:27:08 +02:00
canGiveUpWorkingOn = determineWhetherCanGiveUpWorkingOn (achievementInfoCurrentUser ainfo) (achievementInfoWorkingOn ainfo)
2017-03-18 21:33:41 +01:00
2017-04-03 12:22:52 +02:00
getSubmissionForAchievementR :: SubmissionId -> WorkingOnId -> Handler Html
getSubmissionForAchievementR submissionId workingOnId = do
2018-09-14 15:42:19 +02:00
(Entity userId _) <- requireAuth
2017-04-03 12:22:52 +02:00
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
2017-03-18 21:33:41 +01:00
getStartWorkingOnR :: AchievementId -> Handler Html
getStartWorkingOnR achievementId = do
(Entity userId user) <- requireAuth
achievement <- runDB $ get404 achievementId
let courseId = achievementCourse achievement
2017-03-18 21:33:41 +01:00
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
2017-03-18 21:33:41 +01:00
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)
2017-03-18 21:33:41 +01:00
redirect $ AchievementsR
2017-04-03 11:27:08 +02:00
getGiveUpWorkingOnR :: AchievementId -> Handler Html
getGiveUpWorkingOnR achievementId = do
2018-09-14 15:42:19 +02:00
(Entity userId _) <- requireAuth
2017-04-03 11:27:08 +02:00
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
2017-03-18 21:33:41 +01:00
determineWhetherCanStartWorkingOn Nothing _ _ = False
2018-09-14 15:42:19 +02:00
determineWhetherCanStartWorkingOn (Just (Entity userId _)) peopleWorkingOn maxWinners =
2017-03-18 21:33:41 +01:00
(Import.all (\e -> (userId /= entityKey e)) peopleWorkingOn) && (checkLimit peopleWorkingOn maxWinners)
2017-04-03 11:27:08 +02:00
determineWhetherCanGiveUpWorkingOn Nothing _ = False
2018-09-14 15:42:19 +02:00
determineWhetherCanGiveUpWorkingOn (Just (Entity userId _)) peopleWorkingOn =
2017-04-03 11:27:08 +02:00
(Import.any (\e -> (userId == entityKey e)) peopleWorkingOn)
2017-03-18 21:33:41 +01:00
checkLimit _ Nothing = True
checkLimit peopleWorkingOn (Just m) = (Import.length peopleWorkingOn) < m
2017-03-13 12:00:38 +01:00
formatSubmitters userEnts = Data.Text.intercalate ", " $ Import.map (formatSubmitter . entityVal) userEnts
2017-03-13 11:26:39 +01:00
formatMaxSubmitters :: Maybe Int -> String
formatMaxSubmitters Nothing = "no limit"
formatMaxSubmitters (Just m) = show m
2017-02-26 21:40:38 +01:00
2017-10-20 09:24:36 +02:00
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
2017-10-20 09:24:36 +02:00
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
2017-10-20 09:24:36 +02:00
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")