Several Cleanups

FragenSJ.txt

@@ -1,11 +1,9 @@
 ** i18n:
  - i18n der
-      Links       ->
+      Links       -> MenuItems verwenden wie bisher
       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
 
 ** Page pageActions
  - Berechtigungen prüfen?
@@ -13,6 +11,13 @@
 
 
 ** FORMS
- 3 - Sheets: Multiple Files
+ 3 - Sheets: Multiple Files -> wird später gemacht
-   - Versionen für Studenten/Korrektoren/Lecturers/Admins?!
+   - Versionen für Studenten/Korrektoren/Lecturers/Admins
+     -> ja über isAuthorizedDB siehe unten,
+     -> Lecturer kann gleich auf Edit-Seite gehen wie in UniWorX
 
+
+Freischaltung von Teilen einer Webseite:
+ - Freigabe der Links über Authorisierung in der Foundation
+ - Anzeige der Links nach Authorisierung wie in menItemAccessCallback
+ - möglichst direkt isAuthorizedDB in einem runDB aufrufen!!!

src/Foundation.hs

@@ -193,21 +193,21 @@ instance Yesod UniWorX where
 
 isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
 isAuthorizedDB UsersR _ = adminAccess Nothing
-isAuthorizedDB (SubmissionR cID)      _ = submissionAccess $ Right cID
+isAuthorizedDB (SubmissionR cID)       _ = submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
-isAuthorizedDB TermEditR              _ = adminAccess Nothing
+isAuthorizedDB TermEditR               _ = adminAccess Nothing
-isAuthorizedDB (TermEditExistR _)     _ = adminAccess Nothing
+isAuthorizedDB (TermEditExistR _)      _ = adminAccess Nothing
-isAuthorizedDB CourseNewR             _ = lecturerAccess Nothing
+isAuthorizedDB CourseNewR              _ = lecturerAccess Nothing
-isAuthorizedDB (CourseEditR t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseEditR t c)       _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (SheetListR  t c)  False = return Authorized --
+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 (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 (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 (SheetListR  t c)       _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (SheetNewR   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)
+isAuthorizedDB (SheetEditR  t c s)     _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (SheetDelR   t c s)    _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetDelR   t c s)     _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseEditIDR cID)    _ = do
+isAuthorizedDB (CourseEditIDR cID)     _ = do
   courseId <- decrypt cID
   courseLecturerAccess courseId
 isAuthorizedDB _route _isWrite = return  $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!

src/Handler/Course.hs

@@ -92,7 +92,14 @@ getCourseShowR tid csh = do
       return $ (courseEnt,dependent)
   let course = entityVal courseEnt  
   (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered      
-  defaultLayout $ do
+  let pageActions =
+        [ NavbarLeft $ MenuItem
+          { menuItemLabel = "Übungsblätter"
+          , menuItemRoute = SheetListR tid csh
+          , menuItemAccessCallback = (== Authorized) <$> isAuthorized (SheetListR tid csh) False
+          }
+        ]
+  defaultLinkLayout pageActions $ do
     setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
       

src/Handler/Sheet.hs

@@ -10,10 +10,11 @@
 module Handler.Sheet where
 
 import Import 
+import System.FilePath
+
 import Handler.Utils
 import Handler.Utils.Zip
 
-
 -- import Data.Time
 import qualified Data.Text as T
 -- import Data.Function ((&))
@@ -28,6 +29,8 @@ import qualified Database.Esqueleto as E
 
 import Network.Mime
 
+
+
 {-
   * Implement Handlers
   * Implement Breadcrumbs in Foundation 
@@ -130,7 +133,7 @@ getSheetList courseEnt = do
         rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
         return (sid, sheet, (submissions, rated))
   let colSheets = mconcat
-        [ headed "Blatt"       $ toWgt . sheetName . snd3
+        [ headed "Blatt"       $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ SheetShowR tid csh (sheetName sheet)
         , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
         , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
         , headed "Bewertung"   $ toWgt . show . sheetType . snd3
@@ -172,7 +175,7 @@ getSheetShowR tid csh shn = do
 
   defaultLayout $ do
     setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
-    $(widgetFile "sheetAdmin")
+    $(widgetFile "sheetList")
     [whamlet| Under Construction !!! |] -- TODO
 
 
@@ -207,7 +210,7 @@ getSheetNewR tid csh = do
   aid <- requireAuthId
   (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
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm cid template
   case res of
     (FormSuccess SheetForm{..}) -> do
       actTime <- liftIO getCurrentTime
@@ -233,32 +236,20 @@ getSheetNewR tid csh = do
         case insertOkay of
           Nothing    -> insertOkay <$ addMessageI "danger" (MsgSheetNewDup tident csh sfName)
           (Just sid) -> do
-            addMessageI "info" $ MsgSheetNewOk tident csh sfName
             -- Save Files in DB:
-            -- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
+            whenIsJust sfSheetF    $ insertSheetFile sid SheetExercise
-            whenIsJust sfSheetF $ \sinfo -> do
+            whenIsJust sfHintF     $ insertSheetFile sid SheetHint
-              let sheetInsert file = do
+            whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution
-                    fid <- insert file
+            addMessageI "info" $ MsgSheetNewOk tident csh sfName
-                    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
-            --
-            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 ()
+  let formTitle = "Neues Übungsblatt anlegen" :: Text
+  let actionUrl = SheetNewR tid csh
+  -- actionUrl <- getCurrentRoute
   defaultLayout $ do
-    $(widgetFile "newSheet")
+    $(widgetFile "formPage")
 
 postSheetNewR :: TermId -> Text -> Handler Html
 postSheetNewR = getSheetNewR
@@ -300,3 +291,16 @@ getCourseShowR tid csh = do
     setTitle $ [shamlet| #{termToText tid} - #{csh}|]
     $(widgetFile "course")
 -}    
+
+
+insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
+insertSheetFile sid ftype finfo = do
+    runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
+  where
+    finsert file = do
+      fid <- insert file
+      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+
+
+
+

templates/newSheet.hamlet

@@ -1,20 +0,0 @@
-<div .container>
-    <div .bs-docs-section>
-        <div .row>
-            <div .col-lg-12>
-                <div .page-header>
-                    <h1 #forms>Neuen Blatt anlegen:
-
-                    <p>
-                        Bitte alles ausfüllen!
-
-        <div .row>
-            <div .col-lg-6>
-                <div .bs-callout bs-callout-info well>
-                    <form .form-horizontal method=post #forms enctype=#{enc}>
-                        ^{wdgt}
-
-                        <button .btn.btn-primary type="submit">
-                            Blatt anlegen
-
-

templates/sheetList.hamlet

@@ -27,7 +27,12 @@
                 <h2>Dateien
                 <ul>
                   $forall fileLink <- fileLinks
-                    <li> <a href=@{fileLink}>@{fileLink}
+                    <li>
+                      $case fileLink
+                        $of SheetFileR _ _ _ typ name
+                          #{toPathPiece typ} <a href=@{fileLink}>#{name}
+                        $of other
+                          <a href=@{fileLink}>@{fileLink}
 
     <hr>