Übungsblätter not shown if none exists

config/settings.yml

@@ -19,6 +19,7 @@ should-log-all: "_env:LOG_ALL:false"
 # mutable-static: false
 # skip-combining: false
 auth-dummy-login: "_env:DUMMY_LOGIN:false"
+allow-deprecated: "_env:ALLOW_DEPRECATED:false"
 
 # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
 # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings

src/Foundation.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -225,12 +224,13 @@ adminAP = APDB $ \case
 
 
 knownTags :: Map (CI Text) AccessPredicate
-knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
+knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
   [("free", trueAP)
   ,("deprecated", APHandler $ \r -> do
       $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
       addMessageI "error" MsgDeprecatedRoute
-      return Authorized
+      allow <- appAllowDeprecated . appSettings <$> getYesod
+      return $ bool (Unauthorized "Deprecated Route") Authorized allow
     )
   ,("lecturer", APDB $ \case
       CourseR tid csh _ -> exceptT return return $ do
@@ -568,7 +568,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (TermCourseListR term)    = return (toPathPiece term, Just TermShowR)
   breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term)
   breadcrumb  CourseNewR               = return ("Neu", Just CourseListR)
-  breadcrumb (CourseR _ _ CEditR)         = return ("Editieren", Just CourseListR)
+  breadcrumb (CourseR tid csh CEditR)  = return ("Editieren", Just $ CourseR tid csh CShowR)
 
   breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
   breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu",    Just $ CourseR tid csh SheetListR)
@@ -580,26 +580,37 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
 
 
-  breadcrumb HomeR = return ("UniWorkY", Nothing)
-  breadcrumb (AuthR _) = return ("Login", Just HomeR)
-  breadcrumb ProfileR = return ("Profile", Just HomeR)
+  breadcrumb HomeR        = return ("UniWorkY", Nothing)
+  breadcrumb (AuthR _)    = return ("Login", Just HomeR)
+  breadcrumb ProfileR     = return ("Profile", Just HomeR)
   breadcrumb ProfileDataR = return ("Data", Just ProfileR)
   breadcrumb  _ = return ("home", Nothing)
 
 pageActions :: Route UniWorX -> [MenuTypes]
 pageActions (CourseR tid csh CShowR) =
   [ PageActionPrime $ MenuItem
-      { menuItemLabel = "Übungsblätter"
-      , menuItemIcon  = Nothing
-      , menuItemRoute = CourseR tid csh SheetListR
-      , menuItemAccessCallback' = return True
-      }
-  , PageActionPrime $ MenuItem
       { menuItemLabel = "Kurs Editieren"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid csh CEditR
       , menuItemAccessCallback' = return True
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Übungsblätter"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh SheetListR
+      , menuItemAccessCallback' = do --TODO always show for lecturer
+          let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False)
+          sheets <-runDB $ do
+            cid <- getKeyBy404 $ CourseTermShort tid csh
+            map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
+          anyM sheets sheetRouteAccess
+      }
+  , PageActionSecondary $ MenuItem
+      { menuItemLabel = "Neues Übungsblatt anlegen"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh SheetNewR
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CourseR tid csh SheetListR) =
   [ PageActionPrime $ MenuItem
@@ -617,7 +628,7 @@ pageActions (CSheetR tid csh shn SShowR) =
       , menuItemAccessCallback' = return True -- TODO: check that no submission already exists
       }
   , PageActionPrime $ MenuItem
-      { menuItemLabel = "Abgabe"
+      { menuItemLabel = "Abgabe ansehen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSheetR tid csh shn SubmissionOwnR
       , menuItemAccessCallback' = return True -- TODO: check that a submission already exists

src/Handler/Home.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -15,6 +14,8 @@ module Handler.Home where
 import Import
 import Handler.Utils
 
+import qualified Data.Map as Map
+
 import Data.Time
 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3
@@ -80,7 +81,8 @@ homeAnonymous = do
   courseTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
-    , dbtSorting   =  [ ( "term"
+    , dbtSorting   = Map.fromList
+                      [ ( "term"
                         , SortColumn $ \(course) -> course E.^. CourseTerm
                         )
                       , ( "course"
@@ -147,7 +149,8 @@ homeUser uid = do
   sheetTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
-    , dbtSorting   =  [ ( "term"
+    , dbtSorting   = Map.fromList
+                      [ ( "term"
                         , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseTerm
                         )
                       , ( "course"

src/Handler/Sheet.hs

@@ -159,7 +159,7 @@ getSheetList courseEnt = do
   let colBase = mconcat
         [ headed "Blatt"       $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
         , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
-        , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
+        , headed "Abgabe lbis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
         , headed "Bewertung"   $ toWgt . display . sheetType . snd3
         ]
   let colAdmin = mconcat -- only show edit button for allowed course assistants
@@ -177,7 +177,7 @@ getSheetList courseEnt = do
         then colBase `mappend` colAdmin
         else colBase
   defaultLayout $ do
-    setTitle $ toHtml $ T.append "Übungsblätter " csh
+    setTitle $ toHtml $ csh <> " Übungsblätter"
     if null sheets
       then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
       else encodeWidgetTable tableDefault colSheets sheets

src/Settings.hs

@@ -71,6 +71,8 @@ data AppSettings = AppSettings
 
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
+    , appAllowDeprecated        :: Bool
+    -- ^ Indicate if deprecated routes are accessible for everyone
     }
 
 instance FromJSON AppSettings where
@@ -104,6 +106,7 @@ instance FromJSON AppSettings where
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
 
         appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= defaultDev
+        appAllowDeprecated        <- o .:? "allow-deprecated"      .!= defaultDev
 
         return AppSettings {..}
 

src/Utils.hs

@@ -13,6 +13,7 @@ module Utils
 import ClassyPrelude.Yesod
 
 import Data.List (foldl)
+import Data.Foldable as Fold
 import qualified Data.Char as Char
 
 import Utils.DB as Utils
@@ -207,3 +208,35 @@ shortCircuitM sc mx my op = do
   case sc x of
     True  -> return x
     False -> op <$> pure x <*> my
+
+
+-- Some Utility Functions from Agda.Utils.Monad
+-- | Monadic if-then-else.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM c m m' =
+    do  b <- c
+        if b then m else m'
+
+-- | @ifNotM mc = ifM (not <$> mc)@
+ifNotM :: Monad m => m Bool -> m a -> m a -> m a
+ifNotM c = flip $ ifM c
+
+-- | Lazy monadic conjunction.
+and2M :: Monad m => m Bool -> m Bool -> m Bool
+and2M ma mb = ifM ma mb (return False)
+
+andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM = Fold.foldr and2M (return True)
+
+allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM xs f = andM $ fmap f xs
+
+-- | Lazy monadic disjunction.
+or2M :: Monad m => m Bool -> m Bool -> m Bool
+or2M ma mb = ifM ma (return True) mb
+
+orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+orM = Fold.foldr or2M (return False)
+
+anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+anyM xs f = orM $ fmap f xs

start.sh

@@ -4,5 +4,6 @@ unset HOST
 export DETAILED_LOGGING=true
 export LOG_ALL=true
 export DUMMY_LOGIN=true
+export ALLOW_DEPRECATED=true
 
 exec -- stack exec -- yesod devel