diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7a8c55085..4d0be8c42 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -166,7 +166,7 @@ SheetName: Name SheetDescription: Hinweise für Teilnehmer SheetGroup: Gruppenabgabe SheetVisibleFrom: Sichtbar für Teilnehmer ab -SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Fristen/Bewertung sich noch ändern kann +SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können SheetActiveFrom: Beginn Abgabezeitraum SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich SheetActiveTo: Ende Abgabezeitraum @@ -208,11 +208,22 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} CorrectorAssignTitle: Korrektor zuweisen +MaterialName: Name +MaterialType: Art +MaterialTypePlaceholder: Folien, Code, Beispiel, ... +MaterialTypeSlides: Folien +MaterialTypeCode: Code +MaterialTypeExample: Beispiel +MaterialDescription: Beschreibung +MaterialVisibleFrom: Sichtbar für Teilnehmer ab +MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren +MaterialFiles: Dateien + Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) -UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. +UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden. diff --git a/models/materials b/models/materials new file mode 100644 index 000000000..d715abc63 --- /dev/null +++ b/models/materials @@ -0,0 +1,11 @@ +Material -- course material for disemination to course participants + course CourseId + name (CI Text) + type Text Maybe + description Html Maybe + visibleFrom UTCTime Maybe -- Invisible to enrolled participants before + lastEdit UTCTime + UniqueMaterial course name +MaterialFile -- a file that is part of a material distribution + material MaterialId + file FileId \ No newline at end of file diff --git a/routes b/routes index 0e801e22b..a86f39945 100644 --- a/routes +++ b/routes @@ -13,7 +13,7 @@ -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) -- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) --- !registered -- participant for this course (no effect outside of courses) +-- !registered -- current user is participant for this course (no effect outside of courses) -- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) -- !owner -- part of the group of owners of this submission -- !self -- route refers to the currently logged in user themselves @@ -106,7 +106,12 @@ /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions /corrector-invite/#UserEmail SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector - + /mat MaterialListR GET !materials !registered !corrector + /mat/new MaterialNewR GET POST + /mat/#MaterialName MaterialR: + /show MShowR GET !timeANDregistered !timeANDmaterials !corrector + /edit MEditR GET POST + /delete MDelR GET POST /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 5b130dd50..e1dc1904e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -71,7 +71,7 @@ import qualified Data.Aeson as Aeson import System.Exit (exitFailure) import qualified Database.Memcached.Binary.IO as Memcached - + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -87,6 +87,7 @@ import Handler.Course import Handler.Sheet import Handler.Submission import Handler.Corrections +import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage @@ -172,7 +173,7 @@ makeFoundation appSettings'@AppSettings{..} = do (pgPoolSize appDatabaseConf) ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) - + -- Perform database migration using our application's logging settings. migrateAll `runSqlPool` sqlPool appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool @@ -205,7 +206,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do new <- initClusterSetting proxy void . insert $ ClusterConfig key (Aeson.toJSON new) return new - + readInstanceIDFile :: MonadIO m => FilePath -> m UUID readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS where @@ -226,7 +227,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do let withLogging :: LoggingT IO a -> IO a withLogging = flip runLoggingT logFunc - + mkConnection = withLogging $ do $logInfoS "SMTP" "Opening new connection" liftIO mkConnection' @@ -346,7 +347,7 @@ appMain = runResourceT $ do -------------------------------------------------------------- foundationStoreNum :: Word32 foundationStoreNum = 2 - + getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings @@ -357,7 +358,7 @@ getApplicationRepl = do let foundationStore = Store foundationStoreNum liftIO $ deleteStore foundationStore liftIO $ writeStore foundationStore foundation - + return (getPort wsettings, foundation, app1) shutdownApp :: MonadIO m => UniWorX -> m () diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs new file mode 100644 index 000000000..b738e0105 --- /dev/null +++ b/src/Handler/Material.hs @@ -0,0 +1,73 @@ +module Handler.Material where + +import Import + +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Conduit.List as C + +import qualified Database.Esqueleto as E + +import Utils.Lens +import Utils.Form +import Handler.Utils.Form + + +data MaterialForm = MaterialForm { + mfName :: MaterialName + , mfType :: Maybe Text + , mfDescription :: Maybe Html + , mfVisibleFrom :: Maybe UTCTime + , mfFiles :: Maybe (Source Handler (Either FileId File)) + } + +makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm +makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do + MsgRenderer mr <- getMsgRenderer + let setIds :: Either FileId File -> Set FileId + setIds = either Set.singleton $ const Set.empty + oldFileIds + | Just source <- template >>= mfFiles + = runConduit $ source .| C.foldMap setIds + | otherwise = return Set.empty + typeOptions :: WidgetT UniWorX IO (Set Text) + typeOptions = do + let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] + previouslyUsed <- liftHandlerT . runDB $ + E.select $ E.from $ \material -> + E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do + E.where_ $ (material E.^. MaterialCourse E.==. E.val cid) + E.&&. (E.not_ $ E.isNothing $ material E.^. MaterialType) + return $ material E.^. MaterialType + return $ defaults <> (Set.fromList $ mapMaybe E.unValue previouslyUsed) + + ctime <- liftIO $ getCurrentTime + flip (renderAForm FormStandard) html $ MaterialForm + <$> areq ciField (fslI MsgMaterialName) (mfName <$> template) + <*> aopt (textField & addDatalist typeOptions) + (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder) + (mfType <$> template) + <*> aopt htmlField (fslpI MsgMaterialDescription "Html") + (mfDescription <$> template) + <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom + & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) + <*> aopt (multiFileField oldFileIds) + (fslI MsgMaterialFiles) (mfFiles <$> template) + +getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialListR = error "unimplemented" -- TODO + +getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialNewR = postMaterialNewR +postMaterialNewR = error "unimplemented" -- TODO + +getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMShowR = error "unimplemented" -- TODO + +getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMEditR = postMEditR +postMEditR = error "unimplemented" -- TODO + +getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMDelR = postMDelR +postMDelR = error "unimplemented" -- TODO \ No newline at end of file diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5016f8662..92f79ed39 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -99,7 +99,8 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do ctime <- liftIO $ getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq ciField (fslI MsgSheetName) (sfName <$> template) - <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) + <*> aopt htmlField (fslpI MsgSheetDescription "Html") + (sfDescription <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded])) (sfType <$> template) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index ab73b6ba7..05d063e6a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -83,7 +83,7 @@ import Data.Text.Metrics (damerauLevenshtein) import Data.Binary (Binary) import qualified Data.Binary as Binary - + instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack @@ -350,7 +350,7 @@ classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth - + data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) @@ -880,6 +880,7 @@ type SchoolShorthand = CI Text type CourseName = CI Text type CourseShorthand = CI Text type SheetName = CI Text +type MaterialName = CI Text type UserEmail = CI Email type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 25180df04..0cd5d0335 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -168,6 +168,7 @@ data FormIdentifier = FIDcourse | FIDcourseRegister | FIDsheet + | FIDmaterial | FIDsubmission | FIDsettings | FIDcorrectors