chore(tutorial): towards #37 by adding new tutorials from template
This commit is contained in:
parent
94b48f59cf
commit
930bcef9cd
@ -47,6 +47,10 @@ tutorialTemplateNames :: Maybe TutorialType -> [TutorialType]
|
||||
tutorialTemplateNames Nothing = ["Vorlage", "Template"]
|
||||
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, CI.mk tutorialTypeSeparator <> name]]
|
||||
|
||||
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
|
||||
-- tutorialDefaultName Nothing = tutorialDefaultName $ Just defaultTutorialType
|
||||
tutorialDefaultName _ = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users
|
||||
|
||||
|
||||
data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
@ -139,27 +143,28 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler
|
||||
getCAddUserR = postCAddUserR
|
||||
postCAddUserR tid ssh csh = do
|
||||
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users
|
||||
handleAddUserR tid ssh csh (Right today) Nothing
|
||||
-- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users
|
||||
|
||||
--TODO: Refactor above to send Day instead of TutorialName and refactor below to accept Either Day TutorialName or maybe even TutorialId?
|
||||
|
||||
getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTAddUserR = postTAddUserR
|
||||
postTAddUserR tid ssh csh tut = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
(cid,tutTypes,tutorial) <- runDB $ do
|
||||
postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing
|
||||
|
||||
|
||||
handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
|
||||
handleAddUserR tid ssh csh tdesc ttyp = do
|
||||
(cid, tutTypes) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
tutTypes <- E.select $ E.distinct $ do
|
||||
tutorial <- E.from $ E.table @Tutorial
|
||||
let ttyp = tutorial E.^. TutorialType
|
||||
let tuTyp = tutorial E.^. TutorialType
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. E.not_ (E.any (E.hasPrefix_ ttyp . E.val) (tutorialTemplateNames Nothing))
|
||||
E.&&. E.not_ (E.any (E.hasPrefix_ tuTyp . E.val) (tutorialTemplateNames Nothing))
|
||||
-- ((\pfx -> E.val pfx `E.isPrefixOf_` tutorial E.^. TutorialType) (tutorialTemplateNames Nothing))
|
||||
E.orderBy [E.asc ttyp]
|
||||
return ttyp
|
||||
tutorial <- getBy $ UniqueTutorial cid tut
|
||||
return (cid, E.unValue <$> tutTypes, tutorial)
|
||||
E.orderBy [E.asc tuTyp]
|
||||
return tuTyp
|
||||
return (cid, E.unValue <$> tutTypes)
|
||||
|
||||
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
@ -171,26 +176,26 @@ postTAddUserR tid ssh csh tut = do
|
||||
tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
|
||||
actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
|
||||
registeredUsers <- registerUsers cid users
|
||||
forM_ actTutorial $ \(tutName,tutType,tutDay) -> do
|
||||
tutId <- upsertNewTutorial cid (fromMaybe "TODO" tutName) tutType tutDay
|
||||
registerTutorialMembers tutId registeredUsers
|
||||
|
||||
if
|
||||
| Just tutName <- actTutorial -- CONTINUE HERE
|
||||
, Set.size tutActs == Set.size confirmedActs
|
||||
-> redirect $ CTutorialR tid ssh csh tutName TUsersR
|
||||
| otherwise
|
||||
-> redirect $ CourseR tid ssh csh CUsersR
|
||||
whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
|
||||
whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
|
||||
tutId <- upsertNewTutorial cid tName tutType tutDay
|
||||
registerTutorialMembers tutId registeredUsers
|
||||
-- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
|
||||
redirect $ CTutorialR tid ssh csh tName TUsersR
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
|
||||
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
let tutTypesMsg = [(SomeMessage tt,tt)| tt <- tutTypes]
|
||||
let tutTypesMsg = [(SomeMessage tt,tt)| tt <- tutTypes]
|
||||
tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
|
||||
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
|
||||
auReqTutorial <- optionalActionW
|
||||
( (,,)
|
||||
<$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ Just tut)
|
||||
<*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just ((tutorial ^? _entityVal . _tutorialType) <|> listToMaybe tutTypes))
|
||||
<$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
|
||||
(Just $ maybeLeft tdesc)
|
||||
<*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType)
|
||||
(Just tutDefType)
|
||||
<*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
|
||||
(Just ((tutorial ^? _entityVal . _tutorialFirstDay) <|> Just nowaday))
|
||||
(Just $ maybeRight tdesc)
|
||||
)
|
||||
( fslI MsgCourseParticipantsRegisterTutorialOption )
|
||||
( Just True )
|
||||
@ -300,19 +305,19 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do
|
||||
|
||||
return $ mempty { aurRegisterSuccess = Set.singleton uid }
|
||||
|
||||
upsertNewTutorial :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId
|
||||
upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do
|
||||
upsertNewTutorial :: CourseId -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId
|
||||
upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
existingTut <- getBy $ UniqueTutorial cid newTutorialName
|
||||
templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType]
|
||||
case (existingTut, anchorDay, templateEnt) of
|
||||
case (existingTut, newFirstDay, templateEnt) of
|
||||
(Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day
|
||||
(Nothing, Just newFirstDay, Just Entity{entityVal=Tutorial{..}}) -> do
|
||||
(Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do
|
||||
Course{..} <- get404 cid
|
||||
term <- get404 courseTerm
|
||||
let oldFirstDay = fromMaybe newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
|
||||
newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime
|
||||
dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay
|
||||
let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
|
||||
newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime
|
||||
dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay
|
||||
mvTime = fmap $ addLocalDays dayDiff
|
||||
newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType
|
||||
newType = if newType0 `elem` tutorialTemplateNames Nothing
|
||||
@ -323,7 +328,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do
|
||||
{ tutorialName = newTutorialName
|
||||
, tutorialCourse = cid
|
||||
, tutorialType = newType
|
||||
, tutorialFirstDay = anchorDay
|
||||
, tutorialFirstDay = newFirstDay
|
||||
, tutorialTime = newTime
|
||||
, tutorialRegisterFrom = mvTime tutorialRegisterFrom
|
||||
, tutorialRegisterTo = mvTime tutorialRegisterTo
|
||||
@ -349,7 +354,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, tutorialLastChanged = now
|
||||
, tutorialTutorControlled = False
|
||||
, tutorialFirstDay = anchorDay
|
||||
, tutorialFirstDay = Nothing
|
||||
} [] -- update cannot happen due to previous cases
|
||||
audit $ TransactionTutorialEdit tutId
|
||||
return tutId
|
||||
|
||||
@ -44,9 +44,10 @@ getCTutorialListR tid ssh csh = do
|
||||
dbtRowKey = (E.^. TutorialId)
|
||||
dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||
, sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do
|
||||
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "first-day") (i18nCell MsgTableTutorialFirstDay) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> cellMaybe dayCell tutorialFirstDay
|
||||
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||
, sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do
|
||||
tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
@ -73,8 +74,9 @@ getCTutorialListR tid ssh csh = do
|
||||
linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
||||
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
||||
[ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
||||
, ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
||||
, ("first-day", SortColumn $ \tutorial -> tutorial E.^. TutorialFirstDay )
|
||||
, ( "tutors"
|
||||
, SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
@ -104,7 +106,7 @@ getCTutorialListR tid ssh csh = do
|
||||
dbtExtraReps = []
|
||||
|
||||
tutorialDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
||||
& defaultSorting [SortAscBy "type", SortDescBy "first-day", SortAscBy "name"]
|
||||
((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
||||
|
||||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do
|
||||
|
||||
@ -870,7 +870,7 @@ deepAlt altFst _ = altFst
|
||||
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
|
||||
maybeEmpty = flip foldMap
|
||||
|
||||
-- | also referred to as whenJust
|
||||
-- | also referred to as whenJust and forM_
|
||||
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
@ -46,6 +46,13 @@ insertFile residual fileTitle = do
|
||||
-}
|
||||
|
||||
|
||||
-- | Apply a function @n@ times to a given value. From GHC.Utils.Misc
|
||||
nTimes :: Int -> (a -> a) -> (a -> a)
|
||||
nTimes 0 _ = id
|
||||
nTimes 1 f = f
|
||||
nTimes n f = f . nTimes (n-1) f
|
||||
|
||||
|
||||
fillDb :: DB ()
|
||||
fillDb = do
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings
|
||||
@ -993,6 +1000,42 @@ fillDb = do
|
||||
Thursday -> "A380"
|
||||
_ -> "B777"
|
||||
, tutorialRoomHidden = False
|
||||
, tutorialTime = Occurrences
|
||||
{ occurrencesScheduled = Set.empty
|
||||
, occurrencesExceptions = Set.fromList
|
||||
[ ExceptOccur
|
||||
{ exceptDay = nTimes 7 succ firstDay
|
||||
, exceptStart = TimeOfDay 8 30 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
}
|
||||
, ExceptOccur
|
||||
{ exceptDay = nTimes 8 succ secondDay
|
||||
, exceptStart = TimeOfDay 9 0 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
}
|
||||
]
|
||||
}
|
||||
, tutorialRegGroup = Just "Schulung"
|
||||
, tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight
|
||||
, tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight
|
||||
, tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
|
||||
, tutorialLastChanged = now
|
||||
, tutorialTutorControlled = True
|
||||
, tutorialFirstDay = Just firstDay
|
||||
}
|
||||
insert_ $ Tutor tut1 jost
|
||||
insert_ Tutorial
|
||||
{ tutorialName = mkName "Vorlage"
|
||||
, tutorialCourse = c
|
||||
, tutorialType = "Schulung"
|
||||
, tutorialCapacity = capacity
|
||||
, tutorialRoom = Just $ case weekDay of
|
||||
Monday -> "A380"
|
||||
Tuesday -> "B747"
|
||||
Wednesday -> "MD11"
|
||||
Thursday -> "A380"
|
||||
_ -> "B777"
|
||||
, tutorialRoomHidden = False
|
||||
, tutorialTime = Occurrences
|
||||
{ occurrencesScheduled = Set.empty
|
||||
, occurrencesExceptions = Set.fromList
|
||||
@ -1016,7 +1059,6 @@ fillDb = do
|
||||
, tutorialTutorControlled = True
|
||||
, tutorialFirstDay = Just firstDay
|
||||
}
|
||||
insert_ $ Tutor tut1 jost
|
||||
void . insert' $ Exam
|
||||
{ examCourse = c
|
||||
, examName = mkName "Theorieprüfung"
|
||||
|
||||
Reference in New Issue
Block a user