Initial Stubs

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.

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

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

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 ()

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

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)

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

src/Utils/Form.hs

@@ -168,6 +168,7 @@ data FormIdentifier
   = FIDcourse
   | FIDcourseRegister
   | FIDsheet
+  | FIDmaterial
   | FIDsubmission
   | FIDsettings
   | FIDcorrectors