2885 lines
129 KiB
Haskell
2885 lines
129 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
|
|
|
|
module Foundation where
|
|
|
|
import Import.NoFoundation hiding (embedFile)
|
|
import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager)
|
|
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
|
import Text.Hamlet (hamletFile)
|
|
|
|
import qualified Web.ClientSession as ClientSession
|
|
|
|
import Yesod.Auth.Message
|
|
import Auth.LDAP
|
|
import Auth.PWHash
|
|
import Auth.Dummy
|
|
import Jobs.Types
|
|
|
|
import qualified Network.Wai as W (pathInfo)
|
|
|
|
import Yesod.Core.Types (Logger)
|
|
import qualified Yesod.Core.Unsafe as Unsafe
|
|
import Data.CaseInsensitive (original, mk)
|
|
|
|
import Data.ByteArray (convert)
|
|
import Crypto.Hash (Digest, SHAKE256, SHAKE128)
|
|
import Crypto.Hash.Conduit (sinkHash)
|
|
import qualified Data.UUID as UUID
|
|
import qualified Data.Binary as Binary
|
|
|
|
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.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map, (!?))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
import Data.List (nubBy, (!!), 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(..), ExceptT, runExceptT)
|
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
|
import Control.Monad.Trans.Reader (runReader, mapReaderT)
|
|
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
|
|
import Control.Monad.Writer.Class (MonadWriter(..))
|
|
import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
|
import qualified Control.Monad.Catch as C
|
|
|
|
import Handler.Utils.StudyFeatures
|
|
import Utils.Lens
|
|
import Utils.Form
|
|
import Utils.Sheet
|
|
import Utils.SystemMessage
|
|
|
|
import Text.Shakespeare.Text (st)
|
|
|
|
import Yesod.Form.I18n.German
|
|
import qualified Yesod.Auth.Message as Auth
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
|
import qualified Jose.Jwk as Jose
|
|
|
|
import qualified Database.Memcached.Binary.IO as Memcached
|
|
import Data.Bits (Bits(zeroBits))
|
|
|
|
import Network.Wai.Parse (lbsBackEnd)
|
|
|
|
import qualified Data.Aeson as JSON
|
|
|
|
import Data.FileEmbed (embedFile)
|
|
|
|
|
|
type SMTPPool = Pool SMTPConnection
|
|
|
|
-- 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 :: EmbeddedStatic -- ^ Settings for static file serving.
|
|
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
|
, appSmtpPool :: Maybe SMTPPool
|
|
, appLdapPool :: Maybe LdapPool
|
|
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
|
|
, appHttpManager :: Manager
|
|
, appLogger :: (ReleaseKey, TVar Logger)
|
|
, appLogSettings :: TVar LogSettings
|
|
, appCryptoIDKey :: CryptoIDKey
|
|
, appClusterID :: ClusterId
|
|
, appInstanceID :: InstanceId
|
|
, appJobCtl :: TVar (Map ThreadId (TMChan JobCtl))
|
|
, appCronThread :: TMVar (ReleaseKey, ThreadId)
|
|
, appSessionKey :: ClientSession.Key
|
|
, appSecretBoxKey :: SecretBox.Key
|
|
, appJSONWebKeySet :: Jose.JwkSet
|
|
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
|
|
}
|
|
|
|
makeLenses_ ''UniWorX
|
|
instance HasInstanceID UniWorX InstanceId where
|
|
instanceID = _appInstanceID
|
|
instance HasJSONWebKeySet UniWorX Jose.JwkSet where
|
|
jsonWebKeySet = _appJSONWebKeySet
|
|
instance HasHttpManager UniWorX Manager where
|
|
httpManager = _appHttpManager
|
|
instance HasAppSettings UniWorX where
|
|
appSettings = _appSettings'
|
|
|
|
-- 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")
|
|
|
|
deriving instance Generic CourseR
|
|
deriving instance Generic SheetR
|
|
deriving instance Generic SubmissionR
|
|
deriving instance Generic MaterialR
|
|
deriving instance Generic TutorialR
|
|
deriving instance Generic ExamR
|
|
deriving instance Generic (Route UniWorX)
|
|
|
|
-- | Convenient Type Synonyms:
|
|
type DB = YesodDB UniWorX
|
|
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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX
|
|
pattern CSheetR tid ssh csh shn ptn
|
|
= CourseR tid ssh csh (SheetR shn ptn)
|
|
|
|
pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX
|
|
pattern CMaterialR tid ssh csh mnm ptn
|
|
= CourseR tid ssh csh (MaterialR mnm ptn)
|
|
|
|
pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX
|
|
pattern CTutorialR tid ssh csh tnm ptn
|
|
= CourseR tid ssh csh (TutorialR tnm ptn)
|
|
|
|
pattern CExamR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamR -> Route UniWorX
|
|
pattern CExamR tid ssh csh tnm ptn
|
|
= CourseR tid ssh csh (ExamR tnm ptn)
|
|
|
|
pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX
|
|
pattern CSubmissionR tid ssh csh shn cid ptn
|
|
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
|
|
|
|
|
pluralDE :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
pluralDE num singularForm pluralForm
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
noneOneMoreDE :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ None
|
|
-> Text -- ^ Singular
|
|
-> Text -- ^ Plural
|
|
-> Text
|
|
noneOneMoreDE num noneText singularForm pluralForm
|
|
| num == 0 = noneText
|
|
| num == 1 = singularForm
|
|
| otherwise = pluralForm
|
|
|
|
noneMoreDE :: (Eq a, Num a)
|
|
=> a -- ^ Count
|
|
-> Text -- ^ None
|
|
-> Text -- ^ Some
|
|
-> Text
|
|
noneMoreDE num noneText someText
|
|
| num == 0 = noneText
|
|
| otherwise = someText
|
|
|
|
-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
|
|
type IntMaybe = Maybe Int
|
|
type TextList = [Text]
|
|
|
|
-- | Convenience function for i18n messages definitions
|
|
maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
|
|
maybeToMessage _ Nothing _ = mempty
|
|
maybeToMessage before (Just x) after = before <> (toMessage x) <> after
|
|
|
|
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
|
|
mkMessage "UniWorX" "messages/uniworx" "de"
|
|
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
|
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
|
|
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
|
|
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
|
|
mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "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
|
|
|
|
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
|
|
|
|
-- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
|
|
instance RenderMessage UniWorX Int where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
instance RenderMessage UniWorX Int64 where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
instance RenderMessage UniWorX Integer where
|
|
renderMessage f ls = renderMessage f ls . tshow
|
|
|
|
instance HasResolution a => RenderMessage UniWorX (Fixed a) where
|
|
renderMessage f ls = renderMessage f ls . showFixed True
|
|
|
|
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
|
|
|
|
newtype MsgLanguage = MsgLanguage Lang
|
|
deriving (Eq, Ord, Show, Read)
|
|
instance RenderMessage UniWorX MsgLanguage where
|
|
renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang'))
|
|
| ["de", "DE"] <- lang' = mr MsgGermanGermany
|
|
| ("de" : _) <- lang' = mr MsgGerman
|
|
| otherwise = lang
|
|
where
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
|
|
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
|
|
|
|
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
|
|
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
|
|
embedRenderMessage ''UniWorX ''StudyFieldType id
|
|
embedRenderMessage ''UniWorX ''SheetFileType id
|
|
embedRenderMessage ''UniWorX ''CorrectorState id
|
|
embedRenderMessage ''UniWorX ''RatingException id
|
|
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
|
|
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
|
|
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
|
|
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
|
|
embedRenderMessage ''UniWorX ''LecturerType id
|
|
embedRenderMessage ''UniWorX ''SubmissionModeDescr
|
|
$ let verbMap [_, _, "None"] = "NoSubmissions"
|
|
verbMap [_, _, v] = v <> "Submissions"
|
|
verbMap _ = error "Invalid number of verbs"
|
|
in verbMap . splitCamel
|
|
embedRenderMessage ''UniWorX ''UploadModeDescr id
|
|
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
|
|
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
|
|
|
|
|
|
newtype SheetTypeHeader = SheetTypeHeader SheetType
|
|
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
|
|
|
|
instance RenderMessage UniWorX SheetType where
|
|
renderMessage foundation ls sheetType = case sheetType of
|
|
NotGraded -> mr $ SheetTypeHeader NotGraded
|
|
other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX StudyDegree where
|
|
renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
|
|
|
|
newtype ShortStudyDegree = ShortStudyDegree StudyDegree
|
|
|
|
instance RenderMessage UniWorX ShortStudyDegree where
|
|
renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
|
|
|
|
instance RenderMessage UniWorX StudyTerms where
|
|
renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
|
|
|
|
newtype ShortStudyTerms = ShortStudyTerms StudyTerms
|
|
|
|
instance RenderMessage UniWorX ShortStudyTerms where
|
|
renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
|
|
|
|
data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
|
|
|
|
instance RenderMessage UniWorX StudyDegreeTerm where
|
|
renderMessage foundation ls (StudyDegreeTerm deg trm) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ")"
|
|
where
|
|
mr :: RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage foundation ls
|
|
|
|
instance RenderMessage UniWorX ExamGrade where
|
|
renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
|
|
|
|
|
|
-- ToMessage instances for converting raw numbers to Text (no internationalization)
|
|
|
|
instance ToMessage Int where
|
|
toMessage = tshow
|
|
instance ToMessage Int64 where
|
|
toMessage = tshow
|
|
instance ToMessage Integer where
|
|
toMessage = tshow
|
|
|
|
instance HasResolution a => ToMessage (Fixed a) where
|
|
toMessage = toMessage . showFixed True
|
|
|
|
-- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
|
|
-- instance ToMessage Rational where
|
|
-- toMessage = toMessage . fromRational'
|
|
-- where fromRational' = fromRational :: Rational -> Fixed E3
|
|
|
|
|
|
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
|
|
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
|
|
|
|
newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
|
|
deriving (Generic, Typeable)
|
|
deriving newtype (Semigroup, Monoid, IsList)
|
|
|
|
instance RenderMessage UniWorX UniWorXMessages where
|
|
renderMessage foundation ls (UniWorXMessages msgs) =
|
|
intercalate " " $ map (renderMessage foundation ls) msgs
|
|
|
|
uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
|
|
uniworxMessages = UniWorXMessages . map SomeMessage
|
|
|
|
-- Menus and Favourites
|
|
data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary | Footer
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
instance Universe MenuType
|
|
instance Finite MenuType
|
|
|
|
makePrisms ''MenuType
|
|
|
|
data MenuItem = MenuItem
|
|
{ menuItemLabel :: UniWorXMessage
|
|
, menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery
|
|
, menuItemRoute :: SomeRoute UniWorX
|
|
, menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
|
|
, menuItemModal :: Bool
|
|
, menuItemType :: MenuType
|
|
}
|
|
|
|
makeLenses_ ''MenuItem
|
|
|
|
instance RedirectUrl UniWorX MenuItem where
|
|
toTextUrl MenuItem{..} = toTextUrl menuItemRoute
|
|
instance HasRoute UniWorX MenuItem where
|
|
urlRoute MenuItem{..} = urlRoute menuItemRoute
|
|
|
|
menuItemAccessCallback :: MenuItem -> Handler Bool
|
|
menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menuItemAccessCallback'
|
|
where
|
|
authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized (urlRoute menuItemRoute) False
|
|
|
|
$(return [])
|
|
|
|
|
|
data instance ButtonClass UniWorX
|
|
= BCIsButton
|
|
| BCDefault
|
|
| BCPrimary
|
|
| BCSuccess
|
|
| BCInfo
|
|
| BCWarning
|
|
| BCDanger
|
|
| BCLink
|
|
| BCMassInputAdd | BCMassInputDelete
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe (ButtonClass UniWorX)
|
|
instance Finite (ButtonClass UniWorX)
|
|
|
|
instance PathPiece (ButtonClass UniWorX) where
|
|
toPathPiece BCIsButton = "btn"
|
|
toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
|
|
fromPathPiece = finiteFromPathPiece
|
|
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonSubmit id
|
|
instance Button UniWorX ButtonSubmit where
|
|
btnClasses BtnSubmit = [BCIsButton, 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
|
|
|
|
|
|
instance RenderMessage UniWorX WeekDay where
|
|
renderMessage _ ls wDay = pack $ map fst (wDays $ getTimeLocale' ls) !! fromEnum wDay
|
|
|
|
newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
|
|
|
|
instance RenderMessage UniWorX ShortWeekDay where
|
|
renderMessage _ ls (ShortWeekDay wDay) = pack $ map snd (wDays $ getTimeLocale' ls) !! fromEnum wDay
|
|
|
|
-- Access Control
|
|
newtype InvalidAuthTag = InvalidAuthTag Text
|
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
|
instance Exception InvalidAuthTag
|
|
|
|
|
|
data AccessPredicate
|
|
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
|
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
|
|
| APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult)
|
|
|
|
class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
|
|
evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
|
|
|
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
|
|
evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
|
|
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
|
|
(APHandler p) -> p aid r w
|
|
(APDB p) -> runDB $ p aid r w
|
|
|
|
instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
|
|
evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
|
|
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
|
|
(APHandler p) -> lift $ p aid r w
|
|
(APDB p) -> p aid r w
|
|
|
|
|
|
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 _) _ = reason
|
|
andAR _ _ reason@(Unauthorized _) = reason
|
|
andAR _ Authorized other = other
|
|
andAR _ AuthenticationRequired _ = AuthenticationRequired
|
|
|
|
trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
|
|
trueAR = const Authorized
|
|
falseAR = Unauthorized . ($ MsgUnauthorized) . render
|
|
|
|
trueAP, falseAP :: AccessPredicate
|
|
trueAP = APPure . const . const . const $ trueAR <$> ask
|
|
falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
|
|
|
|
|
askTokenUnsafe :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadLogger m
|
|
, MonadCatch m
|
|
)
|
|
=> ExceptT AuthResult m (BearerToken (UniWorX))
|
|
-- | This performs /no/ meaningful validation of the `BearerToken`
|
|
--
|
|
-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
|
|
askTokenUnsafe = $cachedHere $ do
|
|
jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
|
|
catch (decodeToken jwt) $ \case
|
|
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
|
|
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
|
|
other -> do
|
|
$logWarnS "AuthToken" $ tshow other
|
|
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
|
|
|
|
validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
|
|
validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
|
|
where
|
|
validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
|
|
validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
|
|
guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
|
|
|
|
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
|
|
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
|
|
|
let
|
|
-- Prevent infinite loops
|
|
noTokenAuth :: AuthDNF -> AuthDNF
|
|
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
|
|
|
authorityVal <- do
|
|
dnf <- either throwM return $ routeAuthTags route
|
|
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite
|
|
guardExceptT (is _Authorized authorityVal) authorityVal
|
|
|
|
whenIsJust tokenAddAuth $ \addDNF -> do
|
|
$logDebugS "validateToken" $ tshow addDNF
|
|
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
|
|
guardExceptT (is _Authorized additionalVal) additionalVal
|
|
|
|
return Authorized
|
|
|
|
|
|
tagAccessPredicate :: AuthTag -> AccessPredicate
|
|
tagAccessPredicate AuthFree = trueAP
|
|
tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
|
|
-- Courses: access only to school admins
|
|
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[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 -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
|
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
|
return Authorized
|
|
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
|
|
lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
|
|
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
|
|
AdminHijackUserR cID -> exceptT return return $ do
|
|
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
uid <- decrypt cID
|
|
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
|
|
otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
|
|
mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
|
|
guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthNoEscalation r
|
|
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
|
|
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
|
addMessageI Error MsgDeprecatedRoute
|
|
allow <- view _appAllowDeprecated
|
|
return $ bool (Unauthorized "Deprecated Route") Authorized allow
|
|
tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
|
|
$logWarnS "AccessControl" ("route in development: " <> tshow r)
|
|
#ifdef DEVELOPMENT
|
|
return Authorized
|
|
#else
|
|
return $ Unauthorized "Route under development"
|
|
#endif
|
|
tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
|
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[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
|
|
-- lecturer for any school will do
|
|
_ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
|
|
return Authorized
|
|
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
resList <- $cachedHereBinary (mAuthId) . 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 _ -> $cachedHereBinary (mAuthId, 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 _ -> $cachedHereBinary (mAuthId, 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 _ -> $cachedHereBinary (mAuthId, 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
|
|
tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
|
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
|
E.where_ $ tutor E.^. TutorUser E.==. E.val authId
|
|
return (course E.^. CourseId, tutorial E.^. TutorialId)
|
|
let
|
|
resMap :: Map CourseId (Set TutorialId)
|
|
resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
|
|
case route of
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
|
|
guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
|
guard $ cid `Set.member` Map.keysSet resMap
|
|
return Authorized
|
|
_ -> do
|
|
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
|
|
return Authorized
|
|
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
|
|
cTime <- liftIO getCurrentTime
|
|
registered <- case mAuthId of
|
|
Just uid -> $cachedHereBinary (eId, uid) . lift . existsBy $ UniqueExamRegistration eId uid
|
|
Nothing -> return False
|
|
|
|
let visible = NTop examVisibleFrom <= NTop (Just cTime)
|
|
|
|
case subRoute of
|
|
EShowR -> guard visible
|
|
EUsersR -> guard $ NTop examStart <= NTop (Just cTime)
|
|
&& NTop (Just cTime) <= NTop examFinished
|
|
ERegisterR
|
|
| not registered -> guard $ visible
|
|
&& NTop examRegisterFrom <= NTop (Just cTime)
|
|
&& NTop (Just cTime) <= NTop examRegisterTo
|
|
| otherwise -> guard $ visible
|
|
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
|
_ -> return ()
|
|
|
|
return Authorized
|
|
|
|
CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
|
|
now <- liftIO getCurrentTime
|
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn
|
|
registered <- case mAuthId of
|
|
Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid
|
|
Nothing -> return False
|
|
|
|
if
|
|
| not registered
|
|
, maybe False (now >=) tutorialRegisterFrom
|
|
, maybe True (now <=) tutorialRegisterTo
|
|
-> return Authorized
|
|
| registered
|
|
, maybe True (now <=) tutorialDeregisterUntil
|
|
-> return Authorized
|
|
| otherwise
|
|
-> mzero
|
|
|
|
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
|
|
cTime <- liftIO getCurrentTime
|
|
let
|
|
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
|
|
active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
|
|
marking = cTime > sheetActiveTo
|
|
|
|
guard visible
|
|
|
|
case subRoute of
|
|
-- Single Files
|
|
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
|
|
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
|
|
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
|
SFileR _ _ -> mzero
|
|
-- Archives of SheetFileType
|
|
SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime
|
|
SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom
|
|
SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
|
SZipR _ -> mzero
|
|
-- Submissions
|
|
SubmissionNewR -> guard active
|
|
SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler
|
|
SubmissionR _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
|
|
SubmissionR _ _ -> guard active
|
|
_ -> return ()
|
|
|
|
return Authorized
|
|
|
|
CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
|
|
cTime <- liftIO getCurrentTime
|
|
let visible = NTop materialVisibleFrom <= NTop (Just cTime)
|
|
guard visible
|
|
return Authorized
|
|
|
|
CourseR tid ssh csh CRegisterR -> do
|
|
now <- liftIO getCurrentTime
|
|
mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
|
|
registered <- case (mbc,mAuthId) of
|
|
(Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ isJust <$> (getBy $ UniqueParticipant uid cid)
|
|
_ -> return False
|
|
case mbc of
|
|
(Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
|
|
| not registered
|
|
, maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
|
|
, maybe True (now <=) courseRegisterTo -> return Authorized
|
|
(Just (Entity _ Course{courseDeregisterUntil}))
|
|
| registered
|
|
, maybe True (now <=) courseDeregisterUntil -> return Authorized
|
|
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
|
|
|
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
|
smId <- decrypt cID
|
|
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
|
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
|
guard $ NTop systemMessageFrom <= cTime
|
|
&& NTop systemMessageTo >= cTime
|
|
return Authorized
|
|
|
|
r -> $unsupportedAuthPredicate AuthTime r
|
|
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . 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 MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
|
tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
|
|
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser 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
|
|
E.&&. tutorial E.^. TutorialName E.==. E.val tutn
|
|
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
|
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser 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 MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthTutorialRegistered r
|
|
tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser 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
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
|
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
[E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser 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 MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamRegistered r
|
|
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
|
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
|
let authorizedIfExists f = do
|
|
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
|
whenExceptT ok Authorized
|
|
participant <- decrypt cID
|
|
-- participant is currently registered
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
|
|
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant has at least one submission
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
|
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is member of a submissionGroup
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
|
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is a sheet corrector
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is a tutorial user
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is tutor for this course
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is lecturer for this course
|
|
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
unauthorizedI MsgUnauthorizedParticipant
|
|
r -> $unsupportedAuthPredicate AuthParticipant r
|
|
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
|
|
registered <- $cachedHereBinary tutId . lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ]
|
|
guard $ NTop tutorialCapacity > NTop (Just registered)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
|
Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
registered <- $cachedHereBinary cid . lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
|
guard $ NTop courseCapacity > NTop (Just registered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCapacity r
|
|
tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
|
|
case (tutorialRegGroup, mAuthId) of
|
|
(Nothing, _) -> return Authorized
|
|
(_, Nothing) -> return AuthenticationRequired
|
|
(Just rGroup, Just uid) -> do
|
|
[E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
|
E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid
|
|
E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
|
|
guard $ not hasOther
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthRegisterGroup r
|
|
tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
|
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
|
assertM_ ((<= 0) :: Int -> Bool) . $cachedHereBinary cid . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
return E.countRows
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthEmpty r
|
|
tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
|
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
guard courseMaterialFree
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthMaterials r
|
|
tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
|
|
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
|
|
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthOwner r
|
|
tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
|
|
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
|
|
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
sub <- MaybeT $ get sid
|
|
guard $ submissionRatingDone sub
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthRated r
|
|
tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
|
|
CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
|
|
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
|
|
guard $ is _Just submissionModeUser
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthUserSubmissions r
|
|
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
|
|
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
|
|
guard submissionModeCorrector
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
|
|
tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
|
|
referencedUser <- case route of
|
|
AdminUserR cID -> return cID
|
|
AdminUserDeleteR cID -> return cID
|
|
AdminHijackUserR cID -> return cID
|
|
UserNotificationR cID -> return cID
|
|
CourseR _ _ _ (CUserR cID) -> return cID
|
|
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
|
referencedUser' <- decrypt referencedUser
|
|
case mAuthId of
|
|
Just uid
|
|
| uid == referencedUser' -> return Authorized
|
|
Nothing -> return AuthenticationRequired
|
|
_other -> unauthorizedI MsgUnauthorizedSelf
|
|
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
|
|
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
|
|
smId <- decrypt cID
|
|
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
|
|
let isAuthenticated = isJust mAuthId
|
|
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthAuthentication r
|
|
tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
|
|
tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
|
|
|
|
|
|
authTagSpecificity :: AuthTag -> AuthTag -> Ordering
|
|
-- ^ Heuristic for which `AuthTag`s to evaluate first
|
|
authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
|
|
where
|
|
eqClasses :: [[AuthTag]]
|
|
-- ^ Constructors of `AuthTag` ordered (increasing) by execution order
|
|
eqClasses =
|
|
[ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide
|
|
, [ AuthRead, AuthWrite, AuthToken ] -- Request wide
|
|
, [ AuthAdmin ] -- Site wide
|
|
, [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide
|
|
, [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide
|
|
, [ AuthOwner, AuthRated ] -- Submission wide
|
|
]
|
|
|
|
defaultAuthDNF :: AuthDNF
|
|
defaultAuthDNF = PredDNF $ Set.fromList
|
|
[ impureNonNull . Set.singleton $ PLVariable AuthAdmin
|
|
, impureNonNull . Set.singleton $ PLVariable AuthToken
|
|
]
|
|
|
|
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
|
|
-- ^ DNF up to entailment:
|
|
--
|
|
-- > (A_1 && A_2 && ...) OR' B OR' ...
|
|
--
|
|
-- > A OR' B := ((A |- B) ==> A) && (A || B)
|
|
routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
|
|
where
|
|
partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
|
|
partition' prev t
|
|
| Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
|
|
= if
|
|
| oany (authTags `Set.isSubsetOf`) prev
|
|
-> Right prev
|
|
| otherwise
|
|
-> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev
|
|
| otherwise
|
|
= Left $ InvalidAuthTag t
|
|
|
|
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
|
|
-- ^ `tell`s disabled predicates, identified as pivots
|
|
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
|
|
= do
|
|
mr <- getMsgRenderer
|
|
let
|
|
authVarSpecificity = authTagSpecificity `on` plVar
|
|
authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
|
|
|
|
authTagIsInactive = not . authTagIsActive
|
|
|
|
evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
|
|
evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
|
|
where
|
|
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
|
|
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
|
|
evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
|
|
|
|
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
|
|
evalAuthLiteral PLVariable{..} = evalAuthTag plVar
|
|
evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
|
|
Unauthorized _ -> return Authorized
|
|
AuthenticationRequired -> return AuthenticationRequired
|
|
Authorized -> unauthorizedI plVar
|
|
|
|
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
|
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
|
andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
|
|
|
|
evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
|
|
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
|
|
|
|
$logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF
|
|
|
|
result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
|
|
|
|
unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
|
|
whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
|
|
let pivots = filter (authTagIsInactive . plVar) conj
|
|
whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
|
|
let pivots' = plVar <$> pivots
|
|
$logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
|
|
tell $ Set.fromList pivots'
|
|
|
|
return result
|
|
|
|
evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
|
evalAccessFor mAuthId route isWrite = do
|
|
dnf <- either throwM return $ routeAuthTags route
|
|
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
|
|
|
|
evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
|
|
evalAccessForDB = evalAccessFor
|
|
|
|
evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
|
|
evalAccess route isWrite = do
|
|
mAuthId <- liftHandlerT maybeAuthId
|
|
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
|
dnf <- either throwM return $ routeAuthTags route
|
|
(result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
|
|
result <$ tellSessionJson SessionInactiveAuthTags deactivated
|
|
|
|
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
|
|
evalAccessDB = evalAccess
|
|
|
|
-- | Check whether the current user is authorized by `evalAccess` for the given route
|
|
-- Convenience function for a commonly used code fragment
|
|
hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool
|
|
hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
|
|
|
|
-- | Check whether the current user is authorized by `evalAccess` to read from the given route
|
|
-- Convenience function for a commonly used code fragment
|
|
hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
|
|
hasReadAccessTo = flip hasAccessTo False
|
|
|
|
-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
|
|
-- Convenience function for a commonly used code fragment
|
|
hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
|
|
hasWriteAccessTo = flip hasAccessTo True
|
|
|
|
-- | Conditional redirect that hides the URL if the user is not authorized for the route
|
|
redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
|
|
redirectAccess url = do
|
|
-- must hide URL if not authorized
|
|
access <- evalAccess url False
|
|
case access of
|
|
Authorized -> redirect url
|
|
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
|
|
|
-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
|
|
evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> TermId -> SchoolId -> CourseShorthand -> m AuthResult
|
|
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
|
|
|
|
|
|
-- 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 app ^. _appRoot 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 app = do
|
|
(getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
|
|
return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate
|
|
|
|
maximumContentLength app _ = app ^. _appMaximumContentLength
|
|
|
|
-- 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 = headerMessagesMiddleware . 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'
|
|
headerMessagesMiddleware :: Handler a -> Handler a
|
|
headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
|
|
massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
|
|
$logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
|
|
guard $ or
|
|
[ isModal
|
|
, dbTableShortcircuit
|
|
, massInputShortcircuit
|
|
]
|
|
|
|
lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do
|
|
Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
|
|
addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs'
|
|
|
|
-- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
|
|
defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
|
|
|
|
errorHandler err = do
|
|
mr <- getMessageRender
|
|
let
|
|
encrypted :: ToJSON a => a -> Widget -> Widget
|
|
encrypted plaintextJson plaintext = do
|
|
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
|
|
shouldEncrypt <- view _appEncryptErrors
|
|
if
|
|
| shouldEncrypt
|
|
, not canDecrypt -> do
|
|
ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
|
|
|
|
[whamlet|
|
|
<p>_{MsgErrorResponseEncrypted}
|
|
<pre .errMsg>
|
|
#{ciphertext}
|
|
|]
|
|
| otherwise -> plaintext
|
|
|
|
errPage = case err of
|
|
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
|
|
InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
|
|
InvalidArgs errs -> [whamlet|
|
|
<ul>
|
|
$forall err' <- errs
|
|
<li .errMsg>#{err'}
|
|
|]
|
|
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
|
|
PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
|
|
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
|
|
fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
|
toWidget
|
|
[cassius|
|
|
.errMsg
|
|
white-space: pre-wrap
|
|
font-family: monospace
|
|
|]
|
|
errPage
|
|
|
|
defaultLayout = siteLayout' Nothing
|
|
|
|
-- The page to be redirected to when authentication is required.
|
|
authRoute _ = Just $ AuthR LoginR
|
|
|
|
isAuthorized = evalAccess
|
|
|
|
addStaticContent ext _mime content = do
|
|
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
|
|
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
|
|
let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
|
|
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
|
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
|
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
|
C.catchIf Memcached.isKeyNotFound touch $ \_ ->
|
|
C.handleIf Memcached.isKeyExists (\_ -> return ()) add
|
|
return . Left $ pack absoluteLink
|
|
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
|
|
fileName = (<.> unpack ext)
|
|
. unpack
|
|
. decodeUtf8
|
|
. Base64.encode
|
|
. (convert :: Digest (SHAKE256 144) -> ByteString)
|
|
. runIdentity
|
|
$ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
|
|
|
|
fileUpload _site _length = FileUploadMemory lbsBackEnd
|
|
|
|
-- 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 = readTVarIO . snd . appLogger
|
|
|
|
|
|
siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
|
|
siteLayoutMsg msg widget = do
|
|
mr <- getMessageRender
|
|
siteLayout (toWgt $ mr msg) widget
|
|
|
|
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
|
|
siteLayoutMsg' = siteLayout . i18nHeading
|
|
|
|
siteLayout :: Widget -- ^ `pageHeading`
|
|
-> Widget -> Handler Html
|
|
siteLayout = siteLayout' . Just
|
|
|
|
siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
|
|
-> Widget -> Handler Html
|
|
siteLayout' headingOverride widget = do
|
|
AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
|
|
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
|
|
primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages
|
|
|
|
mcurrentRoute <- getCurrentRoute
|
|
|
|
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
|
|
(title, parents) <- breadcrumbs
|
|
|
|
-- let isParent :: Route UniWorX -> Bool
|
|
-- isParent r = r == (fst parents)
|
|
|
|
defaultLinks' <- defaultLinks
|
|
let menu :: [MenuItem]
|
|
menu = defaultLinks' ++ maybe [] pageActions mcurrentRoute
|
|
|
|
menuTypes <- mapM (\x -> (,,) <$> pure x <*> newIdent <*> toTextUrl x) =<< filterM menuItemAccessCallback 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 do
|
|
items <- filterM menuItemAccessCallback (pageActions courseRoute)
|
|
items' <- forM items $ \i -> (i, ) <$> toTextUrl i
|
|
return (c, courseRoute, items')
|
|
|
|
mmsgs <- if
|
|
| isModal -> getMessages
|
|
| otherwise -> do
|
|
applySystemMessages
|
|
authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
|
|
forM_ authTagPivots $
|
|
\authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
|
|
getMessages
|
|
|
|
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
|
|
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
|
|
navItems = map (view _2) favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
|
|
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
|
|
in \r -> Just r == highR
|
|
favouriteTerms :: [TermIdentifier]
|
|
favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
|
|
favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
|
|
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.
|
|
|
|
navbarModal (MenuItem{..}, menuIdent') = customModal Modal
|
|
{ modalTriggerId = Just menuIdent'
|
|
, modalId = Nothing
|
|
, modalTrigger = \(Just route) menuIdent -> $(widgetFile "widgets/navbar/item")
|
|
, modalContent = Left menuItemRoute
|
|
}
|
|
|
|
navbarItem (MenuItem{..}, menuIdent) = do
|
|
route <- toTextUrl menuItemRoute
|
|
$(widgetFile "widgets/navbar/item")
|
|
|
|
navbar :: Widget
|
|
navbar = $(widgetFile "widgets/navbar/navbar")
|
|
asidenav :: Widget
|
|
asidenav = $(widgetFile "widgets/asidenav/asidenav")
|
|
where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
|
|
footer :: Widget
|
|
footer = $(widgetFile "widgets/footer/footer")
|
|
alerts :: Widget
|
|
alerts = $(widgetFile "widgets/alerts/alerts")
|
|
contentHeadline :: Maybe Widget
|
|
contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute)
|
|
breadcrumbsWgt :: Widget
|
|
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
|
|
pageaction :: Widget
|
|
pageaction = $(widgetFile "widgets/pageaction/pageaction")
|
|
-- functions to determine if there are page-actions (primary or secondary)
|
|
hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
|
|
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
|
hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
|
hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let
|
|
-- See Utils.Frontend.I18n and files in messages/frontend for message definitions
|
|
frontendI18n = toJSON (mr :: FrontendMessage -> Text)
|
|
|
|
pc <- widgetToPageContent $ do
|
|
-- fonts
|
|
addStylesheet $ StaticR fonts_fonts_css
|
|
-- SCSS
|
|
addStylesheet $ StaticR bundles_css_vendor_css
|
|
addStylesheet $ StaticR bundles_css_main_css
|
|
-- JavaScript
|
|
addScript $ StaticR bundles_js_polyfills_js
|
|
addScript $ StaticR bundles_js_vendor_js
|
|
addScript $ StaticR bundles_js_main_js
|
|
-- widgets
|
|
$(widgetFile "default-layout")
|
|
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
|
|
|
|
|
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
|
|
void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
|
|
|
|
now <- liftIO getCurrentTime
|
|
guard $ NTop systemMessageFrom <= NTop (Just now)
|
|
guard $ NTop (Just now) < NTop systemMessageTo
|
|
|
|
let sessionKey = "sm-" <> tshow (ciphertext cID)
|
|
_ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())
|
|
setSessionJson sessionKey ()
|
|
|
|
(_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
|
|
let
|
|
(summary, content) = case smTrans of
|
|
Nothing -> (systemMessageSummary, systemMessageContent)
|
|
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
|
case summary of
|
|
Just s ->
|
|
addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
|
|
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 AdminR)
|
|
breadcrumb (AdminUserR _) = return ("Users" , Just UsersR)
|
|
breadcrumb AdminR = return ("Administration", Nothing)
|
|
breadcrumb AdminFeaturesR = return ("Test" , Just AdminR)
|
|
breadcrumb AdminTestR = return ("Test" , Just AdminR)
|
|
breadcrumb AdminErrMsgR = return ("Test" , Just AdminR)
|
|
|
|
breadcrumb InfoR = return ("Information" , Nothing)
|
|
breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR)
|
|
breadcrumb DataProtR = return ("Datenschutz" , Just InfoR)
|
|
breadcrumb ImpressumR = return ("Impressum" , Just InfoR)
|
|
breadcrumb VersionR = return ("Versionsgeschichte", Just InfoR)
|
|
|
|
|
|
breadcrumb HelpR = return ("Hilfe" , Just HomeR)
|
|
|
|
|
|
breadcrumb HealthR = return ("Status" , Nothing)
|
|
breadcrumb InstanceR = return ("Identifikation", Nothing)
|
|
|
|
|
|
breadcrumb ProfileR = return ("User" , Just HomeR)
|
|
breadcrumb ProfileDataR = return ("Profile" , Just ProfileR)
|
|
breadcrumb AuthPredsR = return ("Authentifizierung", 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, Just CourseListR)
|
|
|
|
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
|
|
|
breadcrumb CourseListR = return ("Kurse" , Nothing)
|
|
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
|
breadcrumb (CourseR tid ssh csh CShowR) = return (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 CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh CAddUserR) = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR)
|
|
breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
|
|
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilung Korrekturen" , Just $ CourseR tid ssh csh CCorrectionsR)
|
|
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 (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
|
|
breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = return ("Offene Abgaben", Just $ CourseR tid ssh csh SheetListR)
|
|
breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR)
|
|
|
|
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Klausuren", Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
|
|
|
|
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
|
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
|
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
|
|
|
breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
|
breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
|
breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
|
breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
|
|
|
breadcrumb (CSheetR tid ssh csh shn SShowR) = return (original shn, Just $ CourseR tid ssh csh SheetListR)
|
|
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten" , Just $ CSheetR tid ssh csh shn SShowR)
|
|
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen" , 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 SAssignR) = return ("Zuteilung Korrekturen" , Just $ CSheetR tid ssh csh shn SSubsR)
|
|
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
|
|
|
|
breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material" , Just $ CourseR tid ssh csh CShowR)
|
|
breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu" , Just $ CourseR tid ssh csh MaterialListR)
|
|
breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (original mnm, Just $ CourseR tid ssh csh MaterialListR)
|
|
breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten" , Just $ CMaterialR tid ssh csh mnm MShowR)
|
|
breadcrumb (CMaterialR tid ssh csh mnm MDelR) = return ("Löschen" , Just $ CMaterialR tid ssh csh mnm MShowR)
|
|
-- (CMaterialR tid ssh csh mnm MFileR) -- 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 AdminR)
|
|
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 :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [MenuItem]
|
|
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
|
|
[ return MenuItem
|
|
{ menuItemType = NavbarAside
|
|
, menuItemLabel = MsgMenuHome
|
|
, menuItemIcon = Just "home"
|
|
, menuItemRoute = SomeRoute HomeR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = Footer
|
|
, menuItemLabel = MsgMenuDataProt
|
|
, menuItemIcon = Just "shield"
|
|
, menuItemRoute = SomeRoute DataProtR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = Footer
|
|
, menuItemLabel = MsgMenuImpressum
|
|
, menuItemIcon = Just "file-signature"
|
|
, menuItemRoute = SomeRoute ImpressumR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = Footer
|
|
, menuItemLabel = MsgMenuInformation
|
|
, menuItemIcon = Just "info"
|
|
, menuItemRoute = SomeRoute InfoR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, do
|
|
mCurrentRoute <- getCurrentRoute
|
|
|
|
return MenuItem
|
|
{ menuItemType = NavbarRight
|
|
, menuItemLabel = MsgMenuHelp
|
|
, menuItemIcon = Just "question"
|
|
, menuItemRoute = SomeRoute (HelpR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mCurrentRoute])
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarRight
|
|
, menuItemLabel = MsgMenuProfile
|
|
, menuItemIcon = Just "cogs"
|
|
, menuItemRoute = SomeRoute ProfileR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = isJust <$> maybeAuthPair
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarSecondary
|
|
, menuItemLabel = MsgMenuLogin
|
|
, menuItemIcon = Just "sign-in-alt"
|
|
, menuItemRoute = SomeRoute $ AuthR LoginR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = isNothing <$> maybeAuthPair
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarSecondary
|
|
, menuItemLabel = MsgMenuLogout
|
|
, menuItemIcon = Just "sign-out-alt"
|
|
, menuItemRoute = SomeRoute $ AuthR LogoutR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = isJust <$> maybeAuthPair
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarAside
|
|
, menuItemLabel = MsgMenuTermShow
|
|
, menuItemIcon = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!!
|
|
, menuItemRoute = SomeRoute TermShowR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarAside
|
|
, menuItemLabel = MsgMenuCourseList
|
|
, menuItemIcon = Just "graduation-cap"
|
|
, menuItemRoute = SomeRoute CourseListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarAside
|
|
, menuItemLabel = MsgMenuCorrections
|
|
, menuItemIcon = Just "check"
|
|
, menuItemRoute = SomeRoute CorrectionsR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarAside
|
|
, menuItemLabel = MsgMenuUsers
|
|
, menuItemIcon = Just "users"
|
|
, menuItemRoute = SomeRoute UsersR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
|
|
}
|
|
, return MenuItem
|
|
{ menuItemType = NavbarAside
|
|
, menuItemLabel = MsgAdminHeading
|
|
, menuItemIcon = Just "screwdriver"
|
|
, menuItemRoute = SomeRoute AdminR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
|
|
|
|
pageActions :: Route UniWorX -> [MenuItem]
|
|
{-
|
|
Icons: https://fontawesome.com/icons?d=gallery
|
|
Guideline: use icons without boxes/frames, only non-pro
|
|
|
|
Please keep sorted according to routes
|
|
-}
|
|
pageActions (HomeR) =
|
|
[
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgInfoLecturerTitle
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute InfoLecturerR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgAdminHeading
|
|
, menuItemIcon = Just "screwdriver"
|
|
, menuItemRoute = SomeRoute AdminR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgAdminFeaturesHeading
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute AdminFeaturesR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuMessageList
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute MessageListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuAdminErrMsg
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute AdminErrMsgR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (AdminR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgAdminFeaturesHeading
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute AdminFeaturesR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuMessageList
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute MessageListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgErrMsgHeading
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute AdminErrMsgR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuUsers
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute UsersR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuAdminTest
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute AdminTestR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (AdminUserR cID) = [
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuUserNotifications
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ UserNotificationR cID
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (InfoR) = [
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgInfoLecturerTitle
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute InfoLecturerR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (VersionR) = [
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgInfoLecturerTitle
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute InfoLecturerR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions HealthR = [
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuInstance
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute InstanceR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions InstanceR = [
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuHealth
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute HealthR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (HelpR) = [
|
|
-- MenuItem
|
|
-- { menuItemType = PageActionPrime
|
|
-- , menuItemLabel = MsgInfoLecturerTitle
|
|
-- , menuItemIcon = Nothing
|
|
-- , menuItemRoute = SomeRoute InfoLecturerR
|
|
-- , menuItemModal = False
|
|
-- , menuItemAccessCallback' = return True
|
|
-- }
|
|
]
|
|
pageActions (ProfileR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuProfileData
|
|
, menuItemIcon = Just "book"
|
|
, menuItemRoute = SomeRoute ProfileDataR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuAuthPreds
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute AuthPredsR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions TermShowR =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuTermCreate
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute TermEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (TermCourseListR tid) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCourseNew
|
|
, menuItemIcon = Just "book"
|
|
, menuItemRoute = SomeRoute CourseNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuTermEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ TermEditExistR tid
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (TermSchoolCourseListR _tid _ssh) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCourseNew
|
|
, menuItemIcon = Just "book"
|
|
, menuItemRoute = SomeRoute CourseNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseListR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCourseNew
|
|
, menuItemIcon = Just "book"
|
|
, menuItemRoute = SomeRoute CourseNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseNewR) = [
|
|
MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgInfoLecturerTitle
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute InfoLecturerR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh CShowR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuMaterialList
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' =
|
|
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material
|
|
materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents
|
|
existsVisible = do
|
|
matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do
|
|
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
return $ material E.^. MaterialName
|
|
anyM matNames (materialAccess . E.unValue)
|
|
in runDB $ lecturerAccess `or2M` existsVisible
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSheetList
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' =
|
|
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets
|
|
sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents
|
|
existsVisible = do
|
|
sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
return $ sheet E.^. SheetName
|
|
anyM sheetNames $ sheetAccess . E.unValue
|
|
in runDB $ lecturerAccess `or2M` existsVisible
|
|
}
|
|
] ++ pageActions (CourseR tid ssh csh SheetListR) ++
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuTutorialList
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuExamList
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' =
|
|
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
|
|
examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR
|
|
existsVisible = do
|
|
examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
return $ exam E.^. ExamName
|
|
anyM examNames $ examAccess . E.unValue
|
|
in runDB $ lecturerAccess `or2M` existsVisible
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuCourseMembers
|
|
, menuItemIcon = Just "user-graduate"
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuCourseCommunication
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuCourseEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuCourseClone
|
|
, menuItemIcon = Just "copy"
|
|
, menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuCourseDelete
|
|
, menuItemIcon = Just "trash"
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh CCorrectionsR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsAssign
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh SheetListR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSheetCurrent
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
|
void . MaybeT $ sheetCurrent tid ssh csh
|
|
return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSheetOldUnassigned
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
|
void . MaybeT $ sheetOldUnassigned tid ssh csh
|
|
return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSubmissions
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsAssign
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsOwn
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
|
|
, ("corrections-school", original $ unSchoolKey ssh)
|
|
, ("corrections-course", original csh)
|
|
])
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = do
|
|
muid <- maybeAuthId
|
|
case muid of
|
|
Nothing -> return False
|
|
(Just uid) -> do
|
|
[E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
|
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
|
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 ok
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSheetNew
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh CUsersR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCourseAddMembers
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh MaterialListR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuMaterialNew
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CMaterialR tid ssh csh mnm MShowR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuMaterialEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuMaterialDelete
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh CTutorialListR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuTutorialNew
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CTutorialR tid ssh csh tutn TEditR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuTutorialDelete
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CTutorialR tid ssh csh tutn TUsersR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuTutorialComm
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuTutorialEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuTutorialDelete
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CourseR tid ssh csh CExamListR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuExamNew
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamNewR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CExamR tid ssh csh examn EShowR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuExamEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuExamUsers
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CSheetR tid ssh csh shn SShowR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSubmissionNew
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ 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
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSubmissionOwn
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ 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
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsOwn
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
|
|
, ("corrections-school", original $ unSchoolKey ssh)
|
|
, ("corrections-course", original csh)
|
|
, ("corrections-sheet" , original shn)
|
|
])
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectors
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSubmissions
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsAssign
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSheetEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuSheetClone
|
|
, menuItemIcon = Just "copy"
|
|
, menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuSheetDelete
|
|
, menuItemIcon = Just "trash"
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CSheetR tid ssh csh shn SSubsR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSubmissionNew
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectors
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsAssign
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrection
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgCorrectorAssignTitle
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuSubmissionDelete
|
|
, menuItemIcon = Just "trash"
|
|
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuSubmissionDelete
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CSheetR tid ssh csh shn SCorrR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuSubmissions
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsAssign
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionSecondary
|
|
, menuItemLabel = MsgMenuSheetEdit
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CorrectionsR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsDownload
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute CorrectionsDownloadR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsUpload
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute CorrectionsUploadR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsCreate
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute CorrectionsCreateR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
|
uid <- MaybeT $ liftHandlerT maybeAuthId
|
|
sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
let
|
|
isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
|
|
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
|
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
isLecturer = E.exists . E.from $ \lecturer -> E.where_
|
|
$ lecturer E.^. LecturerUser E.==. E.val uid
|
|
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.where_ $ isCorrector' E.||. isLecturer
|
|
return $ sheet E.^. SheetSubmissionMode
|
|
return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsGrade
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute CorrectionsGradeR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
]
|
|
pageActions (CorrectionsGradeR) =
|
|
[ MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsUpload
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute CorrectionsUploadR
|
|
, menuItemModal = True
|
|
, menuItemAccessCallback' = return True
|
|
}
|
|
, MenuItem
|
|
{ menuItemType = PageActionPrime
|
|
, menuItemLabel = MsgMenuCorrectionsCreate
|
|
, menuItemIcon = Nothing
|
|
, menuItemRoute = SomeRoute CorrectionsCreateR
|
|
, menuItemModal = False
|
|
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
|
uid <- MaybeT $ liftHandlerT maybeAuthId
|
|
sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
let
|
|
isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
|
|
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
|
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
isLecturer = E.exists . E.from $ \lecturer -> E.where_
|
|
$ lecturer E.^. LecturerUser E.==. E.val uid
|
|
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.where_ $ isCorrector' E.||. isLecturer
|
|
return $ sheet E.^. SheetSubmissionMode
|
|
return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
|
|
}
|
|
]
|
|
pageActions _ = []
|
|
|
|
|
|
i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m ()
|
|
i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg
|
|
|
|
-- | only used in defaultLayout; better use siteLayout instead!
|
|
pageHeading :: Route UniWorX -> Maybe Widget
|
|
pageHeading (AuthR _)
|
|
= Just $ i18nHeading MsgLoginHeading
|
|
pageHeading HomeR
|
|
= Just $ i18nHeading MsgHomeHeading
|
|
pageHeading UsersR
|
|
= Just $ i18nHeading MsgUsers
|
|
pageHeading (AdminUserR _)
|
|
= Just $ i18nHeading MsgAdminUserHeading
|
|
pageHeading (AdminTestR)
|
|
= Just $ [whamlet|Internal Code Demonstration Page|]
|
|
pageHeading (AdminErrMsgR)
|
|
= Just $ i18nHeading MsgErrMsgHeading
|
|
|
|
pageHeading (InfoR)
|
|
= Just $ i18nHeading MsgInfoHeading
|
|
pageHeading (DataProtR)
|
|
= Just $ i18nHeading MsgDataProtHeading
|
|
pageHeading (ImpressumR)
|
|
= Just $ i18nHeading MsgImpressumHeading
|
|
pageHeading (VersionR)
|
|
= Just $ i18nHeading MsgVersionHeading
|
|
|
|
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
|
|
-- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
|
|
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
|
|
, verifySubmission
|
|
]
|
|
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` 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
|
|
verifySubmission = maybeOrig $ \route -> do
|
|
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
|
|
sId <- decrypt cID
|
|
Submission{submissionSheet} <- lift . lift $ get404 sId
|
|
Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
|
|
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
|
|
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
|
|
tell . Any $ route /= newRoute
|
|
return newRoute
|
|
|
|
|
|
-- How to run database actions.
|
|
instance YesodPersist UniWorX where
|
|
type YesodPersistBackend UniWorX = SqlBackend
|
|
runDB action = do
|
|
$logDebugS "YesodPersist" "runDB"
|
|
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
|
|
now <- liftIO getCurrentTime
|
|
|
|
let
|
|
userIdent = 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 = do
|
|
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
|
case res of
|
|
Authenticated uid
|
|
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
|
_other -> return res
|
|
|
|
$logDebugS "auth" $ tshow Creds{..}
|
|
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
|
|
|
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
|
Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
|
|
ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (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
|
|
userLastAuthentication = now <$ guard (not isDummy)
|
|
|
|
userEmail <- if
|
|
| Just [bs] <- userEmail'
|
|
, Right userEmail <- Text.decodeUtf8' bs
|
|
-> return $ 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
|
|
, userTokensIssuedAfter = Nothing
|
|
, ..
|
|
}
|
|
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
|
, UserDisplayName =. userDisplayName
|
|
, UserSurname =. userSurname
|
|
, UserEmail =. userEmail
|
|
] ++
|
|
[ UserLastAuthentication =. Just now | not isDummy ]
|
|
|
|
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
|
|
|
let
|
|
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
|
userStudyFeatures' = do
|
|
(k, v) <- ldapData
|
|
guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
return str
|
|
|
|
termNames = nubBy ((==) `on` mk) $ do
|
|
(k, v) <- ldapData
|
|
guard $ k == Attr "dfnEduPersonFieldOfStudyString"
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
return str
|
|
|
|
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
|
|
|
let
|
|
studyTermCandidates = Set.fromList $ do
|
|
name <- termNames
|
|
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
|
return (key, name)
|
|
studyTermCandidateIncidence
|
|
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
|
|
. UUID.fromByteString
|
|
. fromStrict
|
|
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
|
. runIdentity
|
|
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
|
|
|
|
[E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
|
|
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
|
|
|
unless candidatesRecorded $ do
|
|
let
|
|
studyTermCandidates' = do
|
|
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
|
return StudyTermCandidate{..}
|
|
lift $ insertMany_ studyTermCandidates'
|
|
|
|
lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
|
forM_ fs $ \f@StudyFeatures{..} -> do
|
|
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
|
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
|
void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
|
|
|
return $ Authenticated userId
|
|
Nothing -> acceptExisting
|
|
|
|
where
|
|
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
|
|
|
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
|
[ campusLogin <$> appLdapConf <*> appLdapPool
|
|
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
|
, dummyLogin <$ guard appAuthDummyLogin
|
|
]
|
|
|
|
authHttpManager = Yesod.getHttpManager
|
|
|
|
renderAuthMessage _ _ = Auth.germanMessage -- TODO
|
|
|
|
instance YesodAuthPersist UniWorX
|
|
|
|
unsafeHandler :: UniWorX -> Handler a -> IO a
|
|
unsafeHandler f h = do
|
|
logger <- makeLogger f
|
|
Unsafe.fakeHandlerGetLogger (const logger) f h
|
|
|
|
|
|
instance YesodMail UniWorX where
|
|
defaultFromAddress = getsYesod $ view _appMailFrom
|
|
mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
|
|
mailVerp = getsYesod $ view _appMailVerp
|
|
mailDateTZ = return appTZ
|
|
mailSmtp act = do
|
|
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
|
|
withResource pool act
|
|
mailT ctx mail = defMailT ctx $ do
|
|
void setMailObjectIdRandom
|
|
setDateCurrent
|
|
replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
|
|
|
|
(mRes, smtpData) <- listen mail
|
|
unless (view _MailSmtpDataSet smtpData)
|
|
setMailSmtpData
|
|
|
|
return mRes
|
|
|
|
|
|
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
|
type MonadCryptoKey m = CryptoIDKey
|
|
cryptoIDKey f = getsYesod appCryptoIDKey >>= f
|
|
|
|
instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
|
|
secretBoxKey = getsYesod appSecretBoxKey
|
|
|
|
-- 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
|