SJost
parent
0a3b09f5ee
commit
66ab0f9be6
@ -228,6 +228,7 @@ CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
|
||||
NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
|
||||
|
||||
RatingBy: Korrigiert von
|
||||
AssignedTime: Zuteilung
|
||||
AchievedBonusPoints: Erreichte Bonuspunkte
|
||||
AchievedNormalPoints: Erreichte Punkte
|
||||
AchievedPassPoints: Erreichte Punkte
|
||||
|
||||
3
models
3
models
@ -41,7 +41,7 @@ StudyTerms
|
||||
Primary key
|
||||
Term json
|
||||
name TermIdentifier -- unTermKey :: TermId -> TermIdentifier
|
||||
start Day -- TermKey :: TermIdentifier -< TermId
|
||||
start Day -- TermKey :: TermIdentifier -> TermId
|
||||
end Day
|
||||
holidays [Day]
|
||||
lectureStart Day
|
||||
@ -136,6 +136,7 @@ Submission
|
||||
ratingPoints Points Maybe -- "Just" does not mean done
|
||||
ratingComment Text Maybe -- "Just" does not mean done
|
||||
ratingBy UserId Maybe -- assigned corrector
|
||||
ratingAssigned UTCTime Maybe -- time assigned corrector
|
||||
ratingTime UTCTime Maybe -- "Just" here indicates done!
|
||||
deriving Show
|
||||
SubmissionEdit
|
||||
|
||||
2
routes
2
routes
@ -55,10 +55,12 @@
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand} CourseNewTemplateR GET !lecturer
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET
|
||||
/user/#CryptoUUIDUser CUserR GET
|
||||
/correctors CHiWisR GET
|
||||
|
||||
@ -79,7 +79,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
|
||||
case loginRes of
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage "error" . toHtml
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
FormSuccess CampusLogin{..} -> do
|
||||
|
||||
@ -81,7 +81,7 @@ import Utils
|
||||
import Utils.Form
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson hiding (Error)
|
||||
import Data.Aeson.TH
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
@ -308,7 +308,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
[("free", trueAP)
|
||||
,("deprecated", APHandler $ \r _ -> do
|
||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||
addMessageI "error" MsgDeprecatedRoute
|
||||
addMessageI Error MsgDeprecatedRoute
|
||||
allow <- appAllowDeprecated . appSettings <$> getYesod
|
||||
return $ bool (Unauthorized "Deprecated Route") Authorized allow
|
||||
)
|
||||
@ -850,12 +850,6 @@ pageActions (CourseListR) =
|
||||
]
|
||||
pageActions (CourseR tid ssh csh CShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Kurs Editieren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid ssh csh CEditR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Übungsblätter"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid ssh csh SheetListR
|
||||
@ -877,12 +871,24 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
, menuItemRoute = CourseR tid ssh csh CCorrectionsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionSecondary $ MenuItem
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid ssh csh SheetNewR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionSecondary $ MenuItem
|
||||
{ menuItemLabel = "Kurs editieren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid ssh csh CEditR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionSecondary $ MenuItem
|
||||
{ menuItemLabel = "Neuen Kurs klonen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid ssh csh SheetListR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
@ -1152,7 +1158,7 @@ instance YesodAuth UniWorX where
|
||||
excHandlers
|
||||
| isDummy || isPWFile
|
||||
= [ C.Handler $ \err -> do
|
||||
addMessage "error" (toHtml $ tshow (err :: CampusUserException))
|
||||
addMessage Error (toHtml $ tshow (err :: CampusUserException))
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
acceptExisting
|
||||
]
|
||||
|
||||
@ -54,7 +54,7 @@ postAdminTestR = do
|
||||
((btnResult,_), _) <- runFormPost $ buttonForm
|
||||
case btnResult of
|
||||
(FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt"
|
||||
(FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
|
||||
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
|
||||
_other -> return ()
|
||||
getAdminTestR
|
||||
|
||||
|
||||
@ -148,6 +148,16 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
in anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
|
||||
colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
|
||||
maybe mempty timeCell submissionRatingAssigned
|
||||
|
||||
colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
|
||||
maybe mempty timeCell submissionRatingTime
|
||||
|
||||
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
@ -248,7 +258,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
|
||||
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
|
||||
case actionRes of
|
||||
FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
|
||||
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
|
||||
FormMissing -> return ()
|
||||
FormSuccess (CorrDownloadData, subs) -> do
|
||||
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||||
@ -256,26 +266,32 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
sendResponse =<< submissionMultiArchive ids
|
||||
FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ do
|
||||
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
||||
when (not $ null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
when (not $ null unassigned) $ do
|
||||
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
|
||||
addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num
|
||||
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
|
||||
[ SubmissionRatingBy =. Just uid
|
||||
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
|
||||
]
|
||||
addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingTime =. Nothing
|
||||
]
|
||||
addMessageI "success" $ MsgRemovedCorrections num
|
||||
num <- updateWhereCount [SubmissionId <-. subs]
|
||||
[ SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingAssigned =. Nothing
|
||||
, SubmissionRatingTime =. Nothing
|
||||
]
|
||||
addMessageI Success $ MsgRemovedCorrections num
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
@ -284,16 +300,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
when (not $ null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
when (not $ null unassigned) $ do
|
||||
(assigned, unassigned) <- assignSubmissions shid (Just unassigned)
|
||||
when (not $ null assigned) $
|
||||
addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
|
||||
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
|
||||
when (not $ null unassigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission)
|
||||
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
||||
redirect currentRoute
|
||||
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
@ -346,7 +362,9 @@ postCorrectionsR = do
|
||||
, colCourse
|
||||
, colSheet
|
||||
, colSubmissionLink
|
||||
, colAssigned
|
||||
, colRating
|
||||
, colRated
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
@ -360,15 +378,17 @@ getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid ssh csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let whereClause = courseIs cid
|
||||
colonnade = mconcat
|
||||
colonnade = mconcat -- should match getSSubsR for consistent UX
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, colSheet
|
||||
, colCorrector
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
, colAssigned
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
correctionsR whereClause colonnade psValidator $ Map.fromList
|
||||
@ -381,14 +401,16 @@ getSSubsR = postSSubsR
|
||||
postSSubsR tid ssh csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
let whereClause = sheetIs shid
|
||||
colonnade = mconcat
|
||||
colonnade = mconcat -- should match getCCorrectionsR for consistent UX
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
, colAssigned
|
||||
]
|
||||
psValidator = def
|
||||
correctionsR whereClause colonnade psValidator $ Map.fromList
|
||||
@ -433,7 +455,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
|
||||
case corrResult of
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess (ratingPoints, ratingComment) -> do
|
||||
runDB $ do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
@ -442,23 +464,25 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
let rated = isJust $ void ratingPoints <|> void ratingComment
|
||||
|
||||
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
|
||||
-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
|
||||
-- , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
|
||||
, SubmissionRatingTime =. (now <$ guard rated)
|
||||
, SubmissionRatingPoints =. ratingPoints
|
||||
, SubmissionRatingComment =. ratingComment
|
||||
]
|
||||
|
||||
addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
|
||||
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
case uploadResult of
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess fileSource -> do
|
||||
uid <- requireAuthId
|
||||
|
||||
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||
|
||||
addMessageI "success" MsgRatingFilesUpdated
|
||||
addMessageI Success MsgRatingFilesUpdated
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
defaultLayout $ do
|
||||
@ -488,16 +512,16 @@ postCorrectionsUploadR = do
|
||||
|
||||
case uploadRes of
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess files -> do
|
||||
uid <- requireAuthId
|
||||
subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
|
||||
if
|
||||
| null subs -> addMessageI "warning" MsgNoCorrectionsUploaded
|
||||
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
||||
| otherwise -> do
|
||||
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
|
||||
mr <- (toHtml .) <$> getMessageRender
|
||||
addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
|
||||
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
|
||||
|
||||
|
||||
defaultLayout $ do
|
||||
|
||||
@ -304,51 +304,52 @@ postCRegisterR tid ssh csh = do
|
||||
(FormSuccess codeOk)
|
||||
| registered -> do
|
||||
runDB $ deleteBy $ UniqueParticipant aid cid
|
||||
addMessageI "info" MsgCourseDeregisterOk
|
||||
addMessageI Info MsgCourseDeregisterOk
|
||||
| codeOk -> do
|
||||
actTime <- liftIO $ getCurrentTime
|
||||
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
|
||||
when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk
|
||||
| otherwise -> addMessageI "danger" MsgCourseSecretWrong
|
||||
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
|
||||
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
||||
(_other) -> return () -- TODO check this!
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
getCourseNewR :: Handler Html
|
||||
getCourseNewR :: Handler Html -- call via toTextUrl
|
||||
getCourseNewR = do
|
||||
uid <- requireAuthId
|
||||
params <- runInputGetResult $ (,,)
|
||||
<$> ireq ciTextField "csh"
|
||||
<*> iopt textField "tid"
|
||||
<*> iopt ciTextField "ssh"
|
||||
params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button
|
||||
<$> iopt termNewField "tid"
|
||||
<*> iopt ciTextField "ssh"
|
||||
<*> iopt ciTextField "csh"
|
||||
let noTemplateAction = courseEditHandler True Nothing
|
||||
case params of
|
||||
FormMissing -> noTemplateAction
|
||||
FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml)
|
||||
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml)
|
||||
>> noTemplateAction
|
||||
FormSuccess (csh,mbTid,mbSsh) -> do
|
||||
tid <- ifMaybeM mbTid Nothing $ \tid ->
|
||||
case termFromText tid of
|
||||
Left err -> addMessage "error" (toHtml err) >> return Nothing
|
||||
Right t -> return $ Just $ TermKey t
|
||||
getCourseNewTemplateR tid (SchoolKey <$> mbSsh) csh
|
||||
FormSuccess (mbTid,mbSsh,mbCsh) ->
|
||||
getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
|
||||
|
||||
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Handler Html
|
||||
getCourseNewTemplateR mbTid mbSsh csh = do
|
||||
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
|
||||
getCourseNewTemplateR mbTid mbSsh mbCsh = do
|
||||
uid <- requireAuthId
|
||||
oldCourses <- runDB $ do
|
||||
E.select $ E.from $ \course -> do
|
||||
E.where_ $ course E.^. CourseShorthand E.==. E.val csh
|
||||
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
|
||||
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
let lecturersSchool =
|
||||
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
|
||||
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
|
||||
let lecturersCourse =
|
||||
E.exists $ E.from $ \lecturer -> do
|
||||
E.where_ $ lecturer E.^. UserLecturerUser E.==. E.val uid
|
||||
E.&&. lecturer E.^. UserLecturerSchool E.==. course E.^. CourseSchool
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
||||
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
let lecturersSchool =
|
||||
E.exists $ E.from $ \user -> do
|
||||
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
|
||||
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
|
||||
let courseCreated c =
|
||||
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
|
||||
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
||||
return $ E.min_ $ edit E.^. CourseEditTime
|
||||
E.orderBy [ E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
|
||||
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
|
||||
, E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
|
||||
, E.desc $ courseCreated course] -- most recent created course
|
||||
E.limit 1
|
||||
return course
|
||||
@ -366,11 +367,11 @@ getCourseNewTemplateR mbTid mbSsh csh = do
|
||||
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
||||
<$> ifMaybeM mbTid True existsKey
|
||||
<*> ifMaybeM mbSsh True existsKey
|
||||
<*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
|
||||
unless tidOk $ addMessageI "warning" $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
|
||||
unless sshOk $ addMessageI "warning" $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
|
||||
unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh
|
||||
when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse
|
||||
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
|
||||
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
|
||||
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
|
||||
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
|
||||
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
|
||||
return Nothing
|
||||
courseEditHandler True template
|
||||
|
||||
@ -389,14 +390,16 @@ pgCEditR isGetReq tid ssh csh = do
|
||||
courseEditHandler isGetReq $ courseToForm <$> course
|
||||
|
||||
|
||||
courseDeleteHandler :: Handler Html -- not called anywhere yet
|
||||
courseDeleteHandler = undefined
|
||||
getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCDeleteR = error "TODO: implement getCDeleteR"
|
||||
postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCDeleteR = error "TODO: implement getCDeleteR"
|
||||
{- TODO
|
||||
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
|
||||
, Just cid <- cfCourseId res -> do
|
||||
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
||||
let cti = toPathPiece $ cfTerm res
|
||||
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
||||
addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
||||
redirect $ TermCourseListR $ cfTerm res
|
||||
-}
|
||||
|
||||
@ -435,10 +438,10 @@ courseEditHandler isGet mbCourseForm = do
|
||||
runDB $ do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
insert_ $ Lecturer aid cid
|
||||
addMessageI "info" $ MsgCourseNewOk tid ssh csh
|
||||
addMessageI Info $ MsgCourseNewOk tid ssh csh
|
||||
redirect $ TermCourseListR tid
|
||||
Nothing ->
|
||||
addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh
|
||||
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
|
||||
|
||||
(FormSuccess res@(
|
||||
CourseForm { cfCourseId = Just cid
|
||||
@ -451,7 +454,7 @@ courseEditHandler isGet mbCourseForm = do
|
||||
success <- runDB $ do
|
||||
old <- get cid
|
||||
case old of
|
||||
Nothing -> addMessageI "error" MsgInvalidInput $> False
|
||||
Nothing -> addMessageI Error MsgInvalidInput $> False
|
||||
(Just oldCourse) -> do
|
||||
updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
|
||||
Course { courseName = cfName res
|
||||
@ -469,14 +472,14 @@ courseEditHandler isGet mbCourseForm = do
|
||||
}
|
||||
)
|
||||
case updOkay of
|
||||
(Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False
|
||||
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
|
||||
Nothing -> do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
addMessageI "success" $ MsgCourseEditOk tid ssh csh
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
when success $ redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
(FormFailure _) -> addMessageI Warning MsgInvalidInput
|
||||
(FormMissing) -> return ()
|
||||
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
@ -526,6 +529,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
||||
]
|
||||
let termsField = case template of
|
||||
--TODO: if Admin, then all
|
||||
-- if allowed to delete course then allow current and all active term
|
||||
-- otherwise only keep current term
|
||||
(Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform]
|
||||
_allOtherCases -> termsActiveField
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
|
||||
@ -107,7 +107,7 @@ homeAnonymous = do
|
||||
, dbtIdent = "upcomingdeadlines" :: Text
|
||||
}
|
||||
let features = $(widgetFile "featureList")
|
||||
addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
|
||||
addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
|
||||
defaultLayout $ do
|
||||
$(widgetFile "dsgvDisclaimer")
|
||||
$(widgetFile "home")
|
||||
@ -207,7 +207,7 @@ homeUser uid = do
|
||||
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
||||
, dbtIdent = "upcomingdeadlines" :: Text
|
||||
}
|
||||
addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
||||
addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
||||
defaultLayout $ do
|
||||
-- setTitle "Willkommen zum Uni2work Test!"
|
||||
$(widgetFile "homeUser")
|
||||
|
||||
@ -87,10 +87,10 @@ getProfileR = do
|
||||
, OffsetBy $ stgMaxFavourties
|
||||
]
|
||||
mapM_ delete oldFavs
|
||||
addMessageI "info" $ MsgSettingsUpdate
|
||||
addMessageI Info $ MsgSettingsUpdate
|
||||
redirect ProfileR -- TODO: them change does not happen without redirect
|
||||
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
|
||||
_ -> return ()
|
||||
|
||||
|
||||
|
||||
@ -305,7 +305,7 @@ getSShowR tid ssh csh shn = do
|
||||
return (hasHints, hasSolution)
|
||||
cTime <- Just <$> liftIO getCurrentTime
|
||||
visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet
|
||||
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
|
||||
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
|
||||
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tid ssh csh shn
|
||||
@ -444,21 +444,21 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
Nothing -> False <$ addMessageI "error" (MsgSheetNameDup tid ssh csh sfName)
|
||||
Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
|
||||
(Just sid) -> do -- save files in DB:
|
||||
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
||||
whenIsJust sfHintF $ insertSheetFile' sid SheetHint
|
||||
whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
|
||||
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
|
||||
addMessageI Info $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
|
||||
return True
|
||||
when saveOkay $ redirect $ case msId of
|
||||
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
Nothing -> CSheetR tid ssh csh sfName SCorrR
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "error") . toHtml
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
|
||||
<$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
|
||||
|
||||
@ -481,7 +481,7 @@ getSDelR tid ssh csh shn = do
|
||||
(FormSuccess BtnDelete) -> do
|
||||
runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
|
||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
||||
addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
|
||||
addMessageI Info $ MsgSheetDelOk tid ssh csh shn
|
||||
redirect $ CourseR tid ssh csh SheetListR
|
||||
_other -> do
|
||||
submissionno <- runDB $ do
|
||||
@ -572,7 +572,7 @@ correctorForm shid = do
|
||||
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
|
||||
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
|
||||
| Map.null currentLoads'
|
||||
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
|
||||
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
|
||||
| otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
|
||||
|
||||
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
|
||||
@ -608,11 +608,11 @@ correctorForm shid = do
|
||||
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
|
||||
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
|
||||
case mUid of
|
||||
Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
|
||||
Nothing -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
|
||||
Just uid
|
||||
| not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
|
||||
| otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
|
||||
FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
|
||||
| otherwise -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
|
||||
FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
|
||||
_ -> return loads''
|
||||
|
||||
let deletions' = deletions `Set.difference` Map.keysSet loads
|
||||
@ -703,11 +703,11 @@ getSCorrR tid ssh csh shn = do
|
||||
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
||||
|
||||
case res of
|
||||
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess res -> runDB $ do
|
||||
deleteWhere [SheetCorrectorSheet ==. shid]
|
||||
insertMany_ $ Set.toList res
|
||||
addMessageI "success" MsgCorrectorsUpdated
|
||||
addMessageI Success MsgCorrectorsUpdated
|
||||
FormMissing -> return ()
|
||||
|
||||
let
|
||||
|
||||
@ -147,7 +147,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
return (csheet, map E.unValue buddies, [])
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
addMessageI Info $ MsgSubmissionAlreadyExists
|
||||
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
(Just smid) -> do
|
||||
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
|
||||
@ -237,10 +237,11 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
(Nothing, Nothing) -- new submission, no file upload requested
|
||||
-> insert Submission
|
||||
{ submissionSheet = shid
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Nothing
|
||||
, submissionRatingAssigned = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
@ -258,7 +259,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
return smid
|
||||
cID <- encrypt smid
|
||||
return $ Just cID
|
||||
(FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
|
||||
(FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
|
||||
_other -> return Nothing
|
||||
|
||||
case mCID of
|
||||
|
||||
@ -167,12 +167,12 @@ termEditHandler term = do
|
||||
-- VOR INTERNATIONALISIERUNG:
|
||||
-- let tid = termToText $ termName res
|
||||
-- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
|
||||
-- addMessage "success" [shamlet| #{msg} |]
|
||||
-- addMessage Success [shamlet| #{msg} |]
|
||||
-- MIT INTERNATIONALISIERUNG:
|
||||
addMessageI "success" $ MsgTermEdited tid
|
||||
addMessageI Success $ MsgTermEdited tid
|
||||
redirect TermShowR
|
||||
(FormMissing ) -> return ()
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
(FormFailure _) -> addMessageI Warning MsgInvalidInput
|
||||
let actionUrl = TermEditR
|
||||
defaultLayout $ do
|
||||
setTitleI MsgTermEditHeading
|
||||
|
||||
@ -118,5 +118,5 @@ postAdminHijackUserR cID = do
|
||||
get404 uid
|
||||
setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
|
||||
| otherwise -> error "This should be impossible by definition of `hijackUserForm`"
|
||||
FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs
|
||||
FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
|
||||
FormMissing -> return $ toTypedContent ()
|
||||
|
||||
@ -68,7 +68,7 @@ warnTermDays tid times = do
|
||||
outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays
|
||||
outoflecture = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
|
||||
`Set.difference` outoftermdays -- out of term implies out of lecture-time
|
||||
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt
|
||||
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
|
||||
forM_ warnholidays $ warnI MsgDayIsAHoliday
|
||||
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
||||
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
||||
|
||||
@ -222,26 +222,17 @@ termsActiveField :: Field Handler TermId
|
||||
termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termsSetField :: [TermId] -> Field Handler TermId
|
||||
-- termsSetField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName
|
||||
termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
|
||||
termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
|
||||
-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
|
||||
|
||||
termsActiveOrSetField :: [TermId] -> Field Handler TermId
|
||||
termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
|
||||
where terms = map unTermKey tids
|
||||
-- termActiveOld :: Field Handler TermIdentifier
|
||||
-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termNewField :: Field Handler TermIdentifier
|
||||
termNewField = checkMMap checkTerm termToText textField
|
||||
where
|
||||
errTextParse :: Text
|
||||
errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
|
||||
|
||||
errTextFreigabe :: TermIdentifier -> Text
|
||||
errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
|
||||
|
||||
checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
|
||||
checkTerm t = case termFromText t of
|
||||
Left _ -> return $ Left errTextParse
|
||||
res@(Right _) -> return res
|
||||
|
||||
termNewField = checkMMap (return.termFromText) termToText textField
|
||||
|
||||
schoolField :: Field Handler SchoolId
|
||||
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
|
||||
|
||||
@ -210,7 +210,10 @@ assignSubmissions sid restriction = do
|
||||
$logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)"
|
||||
assignSubmission (countsToLoad' q) smid q
|
||||
|
||||
forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
|
||||
now <- liftIO getCurrentTime
|
||||
forM_ (Map.toList subTutor) $
|
||||
\(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid
|
||||
, SubmissionRatingAssigned =. Just now ]
|
||||
|
||||
let assignedSubmissions = Map.keysSet subTutor
|
||||
unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
|
||||
@ -325,7 +328,7 @@ extractRatingsMsg = do
|
||||
ignored = Right `Set.map` ignored'
|
||||
unless (null ignored) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
|
||||
sinkSubmission :: UserId
|
||||
-> Either SheetId SubmissionId
|
||||
@ -343,11 +346,13 @@ sinkSubmission userId mExists isUpdate = do
|
||||
sId <- lift $ case mExists of
|
||||
Left sheetId -> do
|
||||
let
|
||||
submissionSheet = sheetId
|
||||
submissionRatingPoints = Nothing
|
||||
submissionRatingComment = Nothing
|
||||
submissionRatingBy = Nothing
|
||||
submissionRatingTime = Nothing
|
||||
submissionSheet = sheetId
|
||||
submissionRatingPoints = Nothing
|
||||
submissionRatingComment = Nothing
|
||||
submissionRatingBy = Nothing
|
||||
submissionRatingAssigned = Nothing
|
||||
submissionRatingTime = Nothing
|
||||
|
||||
sId <- insert Submission{..}
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
|
||||
@ -466,6 +471,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
lift $ case isUpdate of
|
||||
False -> insert_ $ SubmissionEdit userId now submissionId
|
||||
True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
|
||||
-- TODO: Should submissionRatingAssigned change here if userId changes?
|
||||
tell $ mempty{ sinkSubmissionTouched = Any True }
|
||||
|
||||
finalize :: SubmissionSinkState -> YesodDB UniWorX ()
|
||||
@ -586,7 +592,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
lift . feed sId $ Left f{ fileTitle = fileTitle' }
|
||||
when (not $ null ignored) $ do
|
||||
mr <- (toHtml .) <$> getMessageRender
|
||||
addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
|
||||
cID <- encrypt sId
|
||||
handle (throwM . SubmissionSinkException cID Nothing) $
|
||||
|
||||
@ -402,7 +402,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
<* E.offset (psPage * psLimit)
|
||||
<* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
|
||||
|
||||
mapM_ (addMessageI "warning") errs
|
||||
mapM_ (addMessageI Warning) errs
|
||||
|
||||
runDB $ do
|
||||
rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
|
||||
|
||||
@ -293,7 +293,7 @@ termFromText t
|
||||
, Just (review shortened -> year) <- readMaybe ys
|
||||
, Right season <- seasonFromChar s
|
||||
= Right TermIdentifier{..}
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
|
||||
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
|
||||
@ -368,11 +368,13 @@ deriveJSON defaultOptions
|
||||
{ constructorTagModifier = fromJust . stripPrefix "Theme"
|
||||
} ''Theme
|
||||
|
||||
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
|
||||
|
||||
instance Universe Theme where universe = universeDef
|
||||
instance Finite Theme
|
||||
|
||||
instance PathPiece Theme where
|
||||
toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
|
||||
toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
|
||||
@ -397,6 +399,8 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
|
||||
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
|
||||
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
|
||||
} ''CorrectorState
|
||||
|
||||
@ -31,7 +31,7 @@ import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import Utils
|
||||
import Utils hiding (MessageClass(..))
|
||||
import Control.Lens
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
35
src/Utils/Message.hs
Normal file
35
src/Utils/Message.hs
Normal file
@ -0,0 +1,35 @@
|
||||
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module Utils.Message
|
||||
( MessageClass(..)
|
||||
, addMessage, addMessageI
|
||||
) where
|
||||
|
||||
|
||||
import Data.Text as Text (toLower)
|
||||
import Data.Universe
|
||||
import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
|
||||
|
||||
import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
|
||||
import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
|
||||
|
||||
|
||||
data MessageClass = Error | Warning | Info | Success
|
||||
deriving (Eq,Ord,Enum,Bounded,Show,Read)
|
||||
|
||||
instance Universe MessageClass
|
||||
instance Finite MessageClass
|
||||
|
||||
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
|
||||
|
||||
instance PathPiece MessageClass where
|
||||
toPathPiece = $(nullaryToPathPiece ''MessageClass [Text.toLower])
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
addMessage :: MonadHandler m => MessageClass-> Html -> m ()
|
||||
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
|
||||
|
||||
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
|
||||
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
|
||||
Loading…
Reference in New Issue
Block a user