From b6b6cf75bb5b174affc9bd1746b1cafacc790ed0 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 16 Jan 2019 15:58:52 +0100
Subject: [PATCH] Towards #272

---
 messages/uniworx/de.msg |  2 ++
 routes                  |  2 ++
 src/Foundation.hs       | 33 +++++++++++++++++++++++++++++++++
 src/Handler/Sheet.hs    | 36 ++++++++++++++++++++++++++++++++++++
 4 files changed, 73 insertions(+)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 5b6fac8cd..89842cada 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -565,6 +565,8 @@ MenuCorrections: Korrekturen
 MenuSubmissions: Abgaben
 MenuSheetList: Übungsblätter
 MenuSheetNew: Neues Übungsblatt anlegen
+MenuSheetCurrent: Akutelles Übungsblatt
+MenuSheetLastInactive: Zuletzt abgegebenes Übungsblatt
 MenuCourseEdit: Kurs editieren
 MenuCourseNewTemplate: Als neuen Kurs klonen
 MenuCourseDelete: Kurs löschen
diff --git a/routes b/routes
index f26d741f3..ca00b85ff 100644
--- a/routes
+++ b/routes
@@ -73,6 +73,8 @@
   /subs                       CCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials !corrector
   !/ex/new                    SheetNewR       GET POST
+  /ex-current                SheetCurrentR   GET             !free -- just a redirect
+  /ex-lastinactive           SheetLastInactiveR GET          !free -- just a redirect
   /ex/#SheetName SheetR:
     /                           SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
     /edit                       SEditR        GET POST
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 87a73f629..09a0869ff 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -689,6 +689,14 @@ evalAccess route isWrite = do
 evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
 evalAccessDB = evalAccess
 
+redirectAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> ReaderT (YesodPersistBackend UniWorX) m a
+redirectAccessDB url = do
+  -- must hide URL if not authorized
+  access <- evalAccessDB url False
+  case access of
+    Authorized -> redirect url
+    _          -> notFound -- permissionDeniedI maybe not always correct?
+
 
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
@@ -1221,6 +1229,31 @@ pageActions (CourseListR) =
   ]
 pageActions (CourseR tid ssh csh CShowR) =
   [ MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuSheetCurrent
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
+      , menuItemModal = False
+      , menuItemAccessCallback' = do
+          now <- liftIO getCurrentTime
+          [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet) -> do
+            E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
+            E.where_ $  sheet E.^. SheetActiveTo   E.>.  E.val now
+                 E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
+                 E.&&. course E.^. CourseTerm      E.==. E.val tid
+                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
+                 E.&&. course E.^. CourseShorthand E.==. E.val csh
+          return ok
+      }
+  , MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuSheetLastInactive
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR
+      , menuItemModal = False
+      , menuItemAccessCallback' = (== Authorized) <$> evalAccess (CourseR tid ssh csh CNotesR) False
+      }
+  , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuSheetList
       , menuItemIcon  = Nothing
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index ff5d712ac..86dbc9a03 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -139,6 +139,42 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
         , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo)   , render MsgSheetErrSolutionEarly)
       ] ]
 
+
+getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getSheetCurrentR tid ssh csh = runDB $ do
+  now <- liftIO getCurrentTime
+  sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+    E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
+    E.where_ $ sheet E.^. SheetActiveTo   E.>.  E.val now
+        E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
+        E.&&. course E.^. CourseTerm      E.==. E.val tid
+        E.&&. course E.^. CourseSchool    E.==. E.val ssh
+        E.&&. course E.^. CourseShorthand E.==. E.val csh
+    E.orderBy [E.asc $ sheet E.^. SheetActiveFrom]
+    E.limit 1
+    return $ sheet E.^. SheetName
+  case sheets of
+    (E.Value shn):_ -> redirectAccessDB $ CSheetR tid ssh csh shn SShowR
+    _ -> notFound
+
+getSheetLastInactiveR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getSheetLastInactiveR tid ssh csh = runDB $ do
+  -- TODO: deliver oldest sheet with unassigned submissions instead!!!
+  now <- liftIO getCurrentTime
+  sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+    E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
+    E.where_ $ sheet E.^. SheetActiveTo   E.<=. E.val now
+        E.&&. course E.^. CourseTerm      E.==. E.val tid
+        E.&&. course E.^. CourseSchool    E.==. E.val ssh
+        E.&&. course E.^. CourseShorthand E.==. E.val csh
+    E.orderBy [E.desc $ sheet E.^. SheetActiveTo]
+    E.limit 1
+    return $ sheet E.^. SheetName
+  case sheets of
+    (E.Value shn):_ -> redirectAccessDB $ CSheetR tid ssh csh shn SShowR
+    _ -> notFound
+
+
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetListR tid ssh csh = do
   muid <- maybeAuthId