{-# 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 #-} {-# LANGUAGE TupleSections #-} {-# 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 Data.CaseInsensitive (CI) 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 Yesod.Auth.Util.PasswordStore import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only 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.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) import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures import Control.Lens import Utils import Utils.Lens import Data.Aeson import Data.Aeson.TH import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) -- -- TODO: Move the following to the appropriate place, if DisplayAble is kept instance DisplayAble TermId where display = termToText . unTermKey instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where display = toPathPiece -- requires import of Data.CryptoID here -- -- MOVE ABOVE -- 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") -- | 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 -- Pattern Synonyms for convenience pattern CSheetR tid csh shn ptn = CourseR tid csh (SheetR shn ptn) pattern CSubmissionR tid csh shn cid ptn = CSheetR tid csh shn (SubmissionR cid ptn) -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) } 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 -- Messages 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 instance RenderMessage UniWorX String where renderMessage f ls str = renderMessage f ls $ Text.pack str instance RenderMessage UniWorX SheetFileType where renderMessage foundation ls = \case SheetExercise -> renderMessage' MsgSheetExercise SheetHint -> renderMessage' MsgSheetHint SheetSolution -> renderMessage' MsgSheetSolution SheetMarking -> renderMessage' MsgSheetMarking where renderMessage' = renderMessage foundation ls getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) appTZ :: TZ appTZ = $(includeSystemTZ "Europe/Berlin") -- 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 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.^. 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 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.^. 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 csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid 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 csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do Entity cid _ <- MaybeT . getBy $ CourseTermShort tid 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 let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime) case subRoute of SFileR SheetExercise _ -> guard started SFileR SheetMarking _ -> mzero -- only for correctors and lecturers SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo SubmissionR _ _ -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo _ -> guard started return Authorized CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop courseRegisterFrom <= cTime && NTop courseRegisterTo >= cTime return Authorized r -> do $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) ,("registered", APDB $ \route _ -> case route of CourseR tid 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.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized r -> do $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) ,("capacity", APDB $ \route _ -> case route of CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> do $logErrorS "AccessControl" $ "'!capacity' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) ,("materials", APDB $ \route _ -> case route of CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh guard courseMaterialFree return Authorized r -> do $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) ,("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 -> do $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) ,("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 -> do $logErrorS "AccessControl" $ "'!rated' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) ,("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 :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise evalAccessDB r w = case route2ap r of (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer (APHandler p) -> lift $ p r w (APDB p) -> p r w evalAccess :: Route UniWorX -> Bool -> Handler AuthResult evalAccess r w = 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 handler = do void . runMaybeT $ do route <- MaybeT getCurrentRoute guardM . lift $ (== Authorized) <$> isAuthorized route False case route of -- update Course Favourites here CourseR tid csh _ -> do uid <- MaybeT maybeAuthId $(logDebug) "Favourites save" now <- liftIO $ getCurrentTime void . lift . runDB . runMaybeT $ do cid <- MaybeT . getKeyBy $ CourseTermShort tid csh user <- MaybeT $ get uid -- update Favourites void . lift $ upsertBy (UniqueCourseFavourite uid cid) (CourseFavourite uid now cid) [CourseFavouriteTime =. now] -- prune Favourites to user-defined size oldFavs <- lift $ selectKeysList [ CourseFavouriteUser ==. uid] [ Desc CourseFavouriteTime , OffsetBy $ userMaxFavourites user ] lift $ mapM_ delete oldFavs _other -> return () defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately defaultLayout widget = do master <- getYesod 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 <- filterM (menuItemAccessCallback . menuItem) menu isAuth <- isJust <$> maybeAuthId -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! (favourites',show -> currentTheme) <- do muid <- maybeAuthPair case muid of Nothing -> return ([],Default) (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 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) 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") -- 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|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 app _source level = appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError makeLogger = return . appLogger -- 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 term) = return (display term, Just TermShowR) breadcrumb CourseListR = return ("Kurs" , Just HomeR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb (CourseR tid csh CShowR) = return (csh , Just $ TermCourseListR tid) -- (CourseR tid csh CRegisterR) -- is POST only breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",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) breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR) breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) -- (CSubmissionR tid csh shn _ SubArchiveR) -- just for Download breadcrumb (CSubmissionR tid csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid csh shn cid SubShowR) -- (CSubmissionR tid csh shn _ SubDownloadR) -- just for Download breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) -- (CSheetR tid csh shn SFileR) -- just for Downloads -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> Text -> Text -> 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 , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Impressum" , menuItemIcon = Just "book" , menuItemRoute = VersionR , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Profile" , menuItemIcon = Just "cogs" , menuItemRoute = ProfileR , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemIcon = Just "sign-in-alt" , menuItemRoute = AuthR LoginR , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemIcon = Just "sign-out-alt" , menuItemRoute = AuthR LogoutR , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem { menuItemLabel = "Kurse" , menuItemIcon = Just "calendar-alt" , menuItemRoute = TermCurrentR -- should be CourseListActiveR or similar in the future , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Semester" , menuItemIcon = Just "graduation-cap" , menuItemRoute = TermShowR , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Korrekturen" , menuItemIcon = Just "check" , menuItemRoute = CorrectionsR , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "users" , menuItemRoute = UsersR , 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 , menuItemAccessCallback' = return True } ] pageActions (ProfileR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Gespeicherte Daten anzeigen" , menuItemIcon = Just "book" , menuItemRoute = ProfileDataR , menuItemAccessCallback' = return True } ] pageActions TermShowR = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Semester anlegen" , menuItemIcon = Nothing , menuItemRoute = TermEditR , menuItemAccessCallback' = return True } ] pageActions (TermCourseListR tid) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Semster editieren" , menuItemIcon = Nothing , menuItemRoute = TermEditExistR tid , menuItemAccessCallback' = return True } ] pageActions (CourseR tid csh CShowR) = [ 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) muid <- maybeAuthId (sheets,lecturer) <- runDB $ do cid <- getKeyBy404 $ CourseTermShort tid 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 csh CCorrectionsR , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid csh SheetNewR , menuItemAccessCallback' = return True } ] pageActions (CourseR tid csh SheetListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid csh SheetNewR , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid csh shn SShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid csh shn SubmissionNewR , 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 csh shn SubmissionOwnR , 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 csh shn SCorrR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid csh shn SSubsR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Blatt Editieren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid csh shn SEditR , menuItemAccessCallback' = return True } ] pageActions (CSubmissionR tid csh shn cid SubShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrektur" , menuItemIcon = Nothing , menuItemRoute = CSubmissionR tid csh shn cid CorrectionR , menuItemAccessCallback' = do smid <- decrypt cid sm <- runDB $ get smid return $ maybe False submissionRatingDone sm } ] pageActions (CSheetR tid csh shn SCorrR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid csh shn SSubsR , menuItemAccessCallback' = return True } ] pageActions (CorrectionsR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsUploadR , menuItemAccessCallback' = return True } ] 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 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 -- CourseListR -- just a redirect to TermCurrentR pageHeading CourseNewR = Just $ i18nHeading MsgCourseNewHeading pageHeading (CourseR tid csh CShowR) = Just $ do Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh toWidget courseName -- (CourseR tid csh CRegisterR) -- just for POST pageHeading (CourseR tid csh CEditR) = Just $ i18nHeading $ MsgCourseEditHeading tid csh pageHeading (CourseR tid csh CCorrectionsR) = Just $ i18nHeading $ MsgSubmissionsCourse tid csh pageHeading (CourseR tid csh SheetListR) = Just $ i18nHeading $ MsgSheetList tid csh pageHeading (CourseR tid csh SheetNewR) = Just $ i18nHeading $ MsgSheetNewHeading tid csh pageHeading (CSheetR tid csh shn SShowR) = Just $ i18nHeading $ MsgSheetTitle tid csh shn pageHeading (CSheetR tid csh shn SEditR) = Just $ i18nHeading $ MsgSheetEditHead tid csh shn pageHeading (CSheetR tid csh shn SDelR) = Just $ i18nHeading $ MsgSheetDelHead tid csh shn pageHeading (CSheetR tid csh shn SSubsR) = Just $ i18nHeading $ MsgSubmissionsSheet shn pageHeading (CSheetR tid csh shn SubmissionNewR) = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn pageHeading (CSheetR tid csh shn SubmissionOwnR) = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one! = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download pageHeading (CSubmissionR tid csh shn cid CorrectionR) = Just $ i18nHeading $ MsgCorrectionHead tid csh shn cid -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download pageHeading (CSheetR tid csh shn SCorrR) = Just $ i18nHeading $ MsgCorrectorsHead shn -- (CSheetR tid csh shn SFileR) -- just for Downloads pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload -- TODO: add headings for more single course- and single term-pages pageHeading _ = Nothing -- 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 tp <- getRouteToParent lift . authLayout $ do master <- getYesod let authPlugins' = authPlugins master $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName authPlugins') forM_ authPlugins' $ flip apLogin tp 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" isPWFile = credsPlugin == "PWFile" uAuth = UniqueAuthentication userPlugin userIdent $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) when (isDummy || isPWFile) . (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' AppSettings{..} <- getsYesod appSettings let userMaxFavourites = appDefaultMaxFavourites userTheme = appDefaultTheme userDateTimeFormat = appDefaultDateTimeFormat userDateFormat = appDefaultDateFormat userTimeFormat = appDefaultTimeFormat 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] ++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app] authHttpManager = getHttpManager authPWFile :: FilePath -> AuthPlugin UniWorX authPWFile fp = AuthPlugin{..} where apName = "PWFile" apLogin = mempty apDispatch "GET" [] = do authData <- lookupBasicAuth pwdata <- liftIO $ Yaml.decodeFileEither fp addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] case pwdata of Left err -> $logDebugS "Auth" $ tshow err Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" case (authData, pwdata) of (Nothing, _) -> do notAuthenticated (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] <- [ pwe | pwe@PWEntry{..} <- pwdata' , let User{..} = pwUser , userIdent == usr , userPlugin == apName ] , verifyPassword pw pwHash -> lift $ do runDB . void $ insertUnique pwUser setCredsRedirect $ Creds apName userIdent [] _ -> permissionDenied "Invalid auth" apDispatch _ _ = notFound 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