1544 lines
65 KiB
Haskell
1544 lines
65 KiB
Haskell
{-# 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|
|
|
<a href=@{MessageR cID}>
|
|
#{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
|