fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2018-09-28 21:34:07 +02:00
commit 7bafd767dd
30 changed files with 294 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/de.msg
View File

@ -223,11 +223,14 @@ NoCorrector: Kein Korrektor
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt.
CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
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
View File

@ -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

11
routes
View File

@ -39,7 +39,7 @@
/info VersionR GET !free
/profile ProfileR GET POST !free !free
/profile/data ProfileDataR GET !free !free
/profile/data ProfileDataR GET POST !free !free
/term TermShowR GET !free
/term/current TermCurrentR GET !free
@ -55,10 +55,15 @@
-- 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
/subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials
!/ex/new SheetNewR GET POST
@ -77,10 +82,6 @@
/correctors SCorrR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
-- /user/#CryptoUUIDUser
-- /users
-- /correctors
/corrections CorrectionsR GET POST !corrector !lecturer
/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer

2
src/Auth/Dummy.hs
View File

@ -52,7 +52,7 @@ dummyLogin = AuthPlugin{..}
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
case loginRes of
FormFailure errs -> do
lift . forM_ errs $ addMessage "error" . toHtml
lift . forM_ errs $ addMessage Error . toHtml
redirect LoginR
FormMissing -> redirect LoginR
FormSuccess ident ->

2
src/Auth/LDAP.hs
View File

@ -86,7 +86,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{ campusIdent = CI.original -> campusIdent, ..} -> do

2
src/Auth/PWHash.hs
View File

@ -61,7 +61,7 @@ hashLogin pwHashAlgo = AuthPlugin{..}
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm
case loginRes of
FormFailure errs -> do
forM_ errs $ addMessage "error" . toHtml
forM_ errs $ addMessage Error . toHtml
redirect LoginR
FormMissing -> redirect LoginR
FormSuccess HashLogin{..} -> do

26
src/Foundation.hs
View File

@ -82,7 +82,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
@ -311,7 +311,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
)
@ -853,12 +853,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
@ -880,12 +874,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
@ -1151,7 +1157,7 @@ instance YesodAuth UniWorX where
excHandlers
| isDummy || isPWHash
= [ C.Handler $ \err -> do
addMessage "error" (toHtml $ tshow (err :: CampusUserException))
addMessage Error (toHtml $ tshow (err :: CampusUserException))
$logErrorS "LDAP" $ tshow err
acceptExisting
]

8
src/Handler/Admin.hs
View File

@ -53,9 +53,9 @@ postAdminTestR :: Handler Html
postAdminTestR = do
((btnResult,_), _) <- runFormPost $ buttonForm
case btnResult of
(FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
_other -> return ()
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
_other -> addMessage Warning "KEIN Knopf erkannt"
getAdminTestR
@ -66,6 +66,6 @@ getAdminUserR uuid = do
defaultLayout $
[whamlet|
<h1>TODO
<h2>Admin Page for User #{display userDisplayName}
<h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
|]

88
src/Handler/Corrections.hs
View File

@ -123,8 +123,13 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName)
colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
csh = course ^. _2
tid = course ^. _3
ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid
cell = listCell (Map.toList users) $ \(userId, User{..}) -> do
anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@ -143,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 )
@ -243,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
@ -251,26 +266,38 @@ 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
(E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission
E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
return (E.countRows :: E.SqlExpr (E.Value Int64))
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
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'
@ -279,16 +306,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
@ -341,7 +368,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
@ -355,15 +384,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
@ -376,13 +407,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
, colCorrector
, colSMatrikel
, colSubmittors
, colSubmissionLink
, colRating
, colRated
, colCorrector
, colAssigned
]
psValidator = def
correctionsR whereClause colonnade psValidator $ Map.fromList
@ -427,7 +461,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
@ -436,23 +470,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
@ -482,16 +518,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

101
src/Handler/Course.hs
View File

@ -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 ciField "csh"
<*> iopt textField "tid"
<*> iopt ciField "ssh"
params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button
<$> iopt termNewField "tid"
<*> iopt ciField "ssh"
<*> iopt ciField "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
@ -587,3 +593,24 @@ validateCourse (CourseForm{..}) =
-- )
-- ,
] ]
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR tid ssh csh = undefined -- TODO
getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR tid ssh csh uuid = do
uid <- decrypt uuid
User{..} <- runDB $ get404 uid
defaultLayout $
[whamlet|
<h1>TODO
<h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
|]
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCHiWisR tid ssh csh = undefined -- TODO

4
src/Handler/Home.hs
View File

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

30
src/Handler/Profile.hs
View File

@ -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 ()
@ -140,13 +140,21 @@ postProfileR = do
-- TODO
getProfileR
postProfileDataR :: Handler Html
postProfileDataR = do
(uid, User{..}) <- requireAuthPair
((btnResult,_), _) <- runFormPost $ buttonForm
case btnResult of
(FormSuccess BtnDelete) -> addMessage Warning "Delete-Knopf gedrückt"
(FormSuccess BtnAbort ) -> addMessage Warning "Knopf Abort erkannt"
_other -> addMessage Warning "KEIN Knopf erkannt"
addMessage Error "Löschen der Daten wurde noch nicht implementiert."
getProfileDataR
getProfileDataR :: Handler Html
getProfileDataR = do
(uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender
-- Tabelle mit eigenen Kursen
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
@ -163,6 +171,20 @@ getProfileDataR = do
ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
-- TODO: move this into a Message and/or Widget-File
let delWdgt = [whamlet|
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
<div>Sind Sie sich absolut sicher, alle gespeicherten Daten zu löschen?
Abgegebene Hausaufgaben werden dadurch rückwirkend gelöscht,
wodurch eventuell ein Klausurbonus nicht mehr anerkannt wird.
<div>
<em>Gilt nicht in der Testphase von Uni2work:
Klausurnoten können Sie hiermit nicht löschen.
Da diese 5 Jahre bis nach Ihrer Exmatrikulation aufbewahrt werden müssen.
<div>^{btnWdgt}
|]
defaultLayout $ do
$(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer")

22
src/Handler/Sheet.hs
View File

@ -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

13
src/Handler/Submission.hs
View File

@ -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

6
src/Handler/Term.hs
View File

@ -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

2
src/Handler/Users.hs
View File

@ -120,5 +120,5 @@ postAdminHijackUserR cID = do
get404 uid
setCredsRedirect $ Creds "dummy" (CI.original 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 ()

2
src/Handler/Utils.hs
View File

@ -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

21
src/Handler/Utils/Form.hs
View File

@ -218,26 +218,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

22
src/Handler/Utils/Submission.hs
View File

@ -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) $

2
src/Handler/Utils/Table/Pagination.hs
View File

@ -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'

9
src/Handler/Utils/Templates.hs
View File

@ -16,6 +16,15 @@ modalStatic modalContent = do
$(widgetFile "widgets/modalStatic")
[whamlet|<div .tooltip__handle ##{uniqueId}>?|] -- SJ: confused why ## is needed here either?
modalWidget :: Html -> WidgetT site IO () -> WidgetT site IO ()
modalWidget modalTrigger modalContent = do
uniqueId <- newIdent
let modalTriggerId = cons '#' uniqueId -- SJ: I am confused why this is needed here?
modalId :: Int32
modalId = 13
$(widgetFile "widgets/modalWidget")
[whamlet|<div .btn ##{uniqueId}>#{modalTrigger}|] -- SJ: confused why ## is needed here either?
modal :: Text -> Maybe [Char] -> WidgetT site IO ()
modal modalTrigger (Just modalContent) = do -- WARNING: ModalContent should not have length 11. SJ: This is possibly bad. See Template!
let

3
src/Import/NoFoundation.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE CPP #-}
module Import.NoFoundation
( module Import
, addMessage, addMessageI
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import

8
src/Model/Types.hs
View File

@ -295,7 +295,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
@ -370,11 +370,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
@ -399,6 +401,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

2
src/Settings.hs
View File

@ -33,7 +33,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)

2
src/Utils.hs
View File

@ -25,6 +25,8 @@ import Utils.DB as Utils
import Utils.TH as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Message as Utils
import Text.Blaze (Markup, ToMarkup)

35
src/Utils/Message.hs Normal file
View 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)

3
src/index.md
View File

@ -19,6 +19,9 @@ Utils.Form
Utils.PathPiece
: (Template-Haskell)-Hilfsfunktionen für Formulierung von PathPiece-Instanzen
Utils.Message
: redefines addMessage, addMessageI, defines MessageClass
Utils.Lens
: Automatisch erzeugt Linsen für eigene und Yesod-Typen, `Control.Lens`-Export

2
templates/adminTest.hamlet
View File

@ -34,7 +34,7 @@
<li><br>
Modals:
^{modal ".toggler1" Nothing}
<a href="/" .btn.toggler1>Klick mich für Ajax-Test
<a href=@{UsersR} .btn.toggler1>Klick mich für Ajax-Test
<noscript>(Für Modals bitte JS aktivieren)</noscript>
^{modal ".toggler2" (Just "Test Inhalt für Modal")}
<div .btn.toggler2>Klick mich für Content-Test

10
templates/profileData.hamlet
View File

@ -1,11 +1,4 @@
<div .container>
<div .alerts>
<div .alert .alert-danger>
<div .alert__content>
TODO: Alle Benutzerbezogenen Daten sollen hier angezeigt
und verlinkt werden
(alle Abgaben, Klausurnoten, etc.)
$if hasRows
<div .container>
<h2> Eigene Kurse
@ -58,8 +51,7 @@
.
<h2>
<em> TODO: Knopf zum Löschen aller Daten erstellen
^{modalWidget "Alle Benutzerbezogenen Daten löschen" delWdgt}
<p>
<h4>Hinweise:
<ul>

2
templates/widgets/modalWidget.hamlet Normal file
View File

@ -0,0 +1,2 @@
<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTriggerId} data-closeable=true>
^{modalContent}