Sheet Download works

FragenSJ.txt

@@ -1,5 +1,8 @@
 ** i18n:
- - i18n der Links, Page Titles und Buttons?
+ - i18n der
+      Links       ->
+      Page Titles -> setTitleI
+      Buttons?
    Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel?
    Was ist mit PageTitles, z.B. in Handler.Term.termEditHandler:
     -- setTitle [whamlet| _{MsgTermNewTitle} |] -- TODO, does not work
@@ -10,9 +13,6 @@
 
 
 ** FORMS
- 1- Handler.Utils.Form.FormIdentifier: Still needed?
- 2- Verification of Ownership during Edit?
-    D.h. wo wird geprüft, dass Sheet Ersteller Lecturer im Kurs ist?
  3 - Sheets: Multiple Files
    - Versionen für Studenten/Korrektoren/Lecturers/Admins?!
 

routes

@@ -22,6 +22,7 @@
 /course/#TermId/#Text/sheet/#Text/show      SheetShowR   GET
 /course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR  GET
 /course/#TermId/#Text/sheet/new             SheetNewR   GET POST
+-- TODO: Change routes to #Text statt #SheetId
 /course/#TermId/#Text/sheet/#SheetId/edit   SheetEditR  GET POST
 /course/#TermId/#Text/sheet/#SheetId/delete SheetDelR   GET POST
 

src/Foundation.hs

@@ -200,6 +200,9 @@ isAuthorizedDB TermEditR              _ = adminAccess Nothing
 isAuthorizedDB (TermEditExistR _)     _ = adminAccess Nothing
 isAuthorizedDB CourseNewR             _ = lecturerAccess Nothing
 isAuthorizedDB (CourseEditR t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetListR  t c)  False = return Authorized --
+isAuthorizedDB (SheetShowR  t c s)    _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
+isAuthorizedDB (SheetFileR  t c s _ _ )_ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
 isAuthorizedDB (SheetListR  t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (SheetNewR   t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (SheetEditR  t c s)    _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)

src/Handler/Sheet.hs

@@ -48,7 +48,7 @@ data SheetForm = SheetForm
       , sfHintF        :: Maybe FileInfo
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe FileInfo
-      , sfSheetId      :: Maybe SheetId
+      -- Keine SheetId im Formular!
       }
 
 
@@ -57,11 +57,10 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
     -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
     -- Erstmal nur mit ZIP arbeiten
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq textField     (fsb "Name")        (sfName <$> template)
+      <$> areq textField     (fsb "Name")                     (sfName <$> template)
       <*> aopt htmlField     (fsb "Hinweise für Teilnehmer")  (sfMarkingText <$> template)
-      <*> sheetTypeAFormReq  (fsb "Bewertung")     (sfType <$> template)
+      <*> sheetTypeAFormReq  (fsb "Bewertung")                (sfType <$> template)
       <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
-      --TODO: SICHTBARKEIT hinzunehmen
       <*> aopt htmlField     (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
       <*> aopt utcTimeField  (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
       <*> areq utcTimeField  (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
@@ -71,7 +70,6 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
       <*> fileAFormOpt       (fsb "Hinweis")
       <*> aopt utcTimeField  (fsb "Lösung ab")   (sfSolutionFrom <$> template)
       <*> fileAFormOpt       (fsb "Lösung")
-      <*> aopt hiddenField "EditSheetId"         (sfSheetId <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
@@ -156,29 +154,27 @@ getSheetList courseEnt = do
 
 -- Show single sheet
 getSheetShowR :: TermId -> Text -> Text -> Handler Html
-getSheetShowR tid csh shn = getSheetShow =<<
+getSheetShowR tid csh shn = do
-  (runDB $ fetchSheet tid csh shn)
+  entSheet <- runDB $ fetchSheet tid csh shn
-
-{- Nur per UUID
-getSheetIdShowR :: SheetId -> Handler Html
-getSheetIdShowR sheetId = getSheetShow =<<
-  (Entity sheetId) <$> (runDB $ get404 sheetId)\
--}{-
-getSheetUUIDShowR :: CryptoUUIDSheet -> Handler Html
-getSheetUUIDShowR sUUID = do
-  cIDKey <- getsYesod appCryptoIDKey
-  sheetId <- UUID.decrypt cIDKey sUUID
-  sheetEnt <- runDB $ get404 sheetId
-  getSheetShow $ Entity sheetId sheetEnt
--}
-
-getSheetShow :: (Entity Sheet) -> Handler Html
-getSheetShow entSheet = do
   let sheet = entityVal entSheet
+      sid   = entityKey entSheet
+  --
+  fileNameTypes <- runDB $ E.select $ E.from $
+    \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
+      -- Restrict to consistent rows that correspond to each other
+      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFileId)
+      E.on (sheetFile E.^. SheetFileSheetId E.==. sheet     E.^. SheetId)
+      -- filter to requested file
+      E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
+      -- return desired columns
+      return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
+  let fileLinks = map (\(E.Value fName, E.Value fType) -> SheetFileR tid csh shn fType fName) fileNameTypes
+
   defaultLayout $ do
     setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
-    [whamlet| Under Construction !!! |] -- TODO
     $(widgetFile "sheetAdmin")
+    [whamlet| Under Construction !!! |] -- TODO
+
 
 getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
 getSheetFileR tid csh shn typ title = do
@@ -209,7 +205,6 @@ getSheetNewR :: TermId -> Text -> Handler Html
 getSheetNewR tid csh = do
   let tident = unTermKey tid
   aid <- requireAuthId
-  -- TODO: Verify that aid is lecturer in Course? Here or in Auth?
   (Entity cid course) <- runDB $ getBy404 $ CourseTermShort tid csh
   let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
   ((res,wdgt), enc) <- runFormPost $ makeSheetForm cid template
@@ -233,20 +228,33 @@ getSheetNewR tid csh = do
             , sheetCreatedBy    = aid
             , sheetChangedBy    = aid
             }
-      insertOkay <- runDB $ insertUnique sheet
+      saveOkay <- runDB $ do
-      case insertOkay of
+        insertOkay <- insertUnique sheet
-        Nothing    -> addMessageI "danger" $ MsgSheetNewDup tident csh sfName
+        case insertOkay of
-        (Just sid) -> do
+          Nothing    -> insertOkay <$ addMessageI "danger" (MsgSheetNewDup tident csh sfName)
-          addMessageI "info" $ MsgSheetNewOk tident csh sfName
+          (Just sid) -> do
-          -- Save Files in DB:
+            addMessageI "info" $ MsgSheetNewOk tident csh sfName
-          -- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
+            -- Save Files in DB:
-          whenIsJust sfSheetF $ \sinfo -> do
+            -- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
-            let sheetInsert file = do
+            whenIsJust sfSheetF $ \sinfo -> do
-                  fid <- insert file
+              let sheetInsert file = do
-                  void . insert $ SheetFile sid fid SheetExercise -- Uniqueness?
+                    fid <- insert file
-            runDB . runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
+                    void . insert $ SheetFile sid fid SheetExercise -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
-
+              runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
-          redirect $ SheetShowR tid csh sfName
+            --
+            whenIsJust sfHintF $ \sinfo -> do
+              let sheetInsert file = do
+                    fid <- insert file
+                    void . insert $ SheetFile sid fid SheetHint -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+              runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
+            --
+            whenIsJust sfSolutionF $ \sinfo -> do
+              let sheetInsert file = do
+                    fid <- insert file
+                    void . insert $ SheetFile sid fid SheetSolution -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+              runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
+            return insertOkay
+      when (isJust saveOkay) $ redirect $ SheetShowR tid csh sfName
     (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
     _ -> return ()
   defaultLayout $ do

src/Handler/Utils.hs

@@ -1,12 +1,15 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
 
+
 module Handler.Utils
   ( module Handler.Utils
   ) where
 
+
+
 import Import.NoFoundation
   
 import Handler.Utils.DateTime as Handler.Utils
@@ -22,6 +25,9 @@ import Text.Blaze (Markup, ToMarkup)
 
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.List as List
+
+import Database.Persist.Class
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"
@@ -61,3 +67,38 @@ whenIsJust Nothing  _ = return ()
 entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
 entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
 
+
+--------
+-- DB --
+--------
+
+myReplaceUnique
+    :: (MonadIO m
+       ,Eq (Unique record)
+       ,PersistRecordBackend record backend
+       ,PersistUniqueWrite backend)
+    => Key record -> record -> ReaderT backend m (Maybe (Unique record))
+myReplaceUnique key datumNew = getJust key >>= replaceOriginal
+  where
+    uniqueKeysNew = persistUniqueKeys datumNew
+    replaceOriginal original = do
+        conflict <- checkUniqueKeys changedKeys
+        case conflict of
+            Nothing -> replace key datumNew >> return Nothing
+            (Just conflictingKey) -> return $ Just conflictingKey
+      where
+        changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
+        uniqueKeysOriginal = persistUniqueKeys original
+
+checkUniqueKeys
+    :: (MonadIO m
+       ,PersistEntity record
+       ,PersistUniqueRead backend
+       ,PersistRecordBackend record backend)
+    => [Unique record] -> ReaderT backend m (Maybe (Unique record))
+checkUniqueKeys [] = return Nothing
+checkUniqueKeys (x:xs) = do
+    y <- getBy x
+    case y of
+        Nothing -> checkUniqueKeys xs
+        Just _ -> return (Just x)

src/Handler/Utils/Form.hs

@@ -35,9 +35,14 @@ data FormIdentifier = FIDcourse | FIDsheet
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
-identForm :: FormIdentifier -> Form a -> Form a   -- TODO: Still needed?
+identForm :: FormIdentifier -> Form a -> Form a
 identForm fid = identifyForm (T.pack $ show fid)
 
+{- Hinweise zur Erinnerung:
+  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
+  - nur einmal pro makeForm reicht
+-}
+
 -------------------
 -- Form Renderer --
 -------------------

templates/sheetAdmin.hamlet

@@ -24,7 +24,10 @@
 
         <div .row>
             <div .col-lg-12>     
-                <h2>Abgaben
+                <h2>Dateien
+                <ul>
+                  $forall fileLink <- fileLinks
+                    <li> <a href=@{fileLink}>@{fileLink}
 
     <hr>