574 lines
24 KiB
Haskell
574 lines
24 KiB
Haskell
{-# 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
|