{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Foundation where import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) -- Used only when in "auth-dummy-login" setting is enabled. import Yesod.Auth.Message import Yesod.Auth.Dummy import Yesod.Auth.LDAP import LDAP.Data (LDAPScope(..)) import LDAP.Search (LDAPEntry(..)) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE 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.Conduit (($$)) import Data.Conduit.List (sourceList) import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures -- 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. , appHttpManager :: Manager , appLogger :: Logger , appCryptoIDKey :: CryptoIDKey } -- 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 = HandlerT UniWorX IO -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") -- Pattern Synonyms for convenience pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn) data MenuItem = MenuItem { menuItemLabel :: Text , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback :: Handler Bool } 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 -- | Convenient Type Synonyms: type DB a = YesodDB UniWorX a type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) mkMessage "UniWorX" "messages" "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 _ _ = defaultFormMessage 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 -- 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" -- 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 handler = do res <- defaultYesodMiddleware handler void . runMaybeT $ do route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute case route of CourseR tid csh _ | "updateFavourite" `elem` attrs -> do uid <- MaybeT maybeAuthId now <- liftIO $ getCurrentTime void . lift . runDB . runMaybeT $ do cid <- MaybeT . getKeyBy $ CourseTermShort tid csh user <- MaybeT $ get uid -- update Favorites lift $ upsertBy (UniqueCourseFavourite uid cid) (CourseFavourite uid now cid) [CourseFavouriteTime =. now] -- prune Favorites to user-defined size oldFavs <- lift $ selectKeysList [ CourseFavouriteUser ==. uid] [ Desc CourseFavouriteTime , OffsetBy $ userMaxFavourites user ] lift $ mapM delete oldFavs _other -> return () return res defaultLayout = defaultLinkLayout [] -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR isAuthorized (AuthR _) _ = return Authorized isAuthorized HomeR _ = return Authorized isAuthorized FaviconR _ = return Authorized isAuthorized RobotsR _ = return Authorized isAuthorized (StaticR _) _ = return Authorized isAuthorized ProfileR _ = isAuthenticated isAuthorized TermShowR _ = return Authorized isAuthorized CourseListR _ = return Authorized isAuthorized (CourseListTermR _) _ = return Authorized isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized isAuthorized SubmissionListR _ = isAuthenticated isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated -- isAuthorized TestR _ = return Authorized isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite -- 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 app _source level = appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError makeLogger = return . appLogger isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult isAuthorizedDB route@(routeAttrs -> attrs) writeable | "adminAny" `member` attrs = adminAccess Nothing | "lecturerAny" `member` attrs = lecturerAccess Nothing isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseNewR _ = lecturerAccess Nothing isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseEditIDR cID) _ = do courseId <- decrypt cID courseLecturerAccess courseId isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult submissionAccess cID = do authId <- lift requireAuthId submissionId <- either decrypt decrypt cID Submission{..} <- get404 submissionId submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] [] let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy return $ case auth of True -> Authorized False -> Unauthorized "No access to this submission" adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdminSchool' -> YesodDB UniWorX AuthResult adminAccess school = do authId <- lift requireAuthId adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] return $ if (not $ null adrights) then Authorized else Unauthorized "No admin access" -- TODO internationalize lecturerAccess :: Maybe SchoolId -> YesodDB UniWorX AuthResult lecturerAccess school = do authId <- lift requireAuthId lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) [] return $ if (not $ null lecrights) then Authorized else Unauthorized "No lecturer access" -- TODO internationalize lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant 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 access <- getBy $ authType authId courseId case access of (Just _) -> return Authorized Nothing -> unauthorizedI msg isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite isAuthorized' :: Route UniWorX -> Bool -> Handler Bool isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb TermShowR = return ("Semester", Just HomeR) breadcrumb TermEditR = return ("Neu", Just TermShowR) breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb CourseListR = return ("Kurs", Just HomeR) breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) breadcrumb CourseNewR = return ("Neu", Just CourseListR) breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR) breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR) breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) breadcrumb HomeR = return ("ReWorX", Nothing) breadcrumb (AuthR _) = return ("Login", Just HomeR) breadcrumb ProfileR = return ("Profile", Just HomeR) breadcrumb _ = return ("home", Nothing) defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. [ NavbarRight $ MenuItem { menuItemLabel = "Home" , menuItemIcon = Just "home" , menuItemRoute = HomeR , menuItemAccessCallback = return True } , NavbarRight $ MenuItem { menuItemLabel = "Profile" , menuItemIcon = Just "profile" , menuItemRoute = ProfileR , menuItemAccessCallback = isJust <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemIcon = Just "login" , menuItemRoute = AuthR LoginR , menuItemAccessCallback = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemIcon = Just "logout" , menuItemRoute = AuthR LogoutR , menuItemAccessCallback = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem { menuItemLabel = "Aktuelle Veranstaltungen" , menuItemIcon = Just "book" , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future , menuItemAccessCallback = return True } , NavbarAside $ MenuItem { menuItemLabel = "Alte Veranstaltungen" , menuItemIcon = Just "book" , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future , menuItemAccessCallback = return True } , NavbarAside $ MenuItem { menuItemLabel = "Veranstaltungen" , menuItemIcon = Just "book" , menuItemRoute = CourseListR , menuItemAccessCallback = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "user" , menuItemRoute = UsersR , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } ] defaultLinkLayout :: [MenuTypes] -> Widget -> Handler Html defaultLinkLayout = defaultMenuLayout . (defaultLinks ++) defaultMenuLayout :: [MenuTypes] -> Widget -> Handler Html defaultMenuLayout menu widget = do master <- getYesod mmsgs <- getMessages mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. (title, parents) <- breadcrumbs menuTypes <- filterM (menuItemAccessCallback . menuItem) menu -- 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") breadcrumbs :: Widget breadcrumbs = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget pageactionprime = $(widgetFile "widgets/pageactionprime") -- functions to determine if there are page-actions isPageActionPrime :: MenuTypes -> Bool isPageActionPrime (PageActionPrime _) = True isPageActionPrime _ = False hasPageActions :: Bool hasPageActions = any isPageActionPrime menuTypes pc <- widgetToPageContent $ do addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" addScript $ StaticR js_featureChecker_js addScript $ StaticR js_fetchPolyfill_js addScript $ StaticR js_urlPolyfill_js addStylesheet $ StaticR css_fonts_css addStylesheet $ StaticR css_icons_css $(widgetFile "default-layout") $(widgetFile "standalone/modal") $(widgetFile "standalone/showHide") $(widgetFile "standalone/inputs") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") -- 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 authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do let (userPlugin, userIdent) | isDummy , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent = (dummyPlugin, dummyIdent) | otherwise = (credsPlugin, credsIdent) isDummy = credsPlugin == "dummy" uAuth = UniqueAuthentication userPlugin userIdent $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) when isDummy . (throwError =<<) . lift $ maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth let userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra userEmail' = lookup "mail" credsExtra userDisplayName' = lookup "displayName" credsExtra userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail' userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' let userMaxFavourites = 12 -- TODO: appDefaultFavourites appSettings newUser = User{..} userUpdate = [ UserMatrikelnummer =. userMatrikelnummer , UserDisplayName =. userDisplayName , UserEmail =. userEmail ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate let userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ] 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 where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) -- You can add other plugins like Google Email, email or OAuth here authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins -- Enable authDummy login if enabled. where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] authHttpManager = getHttpManager ldapConfig :: UniWorX -> LDAPConfig ldapConfig _app@(appSettings -> settings) = LDAPConfig { usernameFilter = \u -> principalName <> "=" <> u , identifierModifier , ldapUri = appLDAPURI settings , initDN = appLDAPDN settings , initPass = appLDAPPw settings , baseDN = appLDAPBaseName settings , ldapScope = LdapScopeSubtree } where principalName :: IsString a => a principalName = "userPrincipalName" identifierModifier _ entry = case lookup principalName $ leattrs entry of Just [n] -> Text.pack n _ -> error "Could not determine user principal name" -- | Access function to determine if a user is logged in. isAuthenticated :: Handler AuthResult isAuthenticated = do muid <- maybeAuthId return $ case muid of Nothing -> Unauthorized "You must login to access this page" Just _ -> Authorized 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 (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