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

Address hlint

Browse Source
This commit is contained in:
Gregor Kleen 2018-11-02 19:57:42 +01:00
parent 6cdfe0891b
commit 12c1a4ca71
18 changed files with 291 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.hlint.yaml
View File

@ -5,6 +5,8 @@
- ignore: { name: "Parse error" } - ignore: { name: "Parse error" }
- ignore: { name: "Reduce duplication" } - ignore: { name: "Reduce duplication" }
- ignore: { name: "Use ||" } - ignore: { name: "Use ||" }
- ignore: { name: "Use &&" }
- ignore: { name: "Use ++" }
- arguments: - arguments:
- -XQuasiQuotes - -XQuasiQuotes

23
package.yaml
View File

@ -156,20 +156,16 @@ default-extensions:
- BinaryLiterals - BinaryLiterals
- PolyKinds - PolyKinds
ghc-options:
- -Wall
- -fno-warn-type-defaults
- -fno-warn-partial-type-signatures
when: when:
- condition: flag(pedantic) - condition: flag(pedantic)
then: ghc-options:
ghc-options: - -Werror
- -Wall - -fwarn-tabs
- -Werror
- -fwarn-tabs
- -fno-warn-type-defaults
- -fno-warn-partial-type-signatures
else:
ghc-options:
- -Wall
- -fno-warn-type-defaults
- -fno-warn-partial-type-signatures
# The library contains all of our application code. The executable # The library contains all of our application code. The executable
# defined below is just a thin wrapper. # defined below is just a thin wrapper.
@ -219,6 +215,9 @@ tests:
source-dirs: hlint source-dirs: hlint
dependencies: dependencies:
- hlint-test - hlint-test
when:
- condition: "!flag(pedantic)"
buildable: false
# Define flags used by "yesod devel" to make compilation faster # Define flags used by "yesod devel" to make compilation faster
flags: flags:

2
routes
View File

@ -34,7 +34,7 @@
/ HomeR GET !free / HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only /users UsersR GET -- no tags, i.e. admins only
/admin/test AdminTestR GET POST /admin/test AdminTestR GET POST
/admin/user/#CryptoUUIDUser AdminUserR GET /admin/user/#CryptoUUIDUser AdminUserR GET !development
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST /admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
/admin/errMsg AdminErrMsgR GET POST /admin/errMsg AdminErrMsgR GET POST
/info VersionR GET !free /info VersionR GET !free

2
shell.nix
View File

@ -22,7 +22,7 @@ let
''; '';
override = oldAttrs: { override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]); nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = '' shellHook = ''
export PROMPT_INFO="${oldAttrs.name}" export PROMPT_INFO="${oldAttrs.name}"

4
src/Application.hs
View File

@ -96,7 +96,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation appSettings@(AppSettings{..}) = do makeFoundation appSettings@AppSettings{..} = do
-- Some basic initializations: HTTP connection manager, logger, and static -- Some basic initializations: HTTP connection manager, logger, and static
-- subsite. -- subsite.
appHttpManager <- newManager appHttpManager <- newManager
@ -208,7 +208,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
applyAuth SmtpAuthConf{..} conn = withLogging $ do applyAuth SmtpAuthConf{..} conn = withLogging $ do
$logDebugS "SMTP" "Doing authentication" $logDebugS "SMTP" "Doing authentication"
authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
when (not authSuccess) $ do unless authSuccess $
fail "SMTP authentication failed" fail "SMTP authentication failed"
return conn return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit

2
src/CryptoID.hs
View File

@ -9,7 +9,7 @@ module CryptoID
import CryptoID.TH import CryptoID.TH
import ClassyPrelude hiding (fromString) import ClassyPrelude
import Model import Model
import qualified Data.CryptoID as E import qualified Data.CryptoID as E

2
src/Data/Universe/Instances/Reverse/JSON.hs
View File

@ -24,4 +24,4 @@ instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a
vMap <- parseJSON val :: Parser (HashMap a b) vMap <- parseJSON val :: Parser (HashMap a b)
unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $ unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
fail "Not all required keys found" fail "Not all required keys found"
return $ (vMap !) return (vMap !)

6
src/Handler/Admin.hs
View File

@ -92,7 +92,7 @@ postAdminTestR = do
^{emailWidget} ^{emailWidget}
|] |]
defaultLayout $ do defaultLayout $
-- setTitle "Uni2work Admin Testpage" -- setTitle "Uni2work Admin Testpage"
$(widgetFile "adminTest") $(widgetFile "adminTest")
@ -101,7 +101,7 @@ getAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR uuid = do getAdminUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
User{..} <- runDB $ get404 uid User{..} <- runDB $ get404 uid
defaultLayout $ defaultLayout
[whamlet| [whamlet|
<h1>TODO <h1>TODO
<h2>Admin Page for User ^{nameWidget userDisplayName userSurname} <h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
@ -130,7 +130,7 @@ postAdminErrMsgR = do
either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
defaultLayout $ defaultLayout
[whamlet| [whamlet|
$maybe t <- plaintext $maybe t <- plaintext
<pre style="white-space:pre-wrap; font-family:monospace"> <pre style="white-space:pre-wrap; font-family:monospace">

40
src/Handler/Corrections.hs
View File

@ -207,9 +207,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
E.orderBy [E.asc $ user E.^. UserId] E.orderBy [E.asc $ user E.^. UserId]
return (user, pseudonym E.?. SheetPseudonymPseudonym) return (user, pseudonym E.?. SheetPseudonymPseudonym)
let let
submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
dbTable psValidator $ DBTable dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtColonnade , dbtColonnade
, dbtProj , dbtProj
@ -284,7 +284,7 @@ correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
(actionRes, action) <- multiAction actions Nothing (actionRes, action) <- multiAction actions Nothing
return ((,) <$> actionRes <*> selectionRes, table <> action) return ((,) <$> actionRes <*> selectionRes, table <> action)
@ -301,12 +301,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
runDB $ do runDB $ do
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
when (not $ null alreadyAssigned) $ do unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 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) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
when (not $ null unassigned) $ do unless (null unassigned) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
[ SubmissionRatingBy =. Just uid [ SubmissionRatingBy =. Just uid
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
@ -335,18 +335,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
subs <- mapM decrypt $ Set.toList subs' subs <- mapM decrypt $ Set.toList subs'
runDB $ do runDB $ do
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
when (not $ null alreadyAssigned) $ do unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 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) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
when (not $ null unassigned) $ do unless (null unassigned) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned) (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
when (not $ null assigned) $ unless (null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
when (not $ null stillUnassigned) $ do unless (null stillUnassigned) $ do
mr <- (toHtml . ) <$> getMessageRender mr <- (toHtml . ) <$> getMessageRender
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) unassigned' <- forM (Set.toList stillUnassigned) $ \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 redirect currentRoute
@ -485,7 +485,7 @@ postCorrectionR tid ssh csh shn cid = do
NotGraded -> pure Nothing NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl") (fslpI MsgRatingPoints "Punktezahl")
(Just $ submissionRatingPoints) (Just submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
@ -548,7 +548,7 @@ getCorrectionUserR tid ssh csh shn cid = do
mr <- getMessageRender mr <- getMessageRender
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
sheetTypeDesc = mr sheetType sheetTypeDesc = mr sheetType
defaultLayout $ do defaultLayout $
$(widgetFile "correction-user") $(widgetFile "correction-user")
_ -> notFound _ -> notFound
@ -574,7 +574,7 @@ postCorrectionsUploadR = do
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
defaultLayout $ do defaultLayout $
$(widgetFile "corrections-upload") $(widgetFile "corrections-upload")
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
@ -587,7 +587,7 @@ postCorrectionsCreateR = do
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName) return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
mkOptList opts = do mkOptList opts = do
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
@ -631,12 +631,12 @@ postCorrectionsCreateR = do
, submissionRatingAssigned = Just now , submissionRatingAssigned = Just now
, submissionRatingTime = Nothing , submissionRatingTime = Nothing
} }
when (not $ null duplicate) unless (null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
existingSubUsers <- E.select . E.from $ \submissionUser -> do existingSubUsers <- E.select . E.from $ \submissionUser -> do
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
return submissionUser return submissionUser
when (not $ null existingSubUsers) $ do unless (null existingSubUsers) $ do
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
@ -692,7 +692,7 @@ postCorrectionsCreateR = do
redirect CorrectionsGradeR redirect CorrectionsGradeR
defaultLayout $ do defaultLayout $
$(widgetFile "corrections-create") $(widgetFile "corrections-create")
where where
partitionEithers' :: [[Either a b]] -> ([[b]], [a]) partitionEithers' :: [[Either a b]] -> ([[b]], [a])
@ -735,7 +735,7 @@ postCorrectionsGradeR = do
cID <- encrypt subId cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i return i
(((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm ((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
case tableRes of case tableRes of
FormMissing -> return () FormMissing -> return ()
@ -751,9 +751,9 @@ postCorrectionsGradeR = do
, SubmissionRatingBy =. Just uid , SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. now <$ guard rated , SubmissionRatingTime =. now <$ guard rated
] ]
| otherwise -> return $ Nothing | otherwise -> return Nothing
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet") unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
defaultLayout $ do defaultLayout $
$(widgetFile "corrections-grade") $(widgetFile "corrections-grade")

99
src/Handler/Course.hs
View File

@ -105,7 +105,7 @@ course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \co
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> do course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
@ -122,7 +122,7 @@ makeCourseTable whereClause colChoices psValidator = do
return (course, participants, registered, school) return (course, participants, registered, school)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school) dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
dbTable psValidator $ DBTable dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtColonnade = colChoices , dbtColonnade = colChoices
, dbtProj , dbtProj
@ -134,7 +134,7 @@ makeCourseTable whereClause colChoices psValidator = do
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand) , ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom) , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo) , ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
, ( "participants", SortColumn $ course2Participants ) , ( "participants", SortColumn course2Participants )
, ( "registered", SortColumn $ course2Registered muid) , ( "registered", SortColumn $ course2Registered muid)
] ]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
@ -206,9 +206,9 @@ getTermSchoolCourseListR tid ssh = do
, colParticipants , colParticipants
, maybe mempty (const colRegistered) muid , maybe mempty (const colRegistered) muid
] ]
whereClause = \(course, _, _) -> whereClause (course, _, _) =
course E.^. CourseTerm E.==. E.val tid course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def validator = def
& defaultSorting [("cshort", SortAsc)] & defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator ((), coursesTable) <- makeCourseTable whereClause colonnade validator
@ -230,7 +230,7 @@ getTermCourseListR tid = do
, colParticipants , colParticipants
, maybe mempty (const colRegistered) muid , maybe mempty (const colRegistered) muid
] ]
whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
validator = def validator = def
& defaultSorting [("cshort", SortAsc)] & defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator ((), coursesTable) <- makeCourseTable whereClause colonnade validator
@ -254,21 +254,21 @@ getCShowR tid ssh csh = do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName return $ user E.^. UserDisplayName
return $ (courseEnt,dependent,E.unValue <$> lecturers) return (courseEnt,dependent,E.unValue <$> lecturers)
let course = entityVal courseEnt let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do defaultLayout $ do
setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course") $(widgetFile "course")
registerForm :: Bool -> Maybe Text -> Form Bool registerForm :: Bool -> Maybe Text -> Form Bool
registerForm registered msecret extra = do registerForm registered msecret extra = do
(msecretRes', msecretView) <- case msecret of (msecretRes', msecretView) <- case msecret of
(Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing) (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
_ -> return (Nothing,Nothing) _ -> return (Nothing,Nothing)
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/registerForm") let widget = $(widgetFile "widgets/registerForm")
@ -282,7 +282,7 @@ postCRegisterR tid ssh csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, course, registered) <- runDB $ do (cid, course, registered) <- runDB $ do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> (getBy $ UniqueParticipant aid cid) registered <- isJust <$> getBy (UniqueParticipant aid cid)
return (cid, course, registered) return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
case regResult of case regResult of
@ -291,11 +291,11 @@ postCRegisterR tid ssh csh = do
runDB $ deleteBy $ UniqueParticipant aid cid runDB $ deleteBy $ UniqueParticipant aid cid
addMessageI Info MsgCourseDeregisterOk addMessageI Info MsgCourseDeregisterOk
| codeOk -> do | codeOk -> do
actTime <- liftIO $ getCurrentTime actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
| otherwise -> addMessageI Warning MsgCourseSecretWrong | otherwise -> addMessageI Warning MsgCourseSecretWrong
(_other) -> return () -- TODO check this! _other -> return () -- TODO check this!
redirect $ CourseR tid ssh csh CShowR redirect $ CourseR tid ssh csh CShowR
@ -316,20 +316,20 @@ getCourseNewR = do
let noTemplateAction = courseEditHandler True Nothing let noTemplateAction = courseEditHandler True Nothing
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more! case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more!
FormMissing -> noTemplateAction FormMissing -> noTemplateAction
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >> FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
noTemplateAction noTemplateAction
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
oldCourses <- runDB $ do oldCourses <- runDB $
E.select $ E.from $ \course -> do E.select $ E.from $ \course -> do
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
let lecturersCourse = let lecturersCourse =
E.exists $ E.from $ \lecturer -> do E.exists $ E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool = let lecturersSchool =
E.exists $ E.from $ \user -> do E.exists $ E.from $ \user ->
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
let courseCreated c = let courseCreated c =
@ -343,7 +343,7 @@ getCourseNewR = do
return course return course
template <- case listToMaybe oldCourses of template <- case listToMaybe oldCourses of
(Just oldTemplate) -> (Just oldTemplate) ->
let newTemplate = (courseToForm oldTemplate) in let newTemplate = courseToForm oldTemplate in
return $ Just $ newTemplate return $ Just $ newTemplate
{ cfCourseId = Nothing { cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@ -355,7 +355,7 @@ getCourseNewR = do
(tidOk,sshOk,cshOk) <- runDB $ (,,) (tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid True existsKey <$> ifMaybeM mbTid True existsKey
<*> ifMaybeM mbSsh True existsKey <*> ifMaybeM mbSsh True existsKey
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise 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 sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
@ -400,14 +400,14 @@ courseEditHandler _isGet mbCourseForm = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
case result of case result of
(FormSuccess res@( (FormSuccess res@CourseForm
CourseForm { cfCourseId = Nothing { cfCourseId = Nothing
, cfShort = csh , cfShort = csh
, cfSchool = ssh , cfSchool = ssh
, cfTerm = tid , cfTerm = tid
})) -> do -- create new course }) -> do -- create new course
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
insertOkay <- runDB $ insertUnique $ Course insertOkay <- runDB $ insertUnique Course
{ courseName = cfName res { courseName = cfName res
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
@ -431,12 +431,12 @@ courseEditHandler _isGet mbCourseForm = do
Nothing -> Nothing ->
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
(FormSuccess res@( (FormSuccess res@CourseForm
CourseForm { cfCourseId = Just cid { cfCourseId = Just cid
, cfShort = csh , cfShort = csh
, cfSchool = ssh , cfSchool = ssh
, cfTerm = tid , cfTerm = tid
})) -> do -- edit existing course }) -> do -- edit existing course
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|] -- addMessage "debug" [shamlet| #{show res}|]
success <- runDB $ do success <- runDB $ do
@ -444,21 +444,20 @@ courseEditHandler _isGet mbCourseForm = do
case old of case old of
Nothing -> addMessageI Error MsgInvalidInput $> False Nothing -> addMessageI Error MsgInvalidInput $> False
(Just _) -> do (Just _) -> do
updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have updOkay <- myReplaceUnique cid Course
Course { courseName = cfName res { courseName = cfName res
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
, courseShorthand = cfShort res , courseShorthand = cfShort res
, courseTerm = cfTerm res -- dangerous , courseTerm = cfTerm res -- dangerous
, courseSchool = cfSchool res , courseSchool = cfSchool res
, courseCapacity = cfCapacity res , courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res , courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res , courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res , courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res , courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res , courseDeregisterUntil = cfDeRegUntil res
} }
)
case updOkay of case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do Nothing -> do
@ -468,7 +467,7 @@ courseEditHandler _isGet mbCourseForm = do
when success $ redirect $ CourseR tid ssh csh CShowR when success $ redirect $ CourseR tid ssh csh CShowR
(FormFailure _) -> addMessageI Warning MsgInvalidInput (FormFailure _) -> addMessageI Warning MsgInvalidInput
(FormMissing) -> return () FormMissing -> return ()
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
defaultLayout $ do defaultLayout $ do
setTitleI MsgCourseEditTitle setTitleI MsgCourseEditTitle
@ -570,7 +569,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
validateCourse :: CourseForm -> [Text] validateCourse :: CourseForm -> [Text]
validateCourse (CourseForm{..}) = validateCourse CourseForm{..} =
[ msg | (False, msg) <- [ msg | (False, msg) <-
[ [
( NTop cfRegFrom <= NTop cfRegTo ( NTop cfRegFrom <= NTop cfRegTo
@ -604,7 +603,7 @@ getCUserR _tid _ssh _csh uCId = do
-- - User is lecturer for course (?) -- - User is lecturer for course (?)
uid <- decrypt uCId uid <- decrypt uCId
User{..} <- runDB $ get404 uid User{..} <- runDB $ get404 uid
defaultLayout $ -- TODO defaultLayout -- TODO
[whamlet| [whamlet|
<p>^{nameWidget userDisplayName userSurname} <p>^{nameWidget userDisplayName userSurname}
|] |]

47
src/Handler/Home.hs
View File

@ -55,43 +55,44 @@ homeAnonymous = do
let tableData :: E.SqlExpr (Entity Course) let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course)) -> E.SqlQuery (E.SqlExpr (Entity Course))
tableData course = do tableData course = do
E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime)) E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
E.&&. ((E.isNothing $ course E.^. CourseRegisterTo) E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime))) E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
)
return course return course
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat colonnade = mconcat
[ -- dbRow [ -- dbRow
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
textCell $ display $ courseTerm course textCell $ display $ courseTerm course
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
textCell $ display $ courseSchool course textCell $ display $ courseSchool course
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
let tid = courseTerm course let tid = courseTerm course
ssh = courseSchool course ssh = courseSchool course
csh = courseShorthand course csh = courseShorthand course
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh) anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
] ]
((), courseTable) <- dbTable def $ DBTable ((), courseTable) <- dbTable def DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = return , dbtProj = return
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "term" [ ( "term"
, SortColumn $ \(course) -> course E.^. CourseTerm , SortColumn $ \course -> course E.^. CourseTerm
) )
, ( "school" , ( "school"
, SortColumn $ \(course) -> course E.^. CourseSchool , SortColumn $ \course -> course E.^. CourseSchool
) )
, ( "course" , ( "course"
, SortColumn $ \(course) -> course E.^. CourseShorthand , SortColumn $ \course -> course E.^. CourseShorthand
) )
, ( "deadline" , ( "deadline"
, SortColumn $ \(course) -> course E.^. CourseRegisterTo , SortColumn $ \course -> course E.^. CourseRegisterTo
) )
] ]
, dbtFilter = mempty {- [ ( "term" , dbtFilter = mempty {- [ ( "term"
@ -105,7 +106,7 @@ homeAnonymous = do
} }
-- let features = $(widgetFile "featureList") -- let features = $(widgetFile "featureList")
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
defaultLayout $ do defaultLayout
-- $(widgetFile "dsgvDisclaimer") -- $(widgetFile "dsgvDisclaimer")
$(widgetFile "home") $(widgetFile "home")
@ -125,7 +126,7 @@ homeUser uid = do
, E.SqlExpr (E.Value (Maybe SubmissionId))) , E.SqlExpr (E.Value (Maybe SubmissionId)))
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
E.&&. (E.just $ E.val uid) E.==. subuser E.?. SubmissionUserUser E.&&. E.just (E.val uid) E.==. subuser E.?. SubmissionUserUser
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId) E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
@ -163,14 +164,14 @@ homeUser uid = do
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn) anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (i18nCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
case mbsid of case mbsid of
Nothing -> mempty Nothing -> mempty
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark tickmark
] ]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
((), sheetTable) <- dbTable validator $ DBTable ((), sheetTable) <- dbTable validator DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
@ -205,7 +206,7 @@ homeUser uid = do
, dbtIdent = "upcomingdeadlines" :: Text , dbtIdent = "upcomingdeadlines" :: Text
} }
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
defaultLayout $ do defaultLayout $
-- setTitle "Willkommen zum Uni2work Test!" -- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser") $(widgetFile "homeUser")
-- $(widgetFile "dsgvDisclaimer") -- $(widgetFile "dsgvDisclaimer")
@ -275,12 +276,14 @@ postHelpR = do
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
case res of case res of
FormSuccess (HelpForm{..}) -> do FormSuccess HelpForm{..} -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
queueJob' $ JobHelpRequest { jSender = hfUserId queueJob' JobHelpRequest
, jHelpRequest = hfRequest { jSender = hfUserId
, jRequestTime = now , jHelpRequest = hfRequest
, jReferer = hfReferer } , jRequestTime = now
, jReferer = hfReferer
}
-- redirect $ HelpR -- redirect $ HelpR
addMessageI Success MsgHelpSent addMessageI Success MsgHelpSent
return () return ()

177
src/Handler/Profile.hs
View File

@ -67,7 +67,7 @@ getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR getProfileR = postProfileR
postProfileR = do postProfileR = do
(uid, User{..}) <- requireAuthPair (uid, User{..}) <- requireAuthPair
let settingsTemplate = Just $ SettingsForm let settingsTemplate = Just SettingsForm
{ stgMaxFavourties = userMaxFavourites { stgMaxFavourties = userMaxFavourites
, stgTheme = userTheme , stgTheme = userTheme
, stgDateTime = userDateTimeFormat , stgDateTime = userDateTimeFormat
@ -92,13 +92,13 @@ postProfileR = do
-- prune Favourites to user-defined size -- prune Favourites to user-defined size
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime [ Desc CourseFavouriteTime
, OffsetBy $ stgMaxFavourties , OffsetBy stgMaxFavourties
] ]
mapM_ delete oldFavs mapM_ delete oldFavs
addMessageI Info $ MsgSettingsUpdate addMessageI Info MsgSettingsUpdate
redirect ProfileR -- TODO: them change does not happen without redirect 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 () _ -> return ()
let formText = Nothing :: Maybe UniWorXMessage let formText = Nothing :: Maybe UniWorXMessage
@ -109,7 +109,7 @@ postProfileR = do
postProfileDataR :: Handler Html postProfileDataR :: Handler Html
postProfileDataR = do postProfileDataR = do
((btnResult,_), _) <- runFormPost $ buttonForm ((btnResult,_), _) <- runFormPost buttonForm
case btnResult of case btnResult of
(FormSuccess BtnDelete) -> do (FormSuccess BtnDelete) -> do
(uid, User{..}) <- requireAuthPair (uid, User{..}) <- requireAuthPair
@ -119,7 +119,7 @@ postProfileDataR = do
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-- addMessageI Success $ MsgDeleteUser deletedSubmissions -- addMessageI Success $ MsgDeleteUser deletedSubmissions
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
defaultLayout $ do defaultLayout
$(widgetFile "deletedUser") $(widgetFile "deletedUser")
(FormSuccess BtnAbort ) -> do (FormSuccess BtnAbort ) -> do
@ -156,72 +156,76 @@ deleteUser duid = do
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
return E.countRows return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
E.&&. (whereBuddies numBuddies) E.&&. whereBuddies numBuddies
return $ submission E.^. SubmissionId return $ submission E.^. SubmissionId
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)] getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
getSubmissionFiles subId = E.select $ E.from $ \file -> do getSubmissionFiles subId = E.select $ E.from $ \file -> do
E.where_ $ E.exists $ E.from $ \submissionFile -> do E.where_ $ E.exists $ E.from $ \submissionFile ->
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
return $ file E.^. FileId return $ file E.^. FileId
deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
E.where_ $ E.exists $ E.from $ \subGroupUser -> do E.where_ $ E.exists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
E.where_ $ E.notExists $ E.from $ \subGroupUser -> do E.where_ $ E.notExists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
getProfileDataR :: Handler Html getProfileDataR :: Handler Html
getProfileDataR = do getProfileDataR = do
(uid, User{..}) <- requireAuthPair (uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender -- mr <- getMessageRender
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$> (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do E.select
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid ( E.from $ \(adright `E.InnerJoin` school) -> do
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
return (school E.^. SchoolShorthand) E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
) return (school E.^. SchoolShorthand)
)
<*> <*>
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do E.select
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid ( E.from $ \(lecright `E.InnerJoin` school) -> do
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
return (school E.^. SchoolShorthand) E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
) return (school E.^. SchoolShorthand)
)
<*> <*>
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.select
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId ( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
) return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*> <*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do E.select
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid ( E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
return ( ( studydegree E.^. StudyDegreeName E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
, studydegree E.^. StudyDegreeKey return ( ( studydegree E.^. StudyDegreeName
) , studydegree E.^. StudyDegreeKey
, ( studyterms E.^. StudyTermsName )
, studyterms E.^. StudyTermsKey , ( studyterms E.^. StudyTermsName
) , studyterms E.^. StudyTermsKey
, studyfeat E.^. StudyFeaturesType )
, studyfeat E.^. StudyFeaturesSemester) , studyfeat E.^. StudyFeaturesType
) , studyfeat E.^. StudyFeaturesSemester)
)
-- Tabelle mit eigenen Kursen -- Tabelle mit eigenen Kursen
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
enrolledCoursesTable <- mkEnrolledCoursesTable uid enrolledCoursesTable <- mkEnrolledCoursesTable uid
-- Tabelle mit allen Klausuren und Noten -- Tabelle mit allen Klausuren und Noten
examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|] let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Abgaben und Abgabe-Gruppen -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- mkSubmissionTable uid submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen -- Tabelle mit allen Abgabegruppen
@ -229,42 +233,14 @@ getProfileDataR = do
-- Tabelle mit allen Korrektor-Aufgaben -- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid correctionsTable <- mkCorrectionsTable uid
-- Tabelle mit allen eigenen Tutorials -- Tabelle mit allen eigenen Tutorials
ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|] let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Tutorials -- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Delete Button -- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
-- TODO: move this into a Message and/or Widget-File -- TODO: move this into a Message and/or Widget-File
let delWdgt = [whamlet|
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
<h2>
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
<div .container>
Während der Testphase von Uni2work können Sie hiermit
Ihren Account bei Uni2work vollständig löschen.
Mit Ihrem Campus-Account können Sie sich aber danach
jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
<div .container>
Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
wenn die Dateien ausschließlich Ihnen zugeordnet sind.
Dateien aus Gruppenabgaben werden also erst dann gelöscht,
wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
<div .container>
<em>Achtung:
Auch abgegebene Hausübungen werden gelöscht!
Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
auch nicht mehr rekonstruiert/berücksichtigt werden.)
<div .container>
<em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
aufbewahrt werden müssen.
<div .container>
^{btnWdgt}
|]
defaultLayout $ do defaultLayout $ do
let delWdgt = $(widgetFile "widgets/data-delete")
$(widgetFile "profileData") $(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer") $(widgetFile "dsgvDisclaimer")
@ -280,14 +256,14 @@ mkOwnedCoursesTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
withType = id withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` lecturer) -> do dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return ( course E.^. CourseTerm return ( course E.^. CourseTerm
, course E.^. CourseSchool , course E.^. CourseSchool
, course E.^. CourseShorthand , course E.^. CourseShorthand
) )
dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbRow [ dbRow
@ -299,10 +275,10 @@ mkOwnedCoursesTable =
schoolCell <$> view (_dbrOutput . _1 . re _Just) schoolCell <$> view (_dbrOutput . _1 . re _Just)
<*> view (_dbrOutput . _2 ) <*> view (_dbrOutput . _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput) courseCellCL <$> view _dbrOutput
] ]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)] validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -313,7 +289,7 @@ mkOwnedCoursesTable =
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
] ]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..}) in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
@ -340,7 +316,7 @@ mkEnrolledCoursesTable =
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view ( _courseTerm . re _Just) schoolCell <$> view ( _courseTerm . re _Just)
<*> view ( _courseSchool ) <*> view _courseSchool
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCell <$> view (_dbrOutput . _1 . _entityVal) courseCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "time") (i18nCell MsgRegistered) $ do , sortable (Just "time") (i18nCell MsgRegistered) $ do
@ -374,17 +350,16 @@ mkSubmissionTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
withType = id withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool , course E.^. CourseSchool
, course E.^. CourseShorthand , course E.^. CourseShorthand
) )
let sht = ( sheet E.^. SheetName let sht = sheet E.^. SheetName
)
return (crse, sht, submission, lastSubEdit uid submission) return (crse, sht, submission, lastSubEdit uid submission)
lastSubEdit uid submission = -- latest Edit-Time of this user for submission lastSubEdit uid submission = -- latest Edit-Time of this user for submission
@ -393,7 +368,7 @@ mkSubmissionTable =
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid
return . E.max_ $ subEdit E.^. SubmissionEditTime return . E.max_ $ subEdit E.^. SubmissionEditTime
dbtProj = \x -> return $ x dbtProj x = return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _2 %~ E.unValue & _dbrOutput . _2 %~ E.unValue
& _dbrOutput . _4 %~ E.unValue & _dbrOutput . _4 %~ E.unValue
@ -404,7 +379,7 @@ mkSubmissionTable =
termCell <$> view (_dbrOutput . _1 . _1) termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just) schoolCell <$> view ( _1. re _Just)
<*> view ( _2 ) <*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $ , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
@ -439,7 +414,7 @@ mkSubmissionTable =
] ]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid dbtSorting = dbtSorting' uid
in dbTableWidget' validator $ DBTable {..} in dbTableWidget' validator DBTable{..}
-- in do dbtSQLQuery <- dbtSQLQuery' -- in do dbtSQLQuery <- dbtSQLQuery'
-- dbtSorting <- dbtSorting' -- dbtSorting <- dbtSorting'
-- return $ dbTableWidget' validator $ DBTable {..} -- return $ dbTableWidget' validator $ DBTable {..}
@ -455,7 +430,7 @@ mkSubmissionGroupTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
withType = id withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
@ -471,7 +446,7 @@ mkSubmissionGroupTable =
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
dbtProj = \x -> return $ x dbtProj x = return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _3 %~ E.unValue & _dbrOutput . _3 %~ E.unValue
@ -481,7 +456,7 @@ mkSubmissionGroupTable =
termCell <$> view (_dbrOutput . _1 . _1) termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just) schoolCell <$> view ( _1. re _Just)
<*> view ( _2 ) <*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $ , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
@ -507,7 +482,7 @@ mkSubmissionGroupTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
] ]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..} in dbTableWidget' validator DBTable{..}
@ -524,15 +499,15 @@ mkCorrectionsTable =
corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
return $ E.countRows return E.countRows
corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime) E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
return $ E.countRows return E.countRows
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
@ -542,7 +517,7 @@ mkCorrectionsTable =
) )
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet)) return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
dbtProj = \x -> return $ x dbtProj x = return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _2 %~ E.unValue & _dbrOutput . _2 %~ E.unValue
@ -580,5 +555,5 @@ mkCorrectionsTable =
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
] ]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..} in dbTableWidget' validator DBTable{..}

79
src/Handler/Submission.hs
View File

@ -1,6 +1,6 @@
module Handler.Submission where module Handler.Submission where
import Import hiding (joinPath) import Import
import Jobs import Jobs
@ -88,7 +88,7 @@ getSubmissionOwnR tid ssh csh shn = do
E.&&. submission E.^. SubmissionSheet E.==. E.val shid E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ submission E.^. SubmissionId return $ submission E.^. SubmissionId
case submissions of case submissions of
((E.Value sid):_) -> return sid (E.Value sid : _) -> return sid
[] -> notFound [] -> notFound
cID <- encrypt sid cID <- encrypt sid
redirect $ CSubmissionR tid ssh csh shn cID SubShowR redirect $ CSubmissionR tid ssh csh shn cID SubShowR
@ -131,7 +131,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return (csheet, map E.unValue buddies, []) return (csheet, map E.unValue buddies, [])
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI Info $ MsgSubmissionAlreadyExists addMessageI Info MsgSubmissionAlreadyExists
redirect $ CSubmissionR tid ssh csh shn cID SubShowR redirect $ CSubmissionR tid ssh csh shn cID SubShowR
(Just smid) -> do (Just smid) -> do
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
@ -145,7 +145,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ (user E.^. UserId, user E.^. UserEmail) return (user E.^. UserId, user E.^. UserEmail)
let breakUserFromBuddies (E.Value userID, E.Value email) let breakUserFromBuddies (E.Value userID, E.Value email)
| uid == userID = (Any True , []) | uid == userID = (Any True , [])
| otherwise = (Any False, [email]) | otherwise = (Any False, [email])
@ -160,17 +160,17 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
let userName = if isOwner || maySubmit let userName = if isOwner || maySubmit
then E.just $ user E.^. UserDisplayName then E.just $ user E.^. UserDisplayName
else E.nothing else E.nothing
return $ (userName, submissionEdit E.^. SubmissionEditTime) return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits) return (csheet,buddies,lastEdits)
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
mCID <- runDBJobs $ do mCID <- runDBJobs $ do
res' <- case res of res' <- case res of
(FormMissing ) -> return $ FormMissing FormMissing -> return FormMissing
(FormFailure failmsgs) -> return $ FormFailure failmsgs (FormFailure failmsgs) -> return $ FormFailure failmsgs
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
(FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members (FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
| (Arbitrary {..}) <- sheetGrouping -> do | Arbitrary{..} <- sheetGrouping -> do
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
@ -212,7 +212,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
case res' of case res' of
(FormSuccess (mFiles,(setFromList -> adhocIds))) -> do (FormSuccess (mFiles, setFromList -> adhocIds)) -> do
smid <- do smid <- do
smid <- case (mFiles, msmid) of smid <- case (mFiles, msmid) of
(Nothing, Just smid) -- no new files, existing submission partners updated (Nothing, Just smid) -- no new files, existing submission partners updated
@ -261,13 +261,13 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
Just isFile = origIsFile <|> corrIsFile Just isFile = origIsFile <|> corrIsFile
in if in if
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
([whamlet|#{fileTitle'}|]) [whamlet|#{fileTitle'}|]
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle' | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty Nothing -> cell mempty
Just (_, Entity _ File{..}) Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
([whamlet|_{MsgFileCorrected}|]) [whamlet|_{MsgFileCorrected}|]
| otherwise -> i18nCell MsgCorrected | otherwise -> i18nCell MsgCorrected
, sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
origTime = fileModified . entityVal . snd <$> mOrig origTime = fileModified . entityVal . snd <$> mOrig
@ -316,40 +316,39 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
runDB $ do submissionID <- submissionMatchesSheet tid ssh csh shn cID
submissionID <- submissionMatchesSheet tid ssh csh shn cID
isRating <- maybe False (== submissionID) <$> isRatingFile path isRating <- (== Just submissionID) <$> isRatingFile path
when (isUpdate || isRating) $ when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
case isRating of case isRating of
True True
| isUpdate -> do | isUpdate -> do
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
| otherwise -> notFound | otherwise -> notFound
False -> do False -> do
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.&&. f E.^. FileTitle E.==. E.val path E.&&. f E.^. FileTitle E.==. E.val path
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
return f return f
case results of case results of
[Entity _ File{ fileContent = Just c, fileTitle }] -> do [Entity _ File{ fileContent = Just c, fileTitle }] -> do
whenM downloadFiles $ whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
other -> do other -> do
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found." error "Multiple matching files found."
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do

15
src/Handler/SystemMessage.hs
View File

@ -50,11 +50,12 @@ postMessageR cID = do
cID' <- encrypt tId cID' <- encrypt tId
runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
$ (,) $ (,)
<$> ( fmap (Entity tId) $ SystemMessageTranslation <$> fmap (Entity tId)
<$> pure systemMessageTranslationMessage ( SystemMessageTranslation
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage) <$> pure systemMessageTranslationMessage
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent) <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary) <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
) )
<*> combinedButtonField (universeF :: [BtnSubmitDelete]) <*> combinedButtonField (universeF :: [BtnSubmitDelete])
@ -111,7 +112,7 @@ postMessageR cID = do
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
forms <- traverse (const mkForm) $ () <$ guard maySubmit forms <- traverse (const mkForm) $ () <$ guard maySubmit
defaultLayout $ defaultLayout
$(widgetFile "system-message") $(widgetFile "system-message")
where where
modifySystemMessage smId SystemMessage{..} = do modifySystemMessage smId SystemMessage{..} = do
@ -248,5 +249,5 @@ postMessageListR = do
addMessageI Success $ MsgSystemMessageAdded cID addMessageI Success $ MsgSystemMessageAdded cID
redirect $ MessageR cID redirect $ MessageR cID
defaultLayout $ defaultLayout
$(widgetFile "system-message-list") $(widgetFile "system-message-list")

2
src/Handler/Utils/Zip.hs
View File

@ -57,7 +57,7 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
fileContent fileContent
| hasTrailingPathSeparator zipEntryName = Nothing | hasTrailingPathSeparator zipEntryName = Nothing
| otherwise = Just $ mconcat contentChunks | otherwise = Just $ mconcat contentChunks
yield $ File{..} yield File{..}
consumeZip' consumeZip'
accContents :: Monad m => Sink (Either a b) m [b] accContents :: Monad m => Sink (Either a b) m [b]
accContents = do accContents = do

2
src/Settings.hs
View File

@ -136,7 +136,7 @@ instance Show PWHashConf where
instance FromJSON PWHashConf where instance FromJSON PWHashConf where
parseJSON = withObject "PWHashConf" $ \o -> do parseJSON = withObject "PWHashConf" $ \o -> do
pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text) pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text
pwHashAlgorithm <- if pwHashAlgorithm <- if
| pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1 | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
| pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2 | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2

44
src/Utils.hs
View File

@ -57,7 +57,7 @@ import qualified Data.Aeson as Aeson
-- Yesod -- -- Yesod --
----------- -----------
newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) } newtype MsgRendererS site = MsgRenderer { render :: forall msg. RenderMessage site msg => msg -> Text }
getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site) getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
getMsgRenderer = do getMsgRenderer = do
@ -104,29 +104,29 @@ tickmarkT = tickmark
text2Html :: Text -> Html text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types text2Html = toHtml -- prevents ambiguous types
toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) => toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
a -> WidgetT site m () => a -> WidgetT site m ()
toWgt = toWidget . toHtml toWgt = toWidget . toHtml
-- Convenience Functions to avoid type signatures: -- Convenience Functions to avoid type signatures:
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
Text -> WidgetT site m () => Text -> WidgetT site m ()
text2widget t = [whamlet|#{t}|] text2widget t = [whamlet|#{t}|]
citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
(CI Text) -> WidgetT site m () => CI Text -> WidgetT site m ()
citext2widget t = [whamlet|#{CI.original t}|] citext2widget t = [whamlet|#{CI.original t}|]
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
String -> WidgetT site m () => String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|] str2widget s = [whamlet|#{s}|]
display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) => display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a)
a -> WidgetT site m () => a -> WidgetT site m ()
display2widget = text2widget . display display2widget = text2widget . display
withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) withFragment form html = flip fmap form $ over _2 (toWidget html >>)
-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production) -- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
@ -174,7 +174,7 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out
-} -}
textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> (pack $ show rx) <> "%" textPercent x = lz <> pack (show rx) <> "%"
where where
round' :: Double -> Int -- avoids annoying warning round' :: Double -> Int -- avoids annoying warning
round' = round round' = round
@ -260,10 +260,10 @@ infixl 5 !!!
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
(!!!) m k = (fromMaybe mempty) $ Map.lookup k m (!!!) m k = fromMaybe mempty $ Map.lookup k m
groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v) groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l] groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend partMap = Map.fromListWith mappend
@ -368,19 +368,19 @@ whenIsRight (Left _) _ = return ()
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return maybeExceptT err act = lift act >>= maybe (throwE err) return
maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
whenExceptT :: Monad m => Bool -> e -> ExceptT e m () whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err whenExceptT b err = when b $ throwE err
whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m () whenMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
whenMExceptT b err = when b $ lift err >>= throwE whenMExceptT b err = when b $ lift err >>= throwE
guardExceptT :: Monad m => Bool -> e -> ExceptT e m () guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
guardExceptT b err = unless b $ throwE err guardExceptT b err = unless b $ throwE err
guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m () guardMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
guardMExceptT b err = unless b $ lift err >>= throwE guardMExceptT b err = unless b $ lift err >>= throwE
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
@ -398,9 +398,9 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
shortCircuitM sc mx my bop = do shortCircuitM sc mx my bop = do
x <- mx x <- mx
case sc x of if
True -> return x | sc x -> return x
False -> bop <$> pure x <*> my | otherwise -> bop <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m () guardM :: MonadPlus m => m Bool -> m ()
@ -435,7 +435,7 @@ allM xs f = andM $ fmap f xs
-- | Lazy monadic disjunction. -- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M ma mb = ifM ma (return True) mb or2M ma = ifM ma (return True)
orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
orM = Fold.foldr or2M (return False) orM = Fold.foldr or2M (return False)

27
templates/widgets/data-delete.hamlet Normal file
View File

@ -0,0 +1,27 @@
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
<h2>
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
<div .container>
Während der Testphase von Uni2work können Sie hiermit
Ihren Account bei Uni2work vollständig löschen.
Mit Ihrem Campus-Account können Sie sich aber danach
jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
<div .container>
Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
wenn die Dateien ausschließlich Ihnen zugeordnet sind.
Dateien aus Gruppenabgaben werden also erst dann gelöscht,
wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
<div .container>
<em>Achtung:
Auch abgegebene Hausübungen werden gelöscht!
Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
auch nicht mehr rekonstruiert/berücksichtigt werden.)
<div .container>
<em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
aufbewahrt werden müssen.
<div .container>
^{btnWdgt}