_{MsgErrorResponseNotFound}|] - InternalError err -> encrypted err [whamlet|
#{err}|] + InternalError err' -> encrypted err' [whamlet|
#{err'}|] InvalidArgs errs -> [whamlet|
_{MsgErrorResponseNotAuthenticated}|] - PermissionDenied err -> [whamlet|
#{err}|] + PermissionDenied err' -> [whamlet|
#{err'}|] BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do toWidget @@ -754,8 +755,8 @@ siteLayout headingOverride widget = do asidenav = $(widgetFile "widgets/asidenav") contentHeadline :: Maybe Widget contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute) - breadcrumbs :: Widget - breadcrumbs = $(widgetFile "widgets/breadcrumbs") + breadcrumbsWgt :: Widget + breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now -- functions to determine if there are page-actions (primary or secondary) @@ -794,11 +795,13 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do cID <- encrypt smId + void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + let sessionKey = "sm-" <> tshow (ciphertext cID) - assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False - assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())) + _ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ()) setSessionJson sessionKey () - (SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId + + (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId let (summary, content) = case smTrans of Nothing -> (systemMessageSummary, systemMessageContent) @@ -1185,11 +1188,12 @@ pageActions (CorrectionsR) = , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId - [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + [E.Value corrCount] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid return E.countRows - return $ (count :: Int) /= 0 + return $ (corrCount :: Int) /= 0 } , PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen eintragen" @@ -1214,11 +1218,12 @@ pageActions (CorrectionsGradeR) = , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId - [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + [E.Value corrCount] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid return E.countRows - return $ (count :: Int) /= 0 + return $ (corrCount :: Int) /= 0 } ] pageActions _ = [] @@ -1295,7 +1300,7 @@ pageHeading (CSheetR tid ssh csh shn SEditR) = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SDelR) = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn -pageHeading (CSheetR tid ssh csh shn SSubsR) +pageHeading (CSheetR _tid _ssh _csh shn SSubsR) = Just $ i18nHeading $ MsgSubmissionsSheet shn pageHeading (CSheetR tid ssh csh shn SubmissionNewR) = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn @@ -1307,7 +1312,7 @@ pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -pageHeading (CSheetR tid ssh csh shn SCorrR) +pageHeading (CSheetR _tid _ssh _csh shn SCorrR) = Just $ i18nHeading $ MsgCorrectorsHead shn -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads @@ -1550,7 +1555,7 @@ instance YesodMail UniWorX where pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do - setMailObjectId + void setMailObjectId setDateCurrent replaceMailHeader "Auto-Submitted" $ Just "auto-generated" diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 50b1963e7..da8a8aed8 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -92,7 +92,7 @@ postAdminTestR = do ^{emailWidget} |] - defaultLayout $ do + defaultLayout $ -- setTitle "Uni2work Admin Testpage" $(widgetFile "adminTest") @@ -101,7 +101,7 @@ getAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR uuid = do uid <- decrypt uuid User{..} <- runDB $ get404 uid - defaultLayout $ + defaultLayout [whamlet|
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 743bee3c1..d89257eee 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -24,7 +24,7 @@ import Data.Semigroup (Sum(..))
-- import qualified Data.Text as T
-- import Data.Function ((&))
--
-import Colonnade hiding (fromMaybe, singleton, bool)
+-- import Colonnade hiding (fromMaybe, singleton, bool)
-- import Yesod.Colonnade
--
-- import qualified Data.UUID.Cryptographic as UUID
@@ -40,25 +40,19 @@ import qualified Database.Esqueleto as E
import Web.PathPieces
import Text.Hamlet (ihamletFile)
-import Text.Blaze.Html (preEscapedToHtml)
import Database.Persist.Sql (updateWhereCount)
import Data.List (genericLength)
-import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
-
-import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
-import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Trans.Writer (WriterT(..), runWriter)
import Control.Monad.Trans.RWS (RWST)
-import Control.Monad.Trans.State (State, StateT(..), runState)
+import Control.Monad.Trans.State (State, runState)
import qualified Control.Monad.State.Class as State
import Data.Foldable (foldrM)
-import Data.Traversable (for)
@@ -131,16 +125,16 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
tid = course ^. _3
ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid
- cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
+ protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
anchorCellM (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|]
- in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+ in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
- cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
- in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+ protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
+ in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
@@ -213,9 +207,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
E.orderBy [E.asc $ user E.^. UserId]
return (user, pseudonym E.?. SheetPseudonymPseudonym)
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)
- dbTable psValidator $ DBTable
+ dbTable psValidator DBTable
{ dbtSQLQuery
, dbtColonnade
, dbtProj
@@ -240,7 +234,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
)
, ( "assignedtime"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
- )
+ )
]
, dbtFilter = Map.fromList
[ ( "term"
@@ -290,7 +284,7 @@ correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
((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
return ((,) <$> actionRes <*> selectionRes, table <> action)
@@ -307,12 +301,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
now <- liftIO getCurrentTime
runDB $ do
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
- when (not $ null alreadyAssigned) $ do
+ unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
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
+ unless (null unassigned) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
[ SubmissionRatingBy =. Just uid
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
@@ -341,18 +335,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
subs <- mapM decrypt $ Set.toList subs'
runDB $ do
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
- when (not $ null alreadyAssigned) $ do
+ unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
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) $
+ unless (null unassigned) $ do
+ (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
+ unless (null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
- when (not $ null unassigned) $ do
+ unless (null stillUnassigned) $ do
mr <- (toHtml . ) <$> getMessageRender
- unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission)
+ unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute
@@ -491,7 +485,7 @@ postCorrectionR tid ssh csh shn cid = do
NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl")
- (Just $ submissionRatingPoints)
+ (Just submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
@@ -506,19 +500,17 @@ postCorrectionR tid ssh csh shn cid = do
case corrResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
- FormSuccess (rated, ratingPoints, ratingComment) -> do
+ FormSuccess (rated, ratingPoints', ratingComment') -> do
runDBJobs $ do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
-
- Submission{submissionRatingTime} <- getJust sub
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
+ , SubmissionRatingPoints =. ratingPoints'
+ , SubmissionRatingComment =. ratingComment'
]
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
@@ -532,10 +524,10 @@ postCorrectionR tid ssh csh shn cid = do
case uploadResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
- FormSuccess fileSource -> do
+ FormSuccess fileUploads -> do
uid <- requireAuthId
- runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+ void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@@ -556,7 +548,7 @@ getCorrectionUserR tid ssh csh shn cid = do
mr <- getMessageRender
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
sheetTypeDesc = mr sheetType
- defaultLayout $ do
+ defaultLayout $
$(widgetFile "correction-user")
_ -> notFound
@@ -582,7 +574,7 @@ postCorrectionsUploadR = do
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
- defaultLayout $ do
+ defaultLayout $
$(widgetFile "corrections-upload")
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
@@ -595,7 +587,7 @@ postCorrectionsCreateR = do
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
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]
- 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 opts = do
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
@@ -617,10 +609,9 @@ postCorrectionsCreateR = do
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, pss) -> do
- now <- liftIO getCurrentTime
runDB $ do
Sheet{..} <- get404 sid
- (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
+ (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText
now <- liftIO getCurrentTime
let
@@ -640,12 +631,12 @@ postCorrectionsCreateR = do
, submissionRatingAssigned = Just now
, submissionRatingTime = Nothing
}
- when (not $ null duplicate)
+ unless (null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
existingSubUsers <- E.select . E.from $ \submissionUser -> do
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
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
$(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'
@@ -669,23 +660,18 @@ postCorrectionsCreateR = do
E.where_ . E.exists . E.from $ \submissionGroupUser ->
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
return $ submissionGroup E.^. SubmissionGroupId
- case (groups :: [E.Value SubmissionGroupId]) of
- [x] -> do
- subId <- insert submission
- void . insert $ SubmissionEdit uid now subId
- insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+ if
+ | length (groups :: [E.Value SubmissionGroupId]) < 2
+ -> do
+ subId <- insert submission
+ void . insert $ SubmissionEdit uid now subId
+ insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
- [] -> do
- subId <- insert submission
- void . insert $ SubmissionEdit uid now subId
- insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
- { submissionUserUser = sheetPseudonymUser
- , submissionUserSubmission = subId
- }
- addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
- _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
+ when (null groups) $
+ addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
+ | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
NoGroups
| [SheetPseudonym{sheetPseudonymUser}] <- spGroup
-> do
@@ -706,18 +692,18 @@ postCorrectionsCreateR = do
redirect CorrectionsGradeR
- defaultLayout $ do
+ defaultLayout $
$(widgetFile "corrections-create")
where
- partition :: [[Either a b]] -> ([[b]], [a])
- partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
+ partitionEithers' :: [[Either a b]] -> ([[b]], [a])
+ partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
= let
invalid :: [Text]
valid :: [[Pseudonym]]
- (valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws
+ (valid, invalid) = partitionEithers' $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws
in case invalid of
(i:_) -> return . Left $ MsgInvalidPseudonym i
[] -> return $ Right valid
@@ -749,7 +735,7 @@ postCorrectionsGradeR = do
cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i
- (((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm
+ ((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
case tableRes of
FormMissing -> return ()
@@ -765,9 +751,9 @@ postCorrectionsGradeR = do
, SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. now <$ guard rated
]
- | otherwise -> return $ Nothing
+ | otherwise -> return Nothing
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
- defaultLayout $ do
+ defaultLayout $
$(widgetFile "corrections-grade")
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index c9262a2b6..161ebcd1d 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -2,9 +2,7 @@ module Handler.Course where
import Import hiding (catMaybes)
-import Control.Lens
import Utils.Lens
-import Utils.TH
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Table.Cells
@@ -20,20 +18,15 @@ import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI
-
-import Colonnade hiding (fromMaybe,bool)
--- import Yesod.Colonnade
-
import qualified Database.Esqueleto as E
-import qualified Data.UUID.Cryptographic as UUID
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|#{display courseName}|]
@@ -44,19 +37,19 @@ colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing (i18nCell MsgCourseDescription)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
case courseDescription of
Nothing -> mempty
(Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr)
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
( case courseDescription of
Nothing -> mempty
@@ -70,7 +63,7 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
@@ -85,24 +78,24 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
maybe mempty timeCell courseRegisterFrom
-- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
- cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
+ maybe mempty timeCell courseRegisterTo
colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
+ $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
Nothing -> MsgCourseMembersCount currentParticipants
- Just max -> MsgCourseMembersCountLimited currentParticipants max
+ Just limit -> MsgCourseMembersCountLimited currentParticipants limit
colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
- $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered, _) } -> tickmarkCell registered
+ $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
@@ -112,7 +105,7 @@ course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \co
return (E.countRows :: E.SqlExpr (E.Value Int64))
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.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
@@ -129,7 +122,7 @@ makeCourseTable whereClause colChoices psValidator = do
return (course, participants, registered, school)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
- dbTable psValidator $ DBTable
+ dbTable psValidator DBTable
{ dbtSQLQuery
, dbtColonnade = colChoices
, dbtProj
@@ -141,7 +134,7 @@ makeCourseTable whereClause colChoices psValidator = do
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
- , ( "participants", SortColumn $ course2Participants )
+ , ( "participants", SortColumn course2Participants )
, ( "registered", SortColumn $ course2Registered muid)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
@@ -213,9 +206,9 @@ getTermSchoolCourseListR tid ssh = do
, colParticipants
, maybe mempty (const colRegistered) muid
]
- whereClause = \(course, _, _) ->
- course E.^. CourseTerm E.==. E.val tid
- E.&&. course E.^. CourseSchool E.==. E.val ssh
+ whereClause (course, _, _) =
+ course E.^. CourseTerm E.==. E.val tid
+ E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def
& defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator
@@ -237,7 +230,7 @@ getTermCourseListR tid = do
, colParticipants
, 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
& defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator
@@ -261,21 +254,21 @@ getCShowR tid ssh csh = do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName
- return $ (courseEnt,dependent,E.unValue <$> lecturers)
+ return (courseEnt,dependent,E.unValue <$> lecturers)
let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do
- setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
+ setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course")
registerForm :: Bool -> Maybe Text -> Form Bool
registerForm registered msecret extra = do
(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)
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/registerForm")
@@ -289,7 +282,7 @@ postCRegisterR tid ssh csh = do
aid <- requireAuthId
(cid, course, registered) <- runDB $ do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
- registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
+ registered <- isJust <$> getBy (UniqueParticipant aid cid)
return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
case regResult of
@@ -298,11 +291,11 @@ postCRegisterR tid ssh csh = do
runDB $ deleteBy $ UniqueParticipant aid cid
addMessageI Info MsgCourseDeregisterOk
| codeOk -> do
- actTime <- liftIO $ getCurrentTime
+ actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
| otherwise -> addMessageI Warning MsgCourseSecretWrong
- (_other) -> return () -- TODO check this!
+ _other -> return () -- TODO check this!
redirect $ CourseR tid ssh csh CShowR
@@ -323,21 +316,20 @@ getCourseNewR = do
let noTemplateAction = courseEditHandler True Nothing
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more!
FormMissing -> noTemplateAction
- FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
+ FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
noTemplateAction
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
- uid <- requireAuthId
- oldCourses <- runDB $ do
+ oldCourses <- runDB $
E.select $ E.from $ \course -> do
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 mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
let lecturersCourse =
- E.exists $ E.from $ \lecturer -> do
+ E.exists $ E.from $ \lecturer ->
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.exists $ E.from $ \user ->
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
let courseCreated c =
@@ -351,7 +343,7 @@ getCourseNewR = do
return course
template <- case listToMaybe oldCourses of
(Just oldTemplate) ->
- let newTemplate = (courseToForm oldTemplate) in
+ let newTemplate = courseToForm oldTemplate in
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -363,7 +355,7 @@ getCourseNewR = do
(tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid 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 sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
@@ -403,19 +395,19 @@ postCDeleteR = error "TODO: implement getCDeleteR"
-- | Course Creation and Editing
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
-- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
-courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html
-courseEditHandler isGet mbCourseForm = do
+courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html -- FIXME: _isGet is not used
+courseEditHandler _isGet mbCourseForm = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
case result of
- (FormSuccess res@(
- CourseForm { cfCourseId = Nothing
- , cfShort = csh
- , cfSchool = ssh
- , cfTerm = tid
- })) -> do -- create new course
+ (FormSuccess res@CourseForm
+ { cfCourseId = Nothing
+ , cfShort = csh
+ , cfSchool = ssh
+ , cfTerm = tid
+ }) -> do -- create new course
now <- liftIO getCurrentTime
- insertOkay <- runDB $ insertUnique $ Course
+ insertOkay <- runDB $ insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
@@ -439,34 +431,33 @@ courseEditHandler isGet mbCourseForm = do
Nothing ->
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
- (FormSuccess res@(
- CourseForm { cfCourseId = Just cid
- , cfShort = csh
- , cfSchool = ssh
- , cfTerm = tid
- })) -> do -- edit existing course
+ (FormSuccess res@CourseForm
+ { cfCourseId = Just cid
+ , cfShort = csh
+ , cfSchool = ssh
+ , cfTerm = tid
+ }) -> do -- edit existing course
now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|]
success <- runDB $ do
old <- get cid
case old of
Nothing -> addMessageI Error MsgInvalidInput $> False
- (Just oldCourse) -> do
- updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
- Course { courseName = cfName res
- , courseDescription = cfDesc res
- , courseLinkExternal = cfLink res
- , courseShorthand = cfShort res
- , courseTerm = cfTerm res -- dangerous
- , courseSchool = cfSchool res
- , courseCapacity = cfCapacity res
- , courseRegisterSecret = cfSecret res
- , courseMaterialFree = cfMatFree res
- , courseRegisterFrom = cfRegFrom res
- , courseRegisterTo = cfRegTo res
- , courseDeregisterUntil = cfDeRegUntil res
- }
- )
+ (Just _) -> do
+ updOkay <- myReplaceUnique cid Course
+ { courseName = cfName res
+ , courseDescription = cfDesc res
+ , courseLinkExternal = cfLink res
+ , courseShorthand = cfShort res
+ , courseTerm = cfTerm res -- dangerous
+ , courseSchool = cfSchool res
+ , courseCapacity = cfCapacity res
+ , courseRegisterSecret = cfSecret res
+ , courseMaterialFree = cfMatFree res
+ , courseRegisterFrom = cfRegFrom res
+ , courseRegisterTo = cfRegTo res
+ , courseDeregisterUntil = cfDeRegUntil res
+ }
case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
@@ -476,7 +467,7 @@ courseEditHandler isGet mbCourseForm = do
when success $ redirect $ CourseR tid ssh csh CShowR
(FormFailure _) -> addMessageI Warning MsgInvalidInput
- (FormMissing) -> return ()
+ FormMissing -> return ()
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
defaultLayout $ do
setTitleI MsgCourseEditTitle
@@ -578,7 +569,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
validateCourse :: CourseForm -> [Text]
-validateCourse (CourseForm{..}) =
+validateCourse CourseForm{..} =
[ msg | (False, msg) <-
[
( NTop cfRegFrom <= NTop cfRegTo
@@ -598,18 +589,24 @@ validateCourse (CourseForm{..}) =
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCUsersR tid ssh csh = undefined -- TODO
+getCUsersR = error "CUsersR: Not implemented"
getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
-getCUserR tid ssh csh uuid = do
- uid <- decrypt uuid
+getCUserR _tid _ssh _csh uCId = do
+ -- Needs authorization check:
+ --
+ -- - User is current member of course
+ -- - User has submitted in course
+ -- - User is member of registered group for course
+ -- - User is corrector for course (?)
+ -- - User is lecturer for course (?)
+ uid <- decrypt uCId
User{..} <- runDB $ get404 uid
- defaultLayout $
+ defaultLayout -- TODO
[whamlet|
- TODO
- Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
+
^{nameWidget userDisplayName userSurname}
|]
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCHiWisR tid ssh csh = undefined -- TODO
+getCHiWisR = error "CHiWisR: Not implemented"
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 8c93c4a17..479e50a97 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -8,7 +8,6 @@ import qualified Data.Map as Map
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8')
import Data.Time hiding (formatTime)
-import Data.Universe
import Data.Universe.Helpers
import Network.Wai (requestHeaderReferer)
@@ -56,43 +55,44 @@ homeAnonymous = do
let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course))
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.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
- E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
+ E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
+ E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
+ )
return course
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat
[ -- 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
- , 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
- , 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
ssh = courseSchool course
csh = courseShorthand course
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
]
- ((), courseTable) <- dbTable def $ DBTable
+ ((), courseTable) <- dbTable def DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = colonnade
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "term"
- , SortColumn $ \(course) -> course E.^. CourseTerm
+ , SortColumn $ \course -> course E.^. CourseTerm
)
, ( "school"
- , SortColumn $ \(course) -> course E.^. CourseSchool
+ , SortColumn $ \course -> course E.^. CourseSchool
)
, ( "course"
- , SortColumn $ \(course) -> course E.^. CourseShorthand
+ , SortColumn $ \course -> course E.^. CourseShorthand
)
, ( "deadline"
- , SortColumn $ \(course) -> course E.^. CourseRegisterTo
+ , SortColumn $ \course -> course E.^. CourseRegisterTo
)
]
, dbtFilter = mempty {- [ ( "term"
@@ -106,7 +106,7 @@ homeAnonymous = do
}
-- let features = $(widgetFile "featureList")
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
- defaultLayout $ do
+ defaultLayout
-- $(widgetFile "dsgvDisclaimer")
$(widgetFile "home")
@@ -126,7 +126,7 @@ homeUser uid = do
, E.SqlExpr (E.Value (Maybe SubmissionId)))
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.&&. (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 $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
@@ -164,14 +164,14 @@ homeUser uid = do
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
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
Nothing -> mempty
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark
]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
- ((), sheetTable) <- dbTable validator $ DBTable
+ ((), sheetTable) <- dbTable validator DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = colonnade
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
@@ -206,7 +206,7 @@ homeUser uid = do
, dbtIdent = "upcomingdeadlines" :: Text
}
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
- defaultLayout $ do
+ defaultLayout $
-- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser")
-- $(widgetFile "dsgvDisclaimer")
@@ -276,12 +276,14 @@ postHelpR = do
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
case res of
- FormSuccess (HelpForm{..}) -> do
+ FormSuccess HelpForm{..} -> do
now <- liftIO getCurrentTime
- queueJob' $ JobHelpRequest { jSender = hfUserId
- , jHelpRequest = hfRequest
- , jRequestTime = now
- , jReferer = hfReferer }
+ queueJob' JobHelpRequest
+ { jSender = hfUserId
+ , jHelpRequest = hfRequest
+ , jRequestTime = now
+ , jReferer = hfReferer
+ }
-- redirect $ HelpR
addMessageI Success MsgHelpSent
return ()
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 3b16c186d..fbbdff58f 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -67,7 +67,7 @@ getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR
postProfileR = do
(uid, User{..}) <- requireAuthPair
- let settingsTemplate = Just $ SettingsForm
+ let settingsTemplate = Just SettingsForm
{ stgMaxFavourties = userMaxFavourites
, stgTheme = userTheme
, stgDateTime = userDateTimeFormat
@@ -92,13 +92,13 @@ postProfileR = do
-- prune Favourites to user-defined size
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime
- , OffsetBy $ stgMaxFavourties
+ , 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 ()
let formText = Nothing :: Maybe UniWorXMessage
@@ -109,7 +109,7 @@ postProfileR = do
postProfileDataR :: Handler Html
postProfileDataR = do
- ((btnResult,_), _) <- runFormPost $ buttonForm
+ ((btnResult,_), _) <- runFormPost buttonForm
case btnResult of
(FormSuccess BtnDelete) -> do
(uid, User{..}) <- requireAuthPair
@@ -119,7 +119,7 @@ postProfileDataR = do
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-- addMessageI Success $ MsgDeleteUser deletedSubmissions
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
- defaultLayout $ do
+ defaultLayout
$(widgetFile "deletedUser")
(FormSuccess BtnAbort ) -> do
@@ -156,72 +156,76 @@ deleteUser duid = do
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
- E.&&. (whereBuddies numBuddies)
+ E.&&. whereBuddies numBuddies
return $ submission E.^. SubmissionId
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
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.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
return $ file E.^. FileId
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.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
- E.where_ $ E.notExists $ E.from $ \subGroupUser -> do
+ E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
+ E.where_ $ E.notExists $ E.from $ \subGroupUser ->
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
(uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
- (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
- E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
- E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
- return (school E.^. SchoolShorthand)
- )
+ E.select
+ ( E.from $ \(adright `E.InnerJoin` school) -> do
+ E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
+ E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
+ return (school E.^. SchoolShorthand)
+ )
<*>
- (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
- E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
- E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
- return (school E.^. SchoolShorthand)
- )
+ E.select
+ ( E.from $ \(lecright `E.InnerJoin` school) -> do
+ E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
+ 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.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
- E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
- E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
- return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
- )
+ E.select
+ ( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
+ E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+ E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
+ 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.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
- E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
- E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
- return ( ( studydegree E.^. StudyDegreeName
- , studydegree E.^. StudyDegreeKey
- )
- , ( studyterms E.^. StudyTermsName
- , studyterms E.^. StudyTermsKey
- )
- , studyfeat E.^. StudyFeaturesType
- , studyfeat E.^. StudyFeaturesSemester)
- )
+ E.select
+ ( E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+ E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+ E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
+ E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+ return ( ( studydegree E.^. StudyDegreeName
+ , studydegree E.^. StudyDegreeKey
+ )
+ , ( studyterms E.^. StudyTermsName
+ , studyterms E.^. StudyTermsKey
+ )
+ , studyfeat E.^. StudyFeaturesType
+ , studyfeat E.^. StudyFeaturesSemester)
+ )
-- Tabelle mit eigenen Kursen
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
enrolledCoursesTable <- mkEnrolledCoursesTable uid
-- 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
submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen
@@ -229,42 +233,14 @@ getProfileDataR = do
-- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid
-- 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
- tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+ let tutorialTable = [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|
-