gonito/Handler/Achievements.hs

176 lines
6.8 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
import Data.Time.Clock
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
2017-03-13 12:00:38 +01:00
data AchievementInfo = AchievementInfo {
2017-03-18 21:33:41 +01:00
achievementInfoId :: AchievementId,
2017-03-13 12:00:38 +01:00
achievementInfoName :: Text,
2017-03-18 19:53:32 +01:00
achievementInfoChallenge :: Entity Challenge,
2017-03-13 12:00:38 +01:00
achievementInfoDescription :: Maybe Text,
achievementInfoPoints :: Int,
achievementInfoDeadline :: UTCTime,
achievementInfoMaxWinners :: Maybe Int,
achievementInfoWorkingOn :: [Entity User],
2017-03-18 16:04:53 +01:00
achievementInfoCurrentUser :: Maybe (Entity User),
achievementInfoTags :: [Entity Tag] }
2017-03-13 12:00:38 +01:00
2017-02-26 21:40:38 +01:00
getAchievementsR :: Handler Html
getAchievementsR = do
(formWidget, formEnctype) <- generateFormPost achievementForm
mUser <- maybeAuth
doAchievements mUser formWidget formEnctype
postAchievementsR :: Handler Html
postAchievementsR = do
((result, formWidget), formEnctype) <- runFormPost achievementForm
mUser <- maybeAuth
when (checkIfAdmin mUser) $ do
case result of
2017-02-26 22:01:27 +01:00
FormSuccess (name, description, points, deadlineDay, deadlineTime, maxSubmitters, mTags) -> do
2017-02-26 21:40:38 +01:00
-- @TODO for the time being hardcoded
Just challengeEnt <- runDB $ getBy $ UniqueName "petite-difference-challenge2"
2017-02-26 22:01:27 +01:00
achievementId <- runDB $ insert $ Achievement name (entityKey challengeEnt) points description (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) maxSubmitters
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
achievementInfos <- runDB $ mapM (getAchievementInfo mUser) achievements
2017-02-26 21:40:38 +01:00
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
defaultLayout $ do
setTitle "Achievements"
$(widgetFile "achievements")
2017-03-13 12:00:38 +01:00
getAchievementInfo mUser (Entity achievementId achievement) = do
es <- selectList [WorkingOnAchievement ==. achievementId] []
let userIds = Import.map (workingOnUser . entityVal) es
users <- mapM get404 userIds
2017-03-18 16:04:53 +01:00
tags <- getAchievementTags achievementId
2017-03-18 19:53:32 +01:00
let challengeId = achievementChallenge achievement
challenge <- get404 challengeId
2017-03-13 12:00:38 +01:00
return $ AchievementInfo {
2017-03-18 21:33:41 +01:00
achievementInfoId = achievementId,
2017-03-13 12:00:38 +01:00
achievementInfoName = achievementName achievement,
2017-03-18 19:53:32 +01:00
achievementInfoChallenge = Entity challengeId challenge,
2017-03-13 12:00:38 +01:00
achievementInfoDescription = achievementDescription achievement,
achievementInfoPoints = achievementPoints achievement,
achievementInfoDeadline = achievementDeadline achievement,
achievementInfoMaxWinners = achievementMaxWinners achievement,
achievementInfoWorkingOn = Import.map (\(i,v) -> Entity i v) $ Import.zip userIds users,
2017-03-18 16:04:53 +01:00
achievementInfoCurrentUser = mUser,
achievementInfoTags = tags }
getAchievementTags achievementId = do
sts <- selectList [AchievementTagAchievement ==. achievementId] []
let tagIds = Import.map (achievementTagTag . entityVal) sts
tags <- mapM get404 $ tagIds
return $ Import.map (\(k, v) -> Entity k v) $ Import.zip tagIds tags
2017-03-13 12:00:38 +01:00
achievementsTable :: Table.Table App (AchievementInfo)
2017-02-26 21:40:38 +01:00
achievementsTable = mempty
2017-03-13 12:00:38 +01:00
++ Table.text "achievement" achievementInfoName
2017-03-18 19:53:32 +01:00
++ Table.linked "challenge" (challengeTitle . entityVal . achievementInfoChallenge) (ShowChallengeR . challengeName . entityVal . achievementInfoChallenge)
2017-03-18 16:04:53 +01:00
++ achievementDescriptionCell
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
workingOnCell = Table.widget "who's working on it?" workingOnWidget
workingOnWidget ainfo = [whamlet|
#{srs}
$if canStartWorkingOn
\ <a href=@{StartWorkingOnR (achievementInfoId ainfo)}>start working</a>
|]
where srs = formatSubmitters $ achievementInfoWorkingOn ainfo
canStartWorkingOn = determineWhetherCanStartWorkingOn (achievementInfoCurrentUser ainfo) (achievementInfoWorkingOn ainfo) (achievementInfoMaxWinners ainfo)
getStartWorkingOnR :: AchievementId -> Handler Html
getStartWorkingOnR achievementId = do
(Entity userId user) <- requireAuth
alreadyWorkingOn <- runDB $ selectList [WorkingOnUser ==. userId, WorkingOnFinalSubmission ==. Nothing] []
if Import.null alreadyWorkingOn
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
achievement <- runDB $ get404 achievementId
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!" :: Text)
redirect $ AchievementsR
determineWhetherCanStartWorkingOn Nothing _ _ = False
determineWhetherCanStartWorkingOn (Just (Entity userId user)) peopleWorkingOn maxWinners =
(Import.all (\e -> (userId /= entityKey e)) peopleWorkingOn) && (checkLimit peopleWorkingOn maxWinners)
checkLimit _ Nothing = True
checkLimit peopleWorkingOn (Just m) = (Import.length peopleWorkingOn) < m
2017-03-13 12:00:38 +01:00
2017-03-18 16:04:53 +01:00
achievementDescriptionCell = Table.widget "description" (
\ainfo -> fragmentWithTags (fromMaybe (""::Text) $ achievementInfoDescription ainfo) (achievementInfoTags ainfo))
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-02-26 22:01:27 +01:00
achievementForm :: Form (Text, Maybe Text, Int, Day, TimeOfDay, Maybe Int, Maybe Text)
achievementForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
2017-02-26 21:40:38 +01:00
<$> areq textField (bfs MsgAchievementName) Nothing
<*> aopt textField (bfs MsgAchievementDescription) Nothing
2017-02-26 22:01:27 +01:00
<*> areq intField (bfs MsgAchievementPoints) Nothing
2017-02-26 21:40:38 +01:00
<*> areq dayField (bfs MsgAchievementDeadlineDay) Nothing
<*> areq timeFieldTypeTime (bfs MsgAchievementDeadlineTime) Nothing
<*> aopt intField (bfs MsgAchievementMaxWinners) Nothing
<*> aopt textField (tagsfs MsgAchievementTags) Nothing