gonito/Handler/Achievements.hs

257 lines
11 KiB
Haskell

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
\ <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 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")