{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards, MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-} module Foundation where import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) import Yesod.Auth.Message import Yesod.Auth.Dummy import Auth.LDAP import Auth.PWHash import Auth.Dummy import Jobs.Types import qualified Network.Wai as W (requestMethod, pathInfo) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE import qualified Data.CryptoID as E import Data.ByteArray (convert) import Crypto.Hash (Digest, SHAKE256) import Crypto.Hash.Conduit (sinkHash) import qualified Data.ByteString.Base64.URL as Base64 (encode) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy.ByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.List (foldr1) import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map import Data.List (findIndex) import Data.Monoid (Any(..)) import Data.Pool import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Catch (handleAll) import qualified Control.Monad.Catch as C import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures import Control.Lens import Utils import Utils.Form import Utils.Lens import Utils.SystemMessage import Data.Aeson hiding (Error, Success) import Data.Aeson.TH import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) import Yesod.Form.I18n.German import qualified Yesod.Auth.Message as Auth import qualified Data.Conduit.List as C instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where display = toPathPiece instance DisplayAble TermId where display = termToText . unTermKey instance DisplayAble SchoolId where display = CI.original . unSchoolKey -- infixl 9 :$: -- pattern a :$: b = a b -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have -- access to the data present here. data UniWorX = UniWorX { appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool , appHttpManager :: Manager , appLogger :: Logger , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey , appInstanceID :: InstanceId , appJobCtl :: [TMChan JobCtl] } type SMTPPool = Pool SMTPConnection -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers -- -- Note that this is really half the story; in Application.hs, mkYesodDispatch -- generates the rest of the code. Please see the following documentation -- for an explanation for this split: -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules -- -- This function also generates the following type synonyms: -- type Handler x = HandlerT UniWorX IO x -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") -- | Convenient Type Synonyms: type DB a = YesodDB UniWorX a type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerT UniWorX IO) a -- Pattern Synonyms for convenience pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) , menuItemModal :: Bool } menuItemAccessCallback :: MenuItem -> Handler Bool menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) Authorized <$> authCheck) <*> menuItemAccessCallback' where authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized menuItemRoute False data MenuTypes -- Semantische Rolle: = NavbarAside { menuItem :: MenuItem } -- TODO | NavbarExtra { menuItem :: MenuItem } -- TODO | NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar | NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten (nicht im MouseOver enthalten, immer hinten gelistet) -- Messages mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage UniWorX FormMessage where renderMessage _ _ = germanFormMessage -- TODO instance RenderMessage UniWorX TermIdentifier where renderMessage foundation ls TermIdentifier{..} = case season of Summer -> renderMessage' $ MsgSummerTerm year Winter -> renderMessage' $ MsgWinterTerm year where renderMessage' = renderMessage foundation ls instance RenderMessage UniWorX StudyFieldType where renderMessage foundation ls = renderMessage foundation ls . \case FieldPrimary -> MsgFieldPrimary FieldSecondary -> MsgFieldSecondary newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving (Eq, Ord, Read, Show) instance RenderMessage UniWorX ShortTermIdentifier where renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of Summer -> renderMessage' $ MsgSummerTermShort year Winter -> renderMessage' $ MsgWinterTermShort year where renderMessage' = renderMessage foundation ls instance RenderMessage UniWorX String where renderMessage f ls str = renderMessage f ls $ Text.pack str instance RenderMessage UniWorX SheetFileType where renderMessage foundation ls = renderMessage foundation ls . \case SheetExercise -> MsgSheetExercise SheetHint -> MsgSheetHint SheetSolution -> MsgSheetSolution SheetMarking -> MsgSheetMarking instance RenderMessage UniWorX CorrectorState where renderMessage foundation ls = renderMessage foundation ls . \case CorrectorNormal -> MsgCorrectorNormal CorrectorMissing -> MsgCorrectorMissing CorrectorExcused -> MsgCorrectorExcused instance RenderMessage UniWorX Load where renderMessage foundation ls = renderMessage foundation ls . \case (Load {byTutorial=Nothing , byProportion=p}) -> MsgCorByProportionOnly p (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p instance RenderMessage UniWorX SheetType where renderMessage foundation ls = renderMessage foundation ls . \case Bonus{..} -> MsgSheetTypeBonus' maxPoints Normal{..} -> MsgSheetTypeNormal' maxPoints Pass{..} -> MsgSheetTypePass' maxPoints passingPoints NotGraded{} -> MsgSheetTypeNotGraded' newtype MsgLanguage = MsgLanguage Lang deriving (Eq, Ord, Show, Read) instance RenderMessage UniWorX MsgLanguage where renderMessage foundation ls (MsgLanguage lang) | lang == "de-DE" = mr MsgGermanGermany | "de" `isPrefixOf` lang = mr MsgGerman where mr = renderMessage foundation ls instance RenderMessage UniWorX NotificationTrigger where renderMessage foundation ls = renderMessage foundation ls . \case NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded NTSubmissionRated -> MsgNotificationTriggerSubmissionRated NTSheetActive -> MsgNotificationTriggerSheetActive NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive NTSheetInactive -> MsgNotificationTriggerSheetInactive NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) instance RenderMessage UniWorX MessageClass where renderMessage f ls = renderMessage f ls . \case Error -> MsgMessageError Warning -> MsgMessageWarning Info -> MsgMessageInfo Success -> MsgMessageSuccess data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink deriving (Enum, Eq, Ord, Bounded, Read, Show) instance Button UniWorX SubmitButton where label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] cssClass BtnSubmit = BCPrimary getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) appTZ :: TZ appTZ = $(includeSystemTZ "Europe/Berlin") appLanguages :: NonEmpty Lang appLanguages = "de-DE" :| [] appLanguagesOpts :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => m (OptionList Lang) -- ^ Authoritive list of supported Languages appLanguagesOpts = do mr <- getsYesod renderMessage let mkOption l = Option { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l) , optionInternalValue = l , optionExternalValue = l } langOptions = map mkOption $ toList appLanguages return $ mkOptionList langOptions -- Access Control data AccessPredicate = APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) | APHandler (Route UniWorX -> Bool -> Handler AuthResult) | APDB (Route UniWorX -> Bool -> DB AuthResult) orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR _ Authorized _ = Authorized orAR _ _ Authorized = Authorized orAR _ AuthenticationRequired _ = AuthenticationRequired orAR _ _ AuthenticationRequired = AuthenticationRequired orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y -- and andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y andAR _ reason@(Unauthorized x) _ = reason andAR _ _ reason@(Unauthorized x) = reason andAR _ Authorized other = other andAR _ AuthenticationRequired _ = AuthenticationRequired orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate orAP = liftAR orAR (== Authorized) andAP = liftAR andAR (const False) liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult) -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument -> AccessPredicate -> AccessPredicate -> AccessPredicate -- Ensure to first evaluate Pure conditions, then Handler before DB liftAR ops sc (APPure f) (APPure g) = APPure $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< ask liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer liftAR ops sc (APDB f) (APDB g) = APDB $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r w -> runReader (f r w) <$> getMsgRenderer) apg liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ \r w -> lift $ f r w) apdb liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb trueAP,falseAP :: AccessPredicate trueAP = APPure . const . const $ return Authorized falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) adminAP = APDB $ \route _ -> case route of -- Courses: access only to school admins CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId 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 (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) return Authorized -- other routes: access to any admin is granted here _other -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized) return Authorized knownTags :: Map (CI Text) AccessPredicate 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 allow <- appAllowDeprecated . appSettings <$> getYesod return $ bool (Unauthorized "Deprecated Route") Authorized allow ) ,("lecturer", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId 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 (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) return Authorized _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] return Authorized ) ,("corrector", APDB $ \route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId return (course E.^. CourseId, sheet E.^. SheetId) let resMap :: Map CourseId (Set SheetId) resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy return Authorized CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized ) ,("time", APDB $ \route _ -> case route of CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime let visible = NTop sheetVisibleFrom <= NTop (Just cTime) active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo guard visible case subRoute of SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SubmissionNewR -> guard active SubmissionR _ _ -> guard active _ -> return () return Authorized CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop courseRegisterFrom <= cTime && NTop courseRegisterTo >= cTime return Authorized MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID SystemMessage{..} <- MaybeT $ get smId cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime && NTop systemMessageTo >= cTime return Authorized r -> $unsupportedAuthPredicate "time" r ) ,("registered", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId 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 (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized r -> $unsupportedAuthPredicate "registered" r ) ,("capacity", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate "capacity" r ) ,("materials", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate "materials" r ) ,("owner", APDB $ \route _ -> case route of CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate "owner" r ) ,("rated", APDB $ \route _ -> case route of CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized r -> $unsupportedAuthPredicate "rated" r ) ,("user-submissions", APDB $ \route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn guard $ sheetSubmissionMode == UserSubmissions return Authorized r -> $unsupportedAuthPredicate "user-submissions" r ) ,("corrector-submissions", APDB $ \route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn guard $ sheetSubmissionMode == CorrectorSubmissions return Authorized r -> $unsupportedAuthPredicate "corrector-submissions" r ) ,("authentication", APDB $ \route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID SystemMessage{..} <- MaybeT $ get smId isAuthenticated <- isJust <$> liftHandlerT maybeAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized r -> $unsupportedAuthPredicate "authentication" r ) ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)) ] tag2ap :: Text -> AccessPredicate tag2ap t = case Map.lookup (CI.mk t) knownTags of (Just acp) -> acp Nothing -> APHandler $ \_route _isWrite -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should) $logWarnS "AccessControl" $ "'" <> t <> "' not known to access control" unauthorizedI MsgUnauthorized route2ap :: Route UniWorX -> AccessPredicate route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed) where attrsAND = map splitAND $ Set.toList $ routeAttrs r splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer (APHandler p) -> lift $ p r w (APDB p) -> p r w evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess r w = liftHandlerT $ case route2ap r of (APPure p) -> runReader (p r w) <$> getMsgRenderer (APHandler p) -> p r w (APDB p) -> runDB $ p r w -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod UniWorX where -- Controls the base of generated URLs. For more information on modifying, -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot approot = ApprootRequest $ \app req -> case appRoot $ appSettings app of Nothing -> getApprootText guessApproot app req Just root -> root -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 -- timeout in minutes "client_session_key.aes" maximumContentLength _ _ = Just $ 50 * 2^20 -- Yesod Middleware allows you to run code before and after each handler function. -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. -- Some users may also want to add the defaultCsrfMiddleware, which: -- a) Sets a cookie with a CSRF token in it. -- b) Validates that incoming write requests include that token in either a header or POST parameter. -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware where updateFavouritesMiddleware :: Handler a -> Handler a updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do route <- MaybeT getCurrentRoute case route of -- update Course Favourites here CourseR tid ssh csh _ -> do void . lift . runDB . runMaybeT $ do guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False $logDebugS "updateFavourites" "Updating favourites" now <- liftIO $ getCurrentTime uid <- MaybeT $ liftHandlerT maybeAuthId cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|] -- update Favourites void . lift $ upsertBy (UniqueCourseFavourite uid cid) courseFavourite [CourseFavouriteTime =. now] -- prune Favourites to user-defined size oldFavs <- lift $ selectKeysList [ CourseFavouriteUser ==. uid] [ Desc CourseFavouriteTime , OffsetBy $ userMaxFavourites user ] lift . forM_ oldFavs $ \fav -> do $logDebugS "updateFavourites" "Deleting old favourite." delete fav _other -> return () normalizeRouteMiddleware :: Handler a -> Handler a normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do route <- MaybeT getCurrentRoute (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers when changed $ do $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|] redirectWith movedPermanently301 route' defaultLayout widget = do master <- getYesod let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master applySystemMessages mmsgs <- getMessages mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. (title, parents) <- breadcrumbs -- let isParent :: Route UniWorX -> Bool -- isParent r = r == (fst parents) let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu isAuth <- isJust <$> maybeAuthId -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! (favourites', currentTheme) <- do muid <- maybeAuthPair case muid of Nothing -> return ([],userDefaultTheme) (Just (uid,user)) -> do favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) E.orderBy [ E.asc $ course E.^. CourseShorthand ] return course return (favs, userTheme user) favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs in \r -> Just r == highR favouriteTerms :: [TermIdentifier] favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])] favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and -- default-layout-wrapper is the entire page. Since the final -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. let navbar :: Widget navbar = $(widgetFile "widgets/navbar") asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav") contentHeadline :: Maybe Widget contentHeadline = pageHeading =<< mcurrentRoute breadcrumbs :: Widget breadcrumbs = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now -- functions to determine if there are page-actions (primary or secondary) isPageActionPrime :: MenuTypes -> Bool isPageActionPrime (PageActionPrime _) = True isPageActionPrime (PageActionSecondary _) = True isPageActionPrime _ = False hasPageActions :: Bool hasPageActions = any (isPageActionPrime . fst) menuTypes pc <- widgetToPageContent $ do addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" addScript $ StaticR js_zepto_js addScript $ StaticR js_fetchPolyfill_js addScript $ StaticR js_urlPolyfill_js addScript $ StaticR js_featureChecker_js addScript $ StaticR js_flatpickr_js addScript $ StaticR js_tabber_js addStylesheet $ StaticR css_flatpickr_css addStylesheet $ StaticR css_tabber_css addStylesheet $ StaticR css_fonts_css addStylesheet $ StaticR css_fontawesome_css $(widgetFile "default-layout") $(widgetFile "standalone/modal") $(widgetFile "standalone/showHide") $(widgetFile "standalone/inputs") $(widgetFile "standalone/tooltip") $(widgetFile "standalone/tabber") $(widgetFile "standalone/alerts") $(widgetFile "standalone/datepicker") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR isAuthorized = evalAccess -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content. addStaticContent ext mime content = do master <- getYesod let staticDir = appStaticDir $ appSettings master addStaticContentExternal minifym genFileName staticDir (StaticR . flip StaticRoute []) ext mime content where -- Generate a unique filename based on the content itself, this is used -- for deduplication so a collision resistant hash function is required -- -- SHA-3 (SHAKE256) seemed to be a future-proof choice -- -- Length of hash is 144 bits instead of MD5's 128, so as to avoid -- padding after base64-conversion genFileName lbs = Text.unpack . Text.decodeUtf8 . Base64.encode . (convert :: Digest (SHAKE256 144) -> ByteString) . runIdentity $ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. shouldLog _ _ _ = error "Must use shouldLogIO" shouldLogIO app _source level = do LogSettings{..} <- readTVarIO $ appLogSettings app return $ logAll || level >= logMinimumLevel makeLogger = return . appLogger applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do cID <- encrypt smId let sessionKey = "sm-" <> tshow (ciphertext cID) assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())) setSessionJson sessionKey () (SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId let (summary, content) = case smTrans of Nothing -> (systemMessageSummary, systemMessageContent) Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) case summary of Just s -> do html <- withUrlRenderer [hamlet| #{s} |] addMessage systemMessageSeverity html Nothing -> addMessage systemMessageSeverity content -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) breadcrumb HomeR = return ("Uni2work", Nothing) breadcrumb UsersR = return ("Benutzer", Just HomeR) breadcrumb AdminTestR = return ("Test" , Just HomeR) breadcrumb (AdminUserR _) = return ("Users" , Just UsersR) breadcrumb VersionR = return ("Impressum" , Just HomeR) breadcrumb ProfileR = return ("Profile" , Just HomeR) breadcrumb ProfileDataR = return ("Data" , Just ProfileR) breadcrumb TermShowR = return ("Semester" , Just HomeR) breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR) breadcrumb TermEditR = return ("Neu" , Just TermCurrentR) breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Nothing) breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) breadcrumb CourseListR = return ("Kurse" , Just HomeR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) -- (CourseR tid ssh csh CRegisterR) -- is POST only breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) -- (CSubmissionR tid ssh csh shn _ SubArchiveR) -- just for Download breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR) -- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR) -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) breadcrumb (MessageR _) = do mayList <- (== Authorized) <$> evalAccess MessageListR False return $ if | mayList -> ("Statusmeldung", Just MessageListR) | otherwise -> ("Statusmeldung", Just HomeR) breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR) breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseTerm E.==. E.val tid return $ submission E.^. SubmissionId defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. [ NavbarAside $ MenuItem { menuItemLabel = "Home" , menuItemIcon = Just "home" , menuItemRoute = HomeR , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Impressum" , menuItemIcon = Just "book" , menuItemRoute = VersionR , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Hilfe" , menuItemIcon = Just "question" , menuItemRoute = HelpR , menuItemModal = True -- TODO: Does not work yet, issue #212 , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Profil" , menuItemIcon = Just "cogs" , menuItemRoute = ProfileR , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemIcon = Just "sign-in-alt" , menuItemRoute = AuthR LoginR , menuItemModal = True -- TODO: Does not work yet, issue #212 , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemIcon = Just "sign-out-alt" , menuItemRoute = AuthR LogoutR , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem { menuItemLabel = "Kurse" , menuItemIcon = Just "calendar-alt" , menuItemRoute = CourseListR , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Semester" , menuItemIcon = Just "graduation-cap" , menuItemRoute = TermShowR , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Korrekturen" , menuItemIcon = Just "check" , menuItemRoute = CorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "users" , menuItemRoute = UsersR , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } ] pageActions :: Route UniWorX -> [MenuTypes] {- Icons: https://fontawesome.com/icons?d=gallery Guideline: use icons without boxes/frames, only non-pro Please keep sorted according to routes -} pageActions (HomeR) = [ -- NavbarAside $ MenuItem -- { menuItemLabel = "Benutzer" -- , menuItemIcon = Just "users" -- , menuItemRoute = UsersR -- , menuItemAccessCallback' = return True -- } -- , NavbarAside $ MenuItem { menuItemLabel = "AdminDemo" , menuItemIcon = Just "screwdriver" , menuItemRoute = AdminTestR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "System-Nachrichten" , menuItemIcon = Nothing , menuItemRoute = MessageListR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (ProfileR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Gespeicherte Daten anzeigen" , menuItemIcon = Just "book" , menuItemRoute = ProfileDataR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions TermShowR = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Semester anlegen" , menuItemIcon = Nothing , menuItemRoute = TermEditR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (TermCourseListR tid) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Semster editieren" , menuItemIcon = Nothing , menuItemRoute = TermEditExistR tid , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseR tid ssh csh CShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetListR , menuItemModal = False , menuItemAccessCallback' = do --TODO always show for lecturer let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False) muid <- maybeAuthId (sheets,lecturer) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] lecturer <- case muid of Nothing -> return False (Just uid) -> existsBy $ UniqueLecturer uid cid return (sheets,lecturer) or2M (return lecturer) $ anyM sheets sheetRouteAccess } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh CCorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Kurs editieren" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh CEditR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Neuen Kurs klonen" , menuItemIcon = Nothing , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh) , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseR tid ssh csh SheetListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid ssh csh shn SShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard $ null submissions return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgabe ansehen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard . not $ null submissions return True } , PageActionPrime $ MenuItem { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Blatt Editieren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid ssh csh shn SSubsR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrektur" , menuItemIcon = Nothing , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid ssh csh shn SCorrR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Edit " <> (CI.original shn) , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CorrectionsR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsUploadR , menuItemModal = True , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben erstellen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsCreateR , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions return E.countRows return $ (count :: Int) /= 0 } , PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen eintragen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsGradeR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CorrectionsGradeR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsUploadR , menuItemModal = True , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben erstellen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsCreateR , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions return E.countRows return $ (count :: Int) /= 0 } ] pageActions _ = [] i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg pageHeading :: Route UniWorX -> Maybe Widget pageHeading (AuthR _) = Just $ i18nHeading MsgLoginHeading pageHeading HomeR = Just $ i18nHeading MsgHomeHeading pageHeading UsersR = Just $ i18nHeading MsgUsers pageHeading (AdminTestR) = Just $ [whamlet|Internal Code Demonstration Page|] pageHeading (AdminUserR _) = Just $ [whamlet|User Display for Admin|] pageHeading (VersionR) = Just $ i18nHeading MsgImpressumHeading pageHeading (HelpR) = Just $ i18nHeading MsgHelpRequest pageHeading ProfileR = Just $ i18nHeading MsgProfileHeading pageHeading ProfileDataR = Just $ i18nHeading MsgProfileDataHeading pageHeading TermShowR = Just $ i18nHeading MsgTermsHeading pageHeading TermCurrentR = Just $ i18nHeading MsgTermCurrent pageHeading TermEditR = Just $ i18nHeading MsgTermEditHeading pageHeading (TermEditExistR tid) = Just $ i18nHeading $ MsgTermEditTid tid pageHeading (TermCourseListR tid) = Just . i18nHeading . MsgTermCourseListHeading $ tid pageHeading (TermSchoolCourseListR tid ssh) = Just $ do School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh i18nHeading $ MsgTermSchoolCourseListHeading tid school pageHeading (SchoolListR) = Just $ i18nHeading MsgSchoolListHeading pageHeading (SchoolShowR ssh) = Just $ do School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh i18nHeading $ MsgSchoolHeading school pageHeading (CourseListR) = Just $ i18nHeading $ MsgCourseListTitle pageHeading CourseNewR = Just $ i18nHeading MsgCourseNewHeading pageHeading (CourseR tid ssh csh CShowR) = Just $ do Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh toWidget courseName -- (CourseR tid csh CRegisterR) -- just for POST pageHeading (CourseR tid ssh csh CEditR) = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh pageHeading (CourseR tid ssh csh CCorrectionsR) = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh pageHeading (CourseR tid ssh csh SheetListR) = Just $ i18nHeading $ MsgSheetList tid ssh csh pageHeading (CourseR tid ssh csh SheetNewR) = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh pageHeading (CSheetR tid ssh csh shn SShowR) = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SEditR) = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SDelR) = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SSubsR) = Just $ i18nHeading $ MsgSubmissionsSheet shn pageHeading (CSheetR tid ssh csh shn SubmissionNewR) = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download pageHeading (CSheetR tid ssh csh shn SCorrR) = Just $ i18nHeading $ MsgCorrectorsHead shn -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload pageHeading CorrectionsCreateR = Just $ i18nHeading MsgCorrCreate pageHeading CorrectionsGradeR = Just $ i18nHeading MsgCorrGrade pageHeading (MessageR _) = Just $ i18nHeading MsgSystemMessageHeading pageHeading MessageListR = Just $ i18nHeading MsgSystemMessageListHeading -- TODO: add headings for more single course- and single term-pages pageHeading _ = Nothing routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] routeNormalizers = [ normalizeRender , ncSchool , ncCourse , ncSheet ] where normalizeRender route = route <$ do YesodRequest{..} <- liftHandlerT getRequest let original = (W.pathInfo reqWaiRequest, reqGetParams) rendered = renderRoute route if | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|] | otherwise -> do $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|] tell $ Any True maybeOrig f route = maybeT (return route) $ f route hasChanged a b | ((/=) `on` CI.original) a b = do $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] tell $ Any True | otherwise = return () ncSchool = maybeOrig $ \route -> do TermSchoolCourseListR tid ssh <- return route let schoolShort :: SchoolShorthand schoolShort = unSchoolKey ssh Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort (hasChanged `on` unSchoolKey)ssh ssh' return $ TermSchoolCourseListR tid ssh' ncCourse = maybeOrig $ \route -> do CourseR tid ssh csh subRoute <- return route Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh hasChanged csh courseShorthand (hasChanged `on` unSchoolKey) ssh courseSchool return $ CourseR tid courseSchool courseShorthand subRoute ncSheet = maybeOrig $ \route -> do CSheetR tid ssh csh shn subRoute <- return route Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn hasChanged shn sheetName return $ CSheetR tid ssh csh sheetName subRoute -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend runDB action = runSqlPool action =<< appConnPool <$> getYesod instance YesodPersistRunner UniWorX where getDBRunner = defaultGetDBRunner appConnPool instance YesodAuth UniWorX where type AuthId UniWorX = UserId -- Where to send a user after successful login loginDest _ = HomeR -- Where to send a user after logout logoutDest _ = HomeR -- Override the above two destinations when a Referer: header is present redirectToReferer _ = True loginHandler = do toParent <- getRouteToParent lift . defaultLayout $ do plugins <- getsYesod authPlugins $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) setTitleI MsgLoginTitle $(widgetFile "login") authenticate Creds{..} = runDB $ do let userIdent = CI.mk credsIdent uAuth = UniqueAuthentication userIdent isDummy = credsPlugin == "dummy" isPWHash = credsPlugin == "PWHash" excHandlers | isDummy || isPWHash = [ C.Handler $ \err -> do addMessage Error (toHtml $ tshow (err :: CampusUserException)) $logErrorS "LDAP" $ tshow err acceptExisting ] | otherwise = [ C.Handler $ \case CampusUserNoResult -> do $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent return . UserError $ IdentifierNotFound credsIdent CampusUserAmbiguous -> do $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent return . UserError $ IdentifierNotFound credsIdent err -> do $logErrorS "LDAP" $ tshow err return $ ServerError "LDAP lookup failed" ] acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth $logDebugS "auth" $ tshow Creds{..} AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings flip catches excHandlers $ case appLdapConf of Just ldapConf -> fmap (either id id) . runExceptT $ do ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData let userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData userEmail' = lookup (Attr "mail") ldapData userDisplayName' = lookup (Attr "displayName") ldapData userSurname' = lookup (Attr "sn") ldapData userAuthentication | isPWHash = error "PWHash should only work for users that are already known" | otherwise = AuthLDAP userEmail <- if | Just [bs] <- userEmail' , Right userEmail <- Text.decodeUtf8' bs -> return $ CI.mk userEmail | otherwise -> throwError $ ServerError "Could not retrieve user email" userDisplayName <- if | Just [bs] <- userDisplayName' , Right userDisplayName <- Text.decodeUtf8' bs -> return userDisplayName | otherwise -> throwError $ ServerError "Could not retrieve user name" userSurname <- if | Just [bs] <- userSurname' , Right userSurname <- Text.decodeUtf8' bs -> return userSurname | otherwise -> throwError $ ServerError "Could not retrieve user surname" userMatrikelnummer <- if | Just [bs] <- userMatrikelnummer' , Right userMatrikelnummer <- Text.decodeUtf8' bs -> return $ Just userMatrikelnummer | Nothing <- userMatrikelnummer' -> return Nothing | otherwise -> throwError $ ServerError "Could not decode user matriculation" let newUser = User { userMaxFavourites = userDefaultMaxFavourites , userTheme = userDefaultTheme , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userNotificationSettings = def , userMailLanguages = def , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer , UserDisplayName =. userDisplayName , UserSurname =. userSurname , UserEmail =. userEmail ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate let userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' userStudyFeatures' = do (k, v) <- ldapData guard $ k == Attr "dfnEduPersonFeaturesOfStudy" v' <- v Right str <- return $ Text.decodeUtf8' v' return str fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures lift $ deleteWhere [StudyFeaturesUser ==. userId] forM_ fs $ \StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing lift $ insertMany_ fs return $ Authenticated userId Nothing -> acceptExisting where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) authPlugins (appSettings -> AppSettings{..}) = catMaybes [ campusLogin <$> appLdapConf , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin ] authHttpManager = getHttpManager renderAuthMessage _ _ = Auth.germanMessage -- TODO instance YesodAuthPersist UniWorX -- Useful when writing code that is re-usable outside of the Handler context. -- An example is background jobs that send email. -- This can also be useful for writing code that works across multiple Yesod applications. instance HasHttpManager UniWorX where getHttpManager = appHttpManager unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger instance YesodMail UniWorX where defaultFromAddress = getsYesod $ appMailFrom . appSettings mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings mailVerp = getsYesod $ appMailVerp . appSettings mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do setMailObjectId setDateCurrent replaceMailHeader "Auto-Submitted" $ Just "auto-generated" ret <- mail setMailSmtpData return ret instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where type MonadCryptoKey m = CryptoIDKey cryptoIDKey f = getsYesod appCryptoIDKey >>= f -- Note: Some functionality previously present in the scaffolding has been -- moved to documentation in the Wiki. Following are some hopefully helpful -- links: -- -- https://github.com/yesodweb/yesod/wiki/Sending-email -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding