Work-in-progress, fixes #158
This commit is contained in:
SJost
parent
a4dacc8d01
commit
5810dc5182
@ -38,10 +38,10 @@ CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{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.
|
||||
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.
|
||||
CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
|
||||
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 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
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
CourseListTitle: Alle Kurse
|
||||
|
||||
@ -80,12 +80,12 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
|
||||
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
|
||||
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } ->
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
||||
anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
|
||||
|
||||
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
||||
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } ->
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
||||
anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
|
||||
|
||||
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
@ -289,12 +289,12 @@ postCourseNewR = courseEditHandler False Nothing
|
||||
|
||||
getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid ssh csh
|
||||
course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh
|
||||
courseEditHandler True course
|
||||
|
||||
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid ssh csh
|
||||
course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh
|
||||
courseEditHandler False course
|
||||
|
||||
|
||||
@ -431,7 +431,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. 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
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
|
||||
@ -442,24 +441,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique)
|
||||
(cfShort <$> template)
|
||||
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
||||
& setTooltip MsgCourseCapacityTip
|
||||
) (cfCapacity <$> template)
|
||||
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
|
||||
& setTooltip MsgCourseSecretTip)
|
||||
(cfSecret <$> template)
|
||||
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
|
||||
& setTooltip MsgCourseRegisterFromTip)
|
||||
(cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
|
||||
& setTooltip MsgCourseRegisterToTip)
|
||||
(cfRegTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
|
||||
& setTooltip MsgCourseDeregisterUntilTip)
|
||||
(cfDeRegUntil <$> template)
|
||||
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
||||
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
||||
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
|
||||
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
|
||||
<*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
|
||||
& setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
|
||||
& setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
|
||||
& setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template)
|
||||
<* submitButton
|
||||
return $ case result of
|
||||
FormSuccess courseResult
|
||||
|
||||
@ -22,12 +22,12 @@ import Data.Time hiding (formatTime)
|
||||
|
||||
-- import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
||||
|
||||
import Control.Lens
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Control.Lens
|
||||
-- import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Yesod.Colonnade
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Text.Shakespeare.Text
|
||||
-- import Text.Shakespeare.Text
|
||||
|
||||
import Development.GitRev
|
||||
|
||||
@ -55,7 +55,6 @@ getHomeR = do
|
||||
homeAnonymous :: Handler Html
|
||||
homeAnonymous = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime
|
||||
let tableData :: E.SqlExpr (Entity Course)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity Course))
|
||||
tableData course = do
|
||||
@ -68,9 +67,9 @@ homeAnonymous = do
|
||||
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
|
||||
colonnade = mconcat
|
||||
[ -- 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
|
||||
, 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
|
||||
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
|
||||
let tid = courseTerm course
|
||||
@ -122,6 +121,7 @@ homeUser uid = do
|
||||
-- (E.SqlExpr (Entity Course )))
|
||||
-- (E.SqlExpr (Entity Sheet ))
|
||||
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
||||
, E.SqlExpr (E.Value SchoolId)
|
||||
, E.SqlExpr (E.Value CourseShorthand)
|
||||
, E.SqlExpr (E.Value SheetName)
|
||||
, E.SqlExpr (E.Value UTCTime)
|
||||
@ -166,7 +166,7 @@ homeUser uid = do
|
||||
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
|
||||
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
|
||||
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
|
||||
Nothing -> mempty
|
||||
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
||||
@ -176,8 +176,8 @@ homeUser uid = do
|
||||
((), sheetTable) <- dbTable validator $ DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtColonnade = colonnade
|
||||
, dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) }
|
||||
-> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False)
|
||||
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
||||
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "term"
|
||||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||
|
||||
@ -141,7 +141,7 @@ postProfileR = do
|
||||
|
||||
getProfileDataR :: Handler Html
|
||||
getProfileDataR = do
|
||||
(uid, User{..}) <- requireAuthPair
|
||||
(_uid, User{..}) <- requireAuthPair
|
||||
-- mr <- getMessageRender
|
||||
|
||||
defaultLayout $ do
|
||||
|
||||
@ -21,31 +21,31 @@ import Import
|
||||
import System.FilePath (takeFileName)
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Zip
|
||||
-- import Handler.Utils.Zip
|
||||
|
||||
-- import Data.Time
|
||||
import qualified Data.Text as T
|
||||
-- import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
-- import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
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 Data.CaseInsensitive (CI)
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
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.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
|
||||
|
||||
@ -59,7 +59,7 @@ import qualified Data.Map as Map
|
||||
import Data.Monoid (Sum(..))
|
||||
|
||||
import Control.Lens
|
||||
import Utils.Lens
|
||||
-- import Utils.Lens
|
||||
|
||||
|
||||
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 $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
||||
let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||
let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
|
||||
E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit' E.^. SheetEditTime
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return (sheet, sheetEdit, submission)
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ 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)
|
||||
$ \(_, E.Value mEditTime, _) -> case mEditTime of
|
||||
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
|
||||
@ -190,9 +190,9 @@ getSheetListR tid ssh csh = do
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid <- mkCid
|
||||
return $ CSubmissionR tid csh sheetName cid SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
cid' <- mkCid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
|
||||
Nothing -> mempty
|
||||
@ -200,7 +200,7 @@ getSheetListR tid ssh csh = do
|
||||
let mkCid = encrypt sid
|
||||
mkRoute = do
|
||||
cid <- mkCid
|
||||
return $ CSubmissionR tid csh sheetName cid CorrectionR
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
|
||||
, sortable Nothing -- (Just "percent")
|
||||
@ -271,7 +271,7 @@ getSShowR tid ssh csh shn = do
|
||||
-- E.where_ (sheet E.^. SheetId E.==. E.val sid )
|
||||
-- -- return desired columns
|
||||
-- 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
|
||||
|
||||
let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
|
||||
@ -295,7 +295,7 @@ getSShowR tid ssh csh shn = do
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, 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
|
||||
, dbtFilter = Map.empty
|
||||
, dbtIdent = "files" :: Text
|
||||
@ -319,7 +319,7 @@ getSShowR tid ssh csh shn = do
|
||||
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
|
||||
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
setTitleI $ MsgSheetTitle tid ssh csh shn
|
||||
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
|
||||
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo 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 = 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
|
||||
let mbshn = sfName <$> template
|
||||
aid <- requireAuthId
|
||||
@ -456,7 +456,7 @@ getSDelR tid ssh csh shn = do
|
||||
case result of
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
|
||||
(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!!!
|
||||
addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
|
||||
redirect $ CourseR tid ssh csh SheetListR
|
||||
@ -464,7 +464,7 @@ getSDelR tid ssh csh shn = do
|
||||
submissionno <- runDB $ do
|
||||
sid <- fetchSheetId tid ssh csh shn
|
||||
count [SubmissionSheet ==. sid]
|
||||
let formTitle = MsgSheetDelHead tid csh shn
|
||||
let formTitle = MsgSheetDelHead tid ssh csh shn
|
||||
let formText = Just $ MsgSheetDelText submissionno
|
||||
let actionUrl = CSheetR tid ssh csh shn SDelR
|
||||
defaultLayout $ do
|
||||
@ -688,10 +688,10 @@ getSCorrR tid ssh csh shn = do
|
||||
FormMissing -> return ()
|
||||
|
||||
let
|
||||
-- formTitle = MsgSheetCorrectorsTitle tid csh shn
|
||||
-- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
|
||||
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
||||
actionUrl = CSheetR tid ssh csh shn SCorrR
|
||||
-- actionUrl = CSheetR tid csh shn SShowR
|
||||
-- actionUrl = CSheetR tid ssh csh shn SShowR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
@ -78,14 +78,14 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
|
||||
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
||||
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
|
||||
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
|
||||
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 tid ssh csh shn = do
|
||||
@ -108,7 +108,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
(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
|
||||
Nothing -> 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
|
||||
|
||||
case mCID of
|
||||
Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
Nothing -> return ()
|
||||
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
@ -254,13 +254,13 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
|
||||
Just isFile = origIsFile <|> corrIsFile
|
||||
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'}|])
|
||||
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
||||
, sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
|
||||
Nothing -> cell mempty
|
||||
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}|])
|
||||
| otherwise -> textCell MsgFileCorrected
|
||||
, 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
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSubmissionEditHead tid csh shn
|
||||
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
||||
$(widgetFile "submission")
|
||||
|
||||
|
||||
getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
runDB $ do
|
||||
submissionID <- submissionMatchesSheet tid csh shn cID
|
||||
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
|
||||
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
|
||||
True
|
||||
@ -343,10 +343,10 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
|
||||
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
|
||||
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
let filename
|
||||
| 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}"|]
|
||||
respondSourceDB "application/zip" $ do
|
||||
submissionID <- lift $ submissionMatchesSheet tid csh shn cID
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
let
|
||||
|
||||
@ -219,7 +219,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
|
||||
return . fromRational $ round (sci * 100) % 100
|
||||
|
||||
--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?
|
||||
-> Field Handler (Source Handler File)
|
||||
|
||||
@ -86,6 +86,11 @@ unsupportedAuthPredicate = do
|
||||
|
||||
tickmark :: IsString a => a
|
||||
tickmark = fromString "✔"
|
||||
-- Avoid annoying warnings:
|
||||
tickmarkS :: String
|
||||
tickmarkS = tickmark
|
||||
tickmarkT :: Text
|
||||
tickmarkT = tickmark
|
||||
|
||||
text2Html :: Text -> Html
|
||||
text2Html = toHtml -- prevents ambiguous types
|
||||
|
||||
@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
<dt .deflist__dt>
|
||||
<dd .deflist__dd>
|
||||
<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}
|
||||
<dt .deflist__dt>
|
||||
|
||||
@ -59,7 +59,7 @@
|
||||
<dt .deflist__dt> Teilnehmer
|
||||
<dd .deflist__dd>
|
||||
<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>
|
||||
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
$maybe cID <- mcid
|
||||
<section>
|
||||
<h2>
|
||||
<a href=@{CSubmissionR tid 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 SubmissionCorrected))}>Archiv
|
||||
(<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
|
||||
$if not (null lastEdits)
|
||||
<h3>_{MsgLastEdits}
|
||||
<ul>
|
||||
|
||||
@ -13,4 +13,4 @@ $maybe points <- submissionRatingPoints
|
||||
$else
|
||||
_{MsgNotPassed}
|
||||
$of NotGraded
|
||||
#{show tickmark}
|
||||
#{display tickmarkS}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user