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

Work-in-progress, fixes #158

Browse Source
This commit is contained in:
SJost 2018-08-22 13:38:13 +02:00
parent a4dacc8d01
commit 5810dc5182
12 changed files with 93 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
messages/uniworx/de.msg
View File

@ -38,10 +38,10 @@ CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet CourseDeregisterOk: Sie wurden abgemeldet
CourseSecretWrong: Falsches Kennwort CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort CourseSecret: Zugangspasswort
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert. CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseNewDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
FFSheetName: Name FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{display tid} TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
CourseListTitle: Alle Kurse CourseListTitle: Alle Kurse

40
src/Handler/Course.hs
View File

@ -80,12 +80,12 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|] anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
@ -289,12 +289,12 @@ postCourseNewR = courseEditHandler False Nothing
getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR tid ssh csh = do getCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermShort tid ssh csh course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh
courseEditHandler True course courseEditHandler True course
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCEditR tid ssh csh = do postCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermShort tid ssh csh course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh
courseEditHandler False course courseEditHandler False course
@ -431,7 +431,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
] ]
let schoolField = selectField $ fmap entityKey <$> optionsPersistCryptoId [SchoolId <-. userSchools] [Asc SchoolName] schoolName
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template) <$> pure (cfCourseId =<< template)
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
@ -442,24 +441,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) & setTooltip MsgCourseShorthandUnique)
(cfShort <$> template) (cfShort <$> template)
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
) (cfCapacity <$> template) <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" & setTooltip MsgCourseSecretTip) (cfSecret <$> template)
& setTooltip MsgCourseSecretTip) <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
(cfSecret <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) & setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
& setTooltip MsgCourseRegisterFromTip) & setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template)
(cfRegFrom <$> template) <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" & setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template)
& setTooltip MsgCourseRegisterToTip)
(cfRegTo <$> template)
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
& setTooltip MsgCourseDeregisterUntilTip)
(cfDeRegUntil <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of
FormSuccess courseResult FormSuccess courseResult

18
src/Handler/Home.hs
View File

@ -22,12 +22,12 @@ import Data.Time hiding (formatTime)
-- import Web.PathPieces (showToPathPiece, readFromPathPiece) -- import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Control.Lens -- import Control.Lens
import Colonnade hiding (fromMaybe, singleton) -- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade -- import Yesod.Colonnade
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Text.Shakespeare.Text -- import Text.Shakespeare.Text
import Development.GitRev import Development.GitRev
@ -55,7 +55,6 @@ getHomeR = do
homeAnonymous :: Handler Html homeAnonymous :: Handler Html
homeAnonymous = do homeAnonymous = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime
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
@ -68,9 +67,9 @@ homeAnonymous = do
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") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
textCell $ display $ courseTerm course textCell $ display $ courseTerm course
, sortable (Just "school") (textCell MsgCourseSchool) $ DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
textCell $ display $ courseSchool course textCell $ display $ courseSchool course
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do , sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
let tid = courseTerm course let tid = courseTerm course
@ -122,6 +121,7 @@ homeUser uid = do
-- (E.SqlExpr (Entity Course ))) -- (E.SqlExpr (Entity Course )))
-- (E.SqlExpr (Entity Sheet )) -- (E.SqlExpr (Entity Sheet ))
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
, E.SqlExpr (E.Value SchoolId)
, E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value SheetName)
, E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value UTCTime)
@ -166,7 +166,7 @@ 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") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value, ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> , sortable (Just "done") (textCell 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)
@ -176,8 +176,8 @@ homeUser uid = do
((), sheetTable) <- dbTable validator $ DBTable ((), sheetTable) <- dbTable validator $ DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
-> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False) -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "term" [ ( "term"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm

2
src/Handler/Profile.hs
View File

@ -141,7 +141,7 @@ postProfileR = do
getProfileDataR :: Handler Html getProfileDataR :: Handler Html
getProfileDataR = do getProfileDataR = do
(uid, User{..}) <- requireAuthPair (_uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender -- mr <- getMessageRender
defaultLayout $ do defaultLayout $ do

52
src/Handler/Sheet.hs
View File

@ -21,31 +21,31 @@ import Import
import System.FilePath (takeFileName) import System.FilePath (takeFileName)
import Handler.Utils import Handler.Utils
import Handler.Utils.Zip -- import Handler.Utils.Zip
-- import Data.Time -- import Data.Time
import qualified Data.Text as T -- import qualified Data.Text as T
-- import Data.Function ((&)) -- import Data.Function ((&))
-- --
import Colonnade hiding (fromMaybe, singleton, bool) -- import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod import qualified Yesod.Colonnade as Yesod
import Text.Blaze (text) import Text.Blaze (text)
-- --
import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Data.CaseInsensitive (CI) -- import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E -- import qualified Database.Esqueleto.Internal.Sql as E
import Control.Monad.Writer (MonadWriter(..), execWriterT) import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.Trans.RWS.Lazy (RWST, local) -- import Control.Monad.Trans.RWS.Lazy (RWST, local)
import qualified Text.Email.Validate as Email -- import qualified Text.Email.Validate as Email
import qualified Data.List as List -- import qualified Data.List as List
import Network.Mime import Network.Mime
@ -59,7 +59,7 @@ import qualified Data.Map as Map
import Data.Monoid (Sum(..)) import Data.Monoid (Sum(..))
import Control.Lens import Control.Lens
import Utils.Lens -- import Utils.Lens
instance Eq (Unique Sheet) where instance Eq (Unique Sheet) where
@ -166,14 +166,14 @@ getSheetListR tid ssh csh = do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit E.^. SheetEditTime return . E.max_ $ sheetEdit' E.^. SheetEditTime
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, sheetEdit, submission) return (sheet, sheetEdit, submission)
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet) [ sortable (Just "name") (i18nCell MsgSheet)
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName) $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit) , sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \(_, E.Value mEditTime, _) -> case mEditTime of $ \(_, E.Value mEditTime, _) -> case mEditTime of
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
@ -190,9 +190,9 @@ getSheetListR tid ssh csh = do
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid -- TODO: executed twice let mkCid = encrypt sid -- TODO: executed twice
mkRoute = do mkRoute = do
cid <- mkCid cid' <- mkCid
return $ CSubmissionR tid csh sheetName cid SubShowR return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
, sortable (Just "rating") (i18nCell MsgRating) , sortable (Just "rating") (i18nCell MsgRating)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
Nothing -> mempty Nothing -> mempty
@ -200,7 +200,7 @@ getSheetListR tid ssh csh = do
let mkCid = encrypt sid let mkCid = encrypt sid
mkRoute = do mkRoute = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
, sortable Nothing -- (Just "percent") , sortable Nothing -- (Just "percent")
@ -271,7 +271,7 @@ getSShowR tid ssh csh shn = do
-- E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- E.where_ (sheet E.^. SheetId E.==. E.val sid )
-- -- return desired columns -- -- return desired columns
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) -- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade -- with Colonnade
let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
@ -295,7 +295,7 @@ getSShowR tid ssh csh shn = do
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn $ SFileR fType fName) False) -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
, dbtStyle = def , dbtStyle = def
, dbtFilter = Map.empty , dbtFilter = Map.empty
, dbtIdent = "files" :: Text , dbtIdent = "files" :: Text
@ -319,7 +319,7 @@ getSShowR tid ssh csh shn = do
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $ when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid ssh csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
@ -402,7 +402,7 @@ getSEditR tid ssh csh shn = do
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR postSEditR = getSEditR
handleSheetEdit :: TermId -> SchoolId -< CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid ssh csh msId template dbAction = do handleSheetEdit tid ssh csh msId template dbAction = do
let mbshn = sfName <$> template let mbshn = sfName <$> template
aid <- requireAuthId aid <- requireAuthId
@ -456,7 +456,7 @@ getSDelR tid ssh csh shn = do
case result of case result of
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
(FormSuccess BtnDelete) -> do (FormSuccess BtnDelete) -> do
runDB $ fetchSheetId tid csh shn >>= deleteCascade runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
addMessageI "info" $ MsgSheetDelOk tid ssh csh shn addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
redirect $ CourseR tid ssh csh SheetListR redirect $ CourseR tid ssh csh SheetListR
@ -464,7 +464,7 @@ getSDelR tid ssh csh shn = do
submissionno <- runDB $ do submissionno <- runDB $ do
sid <- fetchSheetId tid ssh csh shn sid <- fetchSheetId tid ssh csh shn
count [SubmissionSheet ==. sid] count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelHead tid csh shn let formTitle = MsgSheetDelHead tid ssh csh shn
let formText = Just $ MsgSheetDelText submissionno let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid ssh csh shn SDelR let actionUrl = CSheetR tid ssh csh shn SDelR
defaultLayout $ do defaultLayout $ do
@ -688,10 +688,10 @@ getSCorrR tid ssh csh shn = do
FormMissing -> return () FormMissing -> return ()
let let
-- formTitle = MsgSheetCorrectorsTitle tid csh shn -- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
formText = Nothing :: Maybe (SomeMessage UniWorX) formText = Nothing :: Maybe (SomeMessage UniWorX)
actionUrl = CSheetR tid ssh csh shn SCorrR actionUrl = CSheetR tid ssh csh shn SCorrR
-- actionUrl = CSheetR tid csh shn SShowR -- actionUrl = CSheetR tid ssh csh shn SShowR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")

34
src/Handler/Submission.hs
View File

@ -78,14 +78,14 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR getSubShowR = postSubShowR
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid ssh csh shn = do getSubmissionOwnR tid ssh csh shn = do
@ -108,7 +108,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
uid <- requireAuthId uid <- requireAuthId
msmid <- traverse decrypt mcid msmid <- traverse decrypt mcid
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
case msmid of case msmid of
Nothing -> do Nothing -> do
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@ -239,7 +239,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
_other -> return Nothing _other -> return Nothing
case mCID of case mCID of
Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
Nothing -> return () Nothing -> return ()
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@ -254,13 +254,13 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
Just isFile = origIsFile <|> corrIsFile Just isFile = origIsFile <|> corrIsFile
in if in if
| Just True <- origIsFile -> anchorCell (CSubmissionR tid 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 Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty Nothing -> cell mempty
Just (_, Entity _ File{..}) Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
([whamlet|_{MsgFileCorrected}|]) ([whamlet|_{MsgFileCorrected}|])
| otherwise -> textCell MsgFileCorrected | otherwise -> textCell MsgFileCorrected
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
@ -302,19 +302,19 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn
$(widgetFile "submission") $(widgetFile "submission")
getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
runDB $ do runDB $ do
submissionID <- submissionMatchesSheet tid csh shn cID submissionID <- submissionMatchesSheet tid ssh csh shn cID
isRating <- maybe False (== submissionID) <$> isRatingFile path isRating <- maybe False (== submissionID) <$> isRatingFile path
when (isUpdate || isRating) $ when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
case isRating of case isRating of
True True
@ -343,10 +343,10 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
$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 -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
let filename let filename
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
@ -354,7 +354,7 @@ getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
submissionID <- lift $ submissionMatchesSheet tid csh shn cID submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
rating <- lift $ getRating submissionID rating <- lift $ getRating submissionID
let let

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

@ -219,7 +219,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
return . fromRational $ round (sci * 100) % 100 return . fromRational $ round (sci * 100) % 100
--termField: see Utils.Term --termField: see Utils.Term
--schoolField: see Handler.Course
schoolField :: Field Handler SchoolId
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
schoolFieldEnt :: Field Handler (Entity School)
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolId <-. userSchools] [Asc SchoolName] schoolName
zipFileField :: Bool -- ^ Unpack zips? zipFileField :: Bool -- ^ Unpack zips?
-> Field Handler (Source Handler File) -> Field Handler (Source Handler File)

5
src/Utils.hs
View File

@ -86,6 +86,11 @@ unsupportedAuthPredicate = do
tickmark :: IsString a => a tickmark :: IsString a => a
tickmark = fromString "✔" tickmark = fromString "✔"
-- Avoid annoying warnings:
tickmarkS :: String
tickmarkS = tickmark
tickmarkT :: Text
tickmarkT = tickmark
text2Html :: Text -> Html text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types text2Html = toHtml -- prevents ambiguous types

2
templates/course.hamlet
View File

@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<dt .deflist__dt> <dt .deflist__dt>
<dd .deflist__dd> <dd .deflist__dd>
<div .course__registration> <div .course__registration>
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}> <form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm $# regWidget is defined through templates/widgets/registerForm
^{regWidget} ^{regWidget}
<dt .deflist__dt> <dt .deflist__dt>

2
templates/profile.hamlet
View File

@ -59,7 +59,7 @@
<dt .deflist__dt> Teilnehmer <dt .deflist__dt> Teilnehmer
<dd .deflist__dd> <dd .deflist__dd>
<dl .deflist> <dl .deflist>
$forall (E.Value tid, E.Valuse ssh, E.Value csh, regSince) <- participant $forall (E.Value tid, E.Value ssh, E.Value csh, regSince) <- participant
<dt .deflist__dt> <dt .deflist__dt>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<dd .deflist__dd> <dd .deflist__dd>

4
templates/submission.hamlet
View File

@ -1,8 +1,8 @@
$maybe cID <- mcid $maybe cID <- mcid
<section> <section>
<h2> <h2>
<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv <a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
(<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>) (<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
$if not (null lastEdits) $if not (null lastEdits)
<h3>_{MsgLastEdits} <h3>_{MsgLastEdits}
<ul> <ul>

2
templates/widgets/rating.hamlet
View File

@ -13,4 +13,4 @@ $maybe points <- submissionRatingPoints
$else $else
_{MsgNotPassed} _{MsgNotPassed}
$of NotGraded $of NotGraded
#{show tickmark} #{display tickmarkS}