diff --git a/config/settings.yml b/config/settings.yml index 735afe776..51966ee5d 100644 --- a/config/settings.yml +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 483d452a0..34153e3b5 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index b2e514610..c8df3f941 100644 --- a/src/Handler/Home.hs +++ b/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" diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index bf51909af..085e94af9 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index d63b447b2..3d9baa11b 100644 --- a/src/Settings.hs +++ b/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 {..} diff --git a/src/Utils.hs b/src/Utils.hs index 4c3a4a0e6..6ad5aca4c 100644 --- a/src/Utils.hs +++ b/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 diff --git a/start.sh b/start.sh index dc2f16a96..f55acbcae 100755 --- a/start.sh +++ b/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