DeleteRedirct, fetchSheet caching, etc.

FragenSJ.txt

@@ -1,4 +1,4 @@
-** Sicherheitsabfragen?`
+** Sicherheitsabfragen?
  - Verschlüsselung des Zugriffs?
 
  - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage
@@ -12,9 +12,7 @@
  - Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das?
   Kann man abfragen, was bei deleteCascade alles gelöscht wird?
 
- - Verständnis: Getrennte Handler get/post Handler in SheetEditR haben nicht funktioniert. Warum?
 
- - Sheets.redirectBack(): Wollen wir das wirklich? Schöner?
 
 ** i18n:
  - i18n der

models

@@ -103,11 +103,15 @@ Sheet
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
-    created         UTCTime
+    created         UTCTime  -- delete
-    changed         UTCTime
+    changed         UTCTime  -- delete
-    createdBy       UserId
+    createdBy       UserId   -- delete
-    changedBy       UserId    
+    changedBy       UserId   -- delete
     CourseSheet courseId name
+SheetEdit
+    sheet           SheetId
+    user            UserId
+    time            UTCTime
 SheetFile
     sheetId         SheetId
     fileId          FileId

routes

@@ -15,9 +15,20 @@
 /course/                    CourseListR       GET
 !/course/new                CourseNewR        GET POST
 !/course/#TermId            CourseListTermR   GET
+
+-- /course/#TermId/#Text CourseR !tag:
+--   /edit   CourseEditR GET POST
+--   /show   CourseShowR GET POST      -- CourseR tid csh CourseShowR
+--   /ex/#Text SheetR: !registered
+--     /show
+--     /edit                           -- CourseR tid csg (SheetR csh SheetEditR)
+--     /delete
+
 /course/#TermId/#Text/edit  CourseEditR       GET
 /course/#TermId/#Text/show  CourseShowR       GET POST
 
+
+
 /course/#TermId/#Text/ex/                SheetListR   GET
 /course/#TermId/#Text/ex/#Text/show      SheetShowR   GET
 /course/#TermId/#Text/ex/#Text/#SheetFileType/#FilePath SheetFileR  GET

src/Foundation.hs

@@ -232,7 +232,7 @@ adminAccess school = do
   adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) []  
   return $ if (not $ null adrights) 
     then Authorized
-    else Unauthorized "No admin access"
+    else Unauthorized "No admin access" -- TODO internationalize
 
 lecturerAccess :: Maybe SchoolId
                -> YesodDB UniWorX AuthResult
@@ -241,11 +241,10 @@ lecturerAccess school = do
   lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []
   return $ if (not $ null lecrights)
     then Authorized
-    else Unauthorized "No lecturer access"
+    else Unauthorized "No lecturer access" -- TODO internationalize
 
 lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult
 lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer
--- Continue here
 
 courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult
 courseLecturerAccess    = authorizedFor UniqueLecturer    MsgUnauthorizedLecturer
@@ -256,7 +255,10 @@ courseCorrectorAccess   = authorizedFor UniqueCorrector   MsgUnauthorizedCorrect
 courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult
 courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant
 
-authorizedFor :: (PersistEntityBackend record ~ BaseBackend backend, RenderMessage master msg, PersistEntity record, YesodAuth master, PersistUniqueRead backend)
+authorizedFor ::  ( PersistEntityBackend record ~ BaseBackend backend
+                  , PersistEntity record, PersistUniqueRead backend
+                  , YesodAuth master, RenderMessage master msg
+                  )
   => (AuthId master -> t -> Unique record) -> msg -> t -> ReaderT backend (HandlerT master IO) AuthResult
 authorizedFor authType msg courseId = do
   authId <- lift requireAuthId

src/Handler/Sheet.hs

@@ -27,6 +27,7 @@ import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E
 
 import Network.Mime
 
@@ -107,12 +108,35 @@ makeSheetForm template = identForm FIDsheet $ \html -> do
       ] ]
 
 
+fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
+                  , E.SqlSelect b a
+                  , Typeable a, MonadHandler m, IsPersistBackend backend
+                  , PersistQueryRead backend, PersistUniqueRead backend
+                  )
+  =>  (E.SqlExpr (Entity Sheet) -> b)
+      -> Key Term -> Text -> Text -> ReaderT backend m a
+fetchSheetAux prj tid csh shn =
+    let cachId = encodeUtf8 $ tshow (tid,csh,shn)
+    in  cachedBy cachId $ do
+    -- Mit Yesod:
+    -- cid <- getKeyBy404 $ CourseTermShort tid csh
+    -- getBy404 $ CourseSheet cid shn
+    -- Mit Esqueleto:
+        sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+            E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
+            E.where_ $ course E.^. CourseTermId    E.==. E.val tid
+                E.&&. course E.^. CourseShorthand E.==. E.val csh
+                E.&&. sheet  E.^. SheetName       E.==. E.val shn
+            return $ prj sheet
+        case sheetList of
+          [sheet] -> return sheet
+          _other  -> notFound
+
 fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
-fetchSheet tid csh shn = do
+fetchSheet = fetchSheetAux id
-    -- TODO: More efficient with Esquleto?
+
-    -- (Entity cid _course) <- getBy404 $ CourseTermShort tid csh
+fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
-    cid <- getKeyBy404 $ CourseTermShort tid csh
+fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
-    getBy404 $ CourseSheet cid shn
 
 -- List Sheets
 getSheetListCID :: CourseId -> Handler Html
@@ -150,7 +174,8 @@ getSheetList courseEnt = do
         , headed ""            $ \s -> linkButton "Delete" BCLink $ SheetDelR  tid csh $ sheetName $ snd3 s
         ]
   showAdmin <- case sheets of
-    ((_,firstSheet,_):_) ->
+    ((_,firstSheet,_):_) -> do
+      setUltDestCurrent
       (Authorized ==) <$> isAuthorized (SheetEditR tid csh $ sheetName firstSheet) False
     _otherwise   -> return False
   let colSheets = if showAdmin
@@ -252,8 +277,7 @@ getSheetEditR tid csh shn = do
         }
   let action newSheet = do
         replaceRes <- myReplaceUnique sid $ newSheet
-                        { sheetCourseId  = sheetCourseId
+                        { sheetCreated   = sheetCreated
-                        , sheetCreated   = sheetCreated
                         , sheetCreatedBy = sheetChangedBy }
         case replaceRes of
           Nothing     -> return $ Just sid
@@ -286,7 +310,7 @@ handleSheetEdit tid csh template dbAction = do
               , sheetActiveTo     = sfActiveTo
               , sheetHintFrom     = sfHintFrom
               , sheetSolutionFrom = sfSolutionFrom
-              , sheetCreated      = actTime  -- dbAction adjusts this for replacement
+              , sheetCreated      = actTime  -- dbAction adjusts this for replacement, TODO: eigene Tabelle für changedBy
               , sheetChanged      = actTime
               , sheetCreatedBy    = aid      -- dbAction adjusts this for replacement
               , sheetChangedBy    = aid
@@ -317,21 +341,17 @@ handleSheetEdit tid csh template dbAction = do
 getSheetDelR :: TermId -> Text -> Text -> Handler Html
 getSheetDelR tid csh shn = do
   let tident = unTermKey tid
-  ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete )
+  ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
   case result of
-    (FormSuccess BtnAbort)  -> redirectBack
+    (FormSuccess BtnAbort)  -> redirectUltDest $ SheetShowR tid csh shn
     (FormSuccess BtnDelete) -> do
-      runDB $ do
+      runDB $ fetchSheetId tid csh shn >>= deleteCascade
-        -- (Entity cid _course) <- getBy404 $ CourseTermShort tid csh
+      -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
-        cid <- getKeyBy404 $ CourseTermShort tid csh
-        sid <- getKeyBy404 $ CourseSheet cid shn
-        -- deleteBy $ CourseSheet cid shn
-        deleteCascade sid
       setMessageI $ MsgSheetDelOk tident csh shn
       redirect $ SheetListR tid csh
     _other -> do
       submissionno <- runDB $ do
-          Entity { entityKey = sid } <- fetchSheet tid csh shn
+          sid <- fetchSheetId tid csh shn
           count [SubmissionSheetId ==. sid]
       let formTitle = MsgSheetDelTitle tident csh shn
       let formText  = Just $ MsgSheetDelText submissionno
@@ -343,6 +363,8 @@ getSheetDelR tid csh shn = do
 postSheetDelR :: TermId -> Text -> Text -> Handler Html
 postSheetDelR = getSheetDelR
 
+
+
 insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
 insertSheetFile sid ftype finfo = do
     runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
@@ -351,12 +373,3 @@ insertSheetFile sid ftype finfo = 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
 
-
--- TODO: Move below to utils, did not work somehow
-redirectBack :: Handler Html
--- -- redirectBack :: HandlerT UniWorX IO Html
-redirectBack = defaultLayout $ do
-   toWidget [julius| window.history.go(-2); |]
-   [whamlet| BACK |] -- TODO
-
-