Merge branch 'master' into eecorrectr
This commit is contained in:
Sarah Vaupel
commit
366761ba84
@ -32,13 +32,13 @@ npm install:
|
||||
before_script: &npm
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt update -y
|
||||
- npm install -g n
|
||||
- n 13.5.0
|
||||
- export PATH="${N_PREFIX}/bin:$PATH"
|
||||
- npm install -g npm
|
||||
- hash -r
|
||||
- apt-get -y install openssh-client exiftool
|
||||
- apt -y install openssh-client exiftool
|
||||
- install -v -m 0700 -d ~/.ssh
|
||||
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
|
||||
- install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config;
|
||||
@ -93,9 +93,11 @@ yesod:build:dev:
|
||||
before_script: &haskell
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt-get install -y --no-install-recommends locales-all
|
||||
- apt-get install openssh-client -y
|
||||
- apt-key add ${LLVM_APT_KEY}
|
||||
- apt update -y
|
||||
- apt install -y --no-install-recommends locales-all openssh-client llvm-9
|
||||
- ln -vsf llc-9 /usr/bin/llc
|
||||
- ln -vsf opt-9 /usr/bin/opt
|
||||
- install -v -m 0700 -d ~/.ssh
|
||||
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
|
||||
- install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config;
|
||||
@ -143,13 +145,13 @@ frontend:test:
|
||||
before_script:
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt update -y
|
||||
- npm install -g n
|
||||
- n 13.5.0
|
||||
- export PATH="${N_PREFIX}/bin:$PATH"
|
||||
- npm install -g npm
|
||||
- hash -r
|
||||
- apt-get install -y --no-install-recommends chromium-browser
|
||||
- apt install -y --no-install-recommends chromium-browser
|
||||
dependencies:
|
||||
- npm install
|
||||
retry: 2
|
||||
@ -243,8 +245,8 @@ deploy:uniworx3:
|
||||
before_script:
|
||||
- rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
|
||||
- install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
|
||||
- apt-get update -y
|
||||
- apt-get install -y --no-install-recommends openssh-client
|
||||
- apt update -y
|
||||
- apt install -y --no-install-recommends openssh-client
|
||||
- install -v -m 0700 -d ~/.ssh
|
||||
- install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
|
||||
- install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config;
|
||||
|
||||
63
CHANGELOG.md
63
CHANGELOG.md
@ -2,6 +2,69 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [19.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.6.0...v19.0.0) (2020-08-15)
|
||||
|
||||
|
||||
### refactor
|
||||
|
||||
* split foundation & llvm ([c68a01d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c68a01d))
|
||||
|
||||
|
||||
### BREAKING CHANGES
|
||||
|
||||
* split foundation
|
||||
|
||||
|
||||
|
||||
## [18.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.5.0...v18.6.0) (2020-08-11)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **personalised-sheet-files:** more thorough check wrt sub-warnings ([0b0eaff](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0b0eaff))
|
||||
* hlint ([5ea7816](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5ea7816))
|
||||
* **course-visibility:** (more) correct visibility check for favourites ([796a806](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/796a806))
|
||||
* **course-visibility:** account for active auth tags everywhere ([c99433c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c99433c))
|
||||
* **course-visibility:** allow access for admin-like roles ([7569195](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7569195))
|
||||
* **course-visibility:** allow deregistration from invisible courses ([29da6e2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/29da6e2))
|
||||
* **course-visibility:** allow for caching Nothing results of getBy ([f129ce6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f129ce6))
|
||||
* **course-visibility:** check for mayEdit on course list ([b1d0893](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b1d0893))
|
||||
* **course-visibility:** correctly count courses on AllocationListR ([7530287](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7530287))
|
||||
* **course-visibility:** fix favourites ([1ac3c08](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ac3c08))
|
||||
* **course-visibility:** rework routes ([7ce60a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7ce60a3))
|
||||
* **course-visibility:** show icon to lecturers only ([cbb8e72](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb8e72))
|
||||
* **course-visibility:** visibility for admin-like users ([43f625b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43f625b))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **course-visibility:** account for visibility in routes ([cb0bf15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb0bf15))
|
||||
* **course-visibility:** account for visibility on AllocationListR ([4185742](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4185742))
|
||||
* **course-visibility:** account for visibility on AShowR ([df7a784](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/df7a784))
|
||||
* **course-visibility:** account for visibility on TShowR ([0ff07a5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0ff07a5))
|
||||
* **course-visibility:** add invisible icon to CShowR title ([6c0adde](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6c0adde))
|
||||
* **course-visibility:** add visibleFrom,visibleTo ([222d566](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/222d566))
|
||||
* **course-visibility:** allow access for exam correctors ([dfa70ee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa70ee))
|
||||
* **course-visibility:** display icon in course list for lecturers ([17dbccf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/17dbccf))
|
||||
* **course-visibility:** error on visibleFrom > visibleTo ([9494019](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9494019))
|
||||
* **course-visibility:** hide invisible courses from favourites + icon ([d86fed7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d86fed7))
|
||||
* **course-visibility:** more precise description on CShowR ([6fbb2ea](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6fbb2ea))
|
||||
* **course-visibility:** no invisible courses in course list ([24f1289](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/24f1289))
|
||||
* **course-visibility:** now as default visibleFrom for new courses ([7bdf8ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7bdf8ca))
|
||||
* **course-visibility:** redirect to NewsR after deregister (WIP!) ([183aa8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/183aa8d))
|
||||
* **course-visibility:** reorder course form ([7af82bc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7af82bc))
|
||||
* **course-visibility:** rework visibility check for ZA courses ([a16eb1a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a16eb1a))
|
||||
* **course-visibility:** warn on deregister from invisible course ([16ad72d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/16ad72d))
|
||||
* **course-visibility:** warn on invisibility during registration ([23aca1c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/23aca1c))
|
||||
* **personalised-sheet-files:** collated ignore ([1fe63a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fe63a2))
|
||||
* **personalised-sheet-files:** download from CUsersR ([93d0ace](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/93d0ace))
|
||||
* **personalised-sheet-files:** finish upload functionality ([ed5fb6e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ed5fb6e))
|
||||
* **personalised-sheet-files:** i18n ([f452b2b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f452b2b))
|
||||
* **personalised-sheet-files:** introduce routes & work on crypto ([9ee44aa](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9ee44aa))
|
||||
* **personalised-sheet-files:** participant interaction ([db205f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db205f6))
|
||||
|
||||
|
||||
|
||||
## [18.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.4.0...v18.5.0) (2020-08-03)
|
||||
|
||||
|
||||
|
||||
@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral
|
||||
|
||||
|
||||
instance PathPiece DiffTime where
|
||||
toPathPiece = toPathPiece . MkFixed @E12 . diffTimeToPicoseconds
|
||||
toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds
|
||||
fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps
|
||||
|
||||
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "18.5.0",
|
||||
"version": "19.0.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "18.5.0",
|
||||
"version": "19.0.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
43
package.yaml
43
package.yaml
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 18.5.0
|
||||
version: 19.0.0
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
@ -63,7 +63,6 @@ dependencies:
|
||||
- cryptoids-class
|
||||
- binary
|
||||
- binary-instances
|
||||
- cereal
|
||||
- mtl
|
||||
- esqueleto >=3.1.0
|
||||
- mime-types
|
||||
@ -210,6 +209,8 @@ default-extensions:
|
||||
- TypeFamilyDependencies
|
||||
- QuantifiedConstraints
|
||||
- EmptyDataDeriving
|
||||
- StandaloneKindSignatures
|
||||
- NoStarIsType
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
@ -229,42 +230,41 @@ when:
|
||||
ghc-options:
|
||||
- -Werror
|
||||
- -fwarn-tabs
|
||||
- condition: flag(dev)
|
||||
then:
|
||||
ghc-options:
|
||||
- -O0
|
||||
- -ddump-splices
|
||||
- -ddump-to-file
|
||||
cpp-options: -DDEVELOPMENT
|
||||
ghc-prof-options:
|
||||
- -fprof-auto
|
||||
else:
|
||||
ghc-options:
|
||||
- -O -fllvm
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: flag(dev)
|
||||
then:
|
||||
ghc-options:
|
||||
- -O0
|
||||
- -ddump-splices
|
||||
- -ddump-to-file
|
||||
cpp-options: -DDEVELOPMENT
|
||||
ghc-prof-options:
|
||||
- -fprof-auto
|
||||
else:
|
||||
ghc-options:
|
||||
- -O2
|
||||
|
||||
# Runnable executable for our application
|
||||
executables:
|
||||
uniworx:
|
||||
main: main.hs
|
||||
source-dirs: app
|
||||
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T"
|
||||
dependencies:
|
||||
- uniworx
|
||||
when:
|
||||
- condition: flag(library-only)
|
||||
buildable: false
|
||||
ghc-options:
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
uniworxdb:
|
||||
main: Database.hs
|
||||
ghc-options:
|
||||
- -main-is Database
|
||||
- -threaded
|
||||
- -rtsopts "-with-rtsopts=-N -T"
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
source-dirs: test
|
||||
dependencies:
|
||||
- uniworx
|
||||
@ -277,8 +277,7 @@ executables:
|
||||
main: Load.hs
|
||||
ghc-options:
|
||||
- -main-is Load
|
||||
- -threaded
|
||||
- -rtsopts "-with-rtsopts=-N -T"
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
source-dirs: load
|
||||
dependencies:
|
||||
- uniworx
|
||||
@ -312,9 +311,7 @@ tests:
|
||||
- yesod-persistent
|
||||
ghc-options:
|
||||
- -fno-warn-orphans
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
- -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
hlint:
|
||||
main: Hlint.hs
|
||||
other-modules: []
|
||||
|
||||
@ -101,6 +101,8 @@ import qualified Network.Minio as Minio
|
||||
|
||||
import Web.ServerSession.Core (StorageException(..))
|
||||
|
||||
import GHC.RTS.Flags (getRTSFlags)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
import Handler.News
|
||||
@ -200,6 +202,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
runAppLoggingT tempFoundation $ do
|
||||
$logInfoS "InstanceID" $ UUID.toText appInstanceID
|
||||
$logDebugS "Configuration" $ tshow appSettings'
|
||||
$logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
|
||||
|
||||
smtpPool <- for appSmtpConf $ \c -> do
|
||||
$logDebugS "setup" "SMTP-Pool"
|
||||
|
||||
@ -77,8 +77,8 @@ instance ToWidget site a => ToWidget site (CI a) where
|
||||
instance RenderMessage site a => RenderMessage site (CI a) where
|
||||
renderMessage f ls msg = renderMessage f ls $ CI.original msg
|
||||
|
||||
instance Lift t => Lift (CI t) where
|
||||
lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
|
||||
instance (CI.FoldCase t, Lift t) => Lift (CI t) where
|
||||
liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||]
|
||||
|
||||
|
||||
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
||||
|
||||
@ -46,7 +46,7 @@ sqlInTuple arity = do
|
||||
xsV <- newName "xs"
|
||||
|
||||
let
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs)
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
|
||||
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
||||
|
||||
instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
||||
|
||||
22
src/Database/Persist/Sql/Types/Instances.hs
Normal file
22
src/Database/Persist/Sql/Types/Instances.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Database.Persist.Sql.Types.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
|
||||
instance BackendCompatible SqlWriteBackend SqlWriteBackend where
|
||||
projectBackend = id
|
||||
|
||||
instance BackendCompatible SqlReadBackend SqlReadBackend where
|
||||
projectBackend = id
|
||||
|
||||
instance BackendCompatible SqlReadBackend SqlBackend where
|
||||
projectBackend = SqlReadBackend
|
||||
|
||||
instance BackendCompatible SqlWriteBackend SqlBackend where
|
||||
projectBackend = SqlWriteBackend
|
||||
@ -24,7 +24,7 @@ persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
|
||||
persistDirectoryWith settings dir = do
|
||||
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
|
||||
fn <- MaybeT . return . fromNullable $ takeFileName fp
|
||||
guard . not $ head fn == '.'
|
||||
guard $ head fn /= '.'
|
||||
guard . not $ head fn == '#' && last fn == '#'
|
||||
|
||||
lift $ do
|
||||
|
||||
5342
src/Foundation.hs
5342
src/Foundation.hs
File diff suppressed because it is too large
Load Diff
1475
src/Foundation/Authorization.hs
Normal file
1475
src/Foundation/Authorization.hs
Normal file
File diff suppressed because it is too large
Load Diff
46
src/Foundation/DB.hs
Normal file
46
src/Foundation/DB.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module Foundation.DB
|
||||
( runDBRead
|
||||
, runSqlPoolRetry
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (runDB, getDBRunner)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Control.Retry as Retry
|
||||
import GHC.IO.Exception (IOErrorType(OtherError))
|
||||
|
||||
import Database.Persist.Sql (runSqlPool, SqlReadBackend(..))
|
||||
|
||||
|
||||
runSqlPoolRetry :: forall m a backend.
|
||||
( MonadUnliftIO m, BackendCompatible SqlBackend backend
|
||||
, MonadLogger m, MonadMask m
|
||||
)
|
||||
=> ReaderT backend m a
|
||||
-> Pool backend
|
||||
-> m a
|
||||
runSqlPoolRetry action pool = do
|
||||
let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
|
||||
handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
|
||||
where suggestRetry :: IOException -> m Bool
|
||||
suggestRetry ioExc = return $
|
||||
ioeGetErrorType ioExc == OtherError
|
||||
&& ioeGetLocation ioExc == "libpq"
|
||||
logRetry :: forall e.
|
||||
Exception e
|
||||
=> Bool -- ^ Will retry
|
||||
-> e
|
||||
-> Retry.RetryStatus
|
||||
-> m ()
|
||||
logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
|
||||
logRetry shouldRetry@True err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
|
||||
|
||||
Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
|
||||
$logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
|
||||
runSqlPool action pool
|
||||
|
||||
runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
|
||||
runDBRead action = do
|
||||
$logDebugS "YesodPersist" "runDBRead"
|
||||
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
|
||||
@ -1,11 +1,12 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Foundation.I18n
|
||||
( appLanguages
|
||||
( appLanguages, appLanguagesOpts
|
||||
, UniWorXMessage(..)
|
||||
, ShortTermIdentifier(..)
|
||||
, MsgLanguage(..)
|
||||
, ShortSex(..)
|
||||
, ShortWeekDay(..)
|
||||
, SheetTypeHeader(..)
|
||||
, SheetArchiveFileTypeDirectory(..)
|
||||
, ShortStudyDegree(..)
|
||||
@ -34,16 +35,17 @@ import qualified Data.Text as Text
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import GHC.Exts (IsList(..))
|
||||
import qualified GHC.Exts (IsList(..))
|
||||
|
||||
import Yesod.Form.I18n.German
|
||||
import Yesod.Form.I18n.English
|
||||
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.Char as Char
|
||||
import Text.Unidecode (unidecode)
|
||||
import Data.Text.Lens (packed)
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
|
||||
appLanguages :: NonEmpty Lang
|
||||
appLanguages = "de-de-formal" :| ["en-eu"]
|
||||
@ -183,6 +185,20 @@ instance RenderMessage UniWorX MsgLanguage where
|
||||
where
|
||||
mr = renderMessage foundation $ lang : filter (/= lang) ls
|
||||
|
||||
appLanguagesOpts :: ( MonadHandler m
|
||||
, RenderMessage (HandlerSite m) MsgLanguage
|
||||
) => m (OptionList Lang)
|
||||
-- ^ Authoritive list of supported Languages
|
||||
appLanguagesOpts = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let mkOption l = Option
|
||||
{ optionDisplay = mr $ MsgLanguage l
|
||||
, optionInternalValue = l
|
||||
, optionExternalValue = l
|
||||
}
|
||||
langOptions = map mkOption $ toList appLanguages
|
||||
return $ mkOptionList langOptions
|
||||
|
||||
embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
|
||||
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''StudyFieldType id
|
||||
@ -364,6 +380,23 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where
|
||||
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
||||
mr = renderMessage foundation ls
|
||||
|
||||
instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
|
||||
renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
|
||||
where
|
||||
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
||||
mr = renderMessage f ls
|
||||
(pieces, _) = renderRoute route
|
||||
|
||||
instance RenderMessage UniWorX WeekDay where
|
||||
renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
||||
|
||||
newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
|
||||
|
||||
instance RenderMessage UniWorX ShortWeekDay where
|
||||
renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonSubmit id
|
||||
|
||||
|
||||
unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
|
||||
unRenderMessage' cmp foundation inp = nub $ do
|
||||
@ -371,7 +404,7 @@ unRenderMessage' cmp foundation inp = nub $ do
|
||||
x <- universeF
|
||||
guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
|
||||
return x
|
||||
where appLanguages' = F.toList appLanguages
|
||||
where appLanguages' = toList appLanguages
|
||||
|
||||
unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
||||
unRenderMessage = unRenderMessage' (==)
|
||||
@ -379,3 +412,7 @@ unRenderMessage = unRenderMessage' (==)
|
||||
unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
|
||||
unRenderMessageLenient = unRenderMessage' cmp
|
||||
where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
|
||||
|
||||
|
||||
instance Default DateTimeFormatter where
|
||||
def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
|
||||
|
||||
203
src/Foundation/Instances.hs
Normal file
203
src/Foundation/Instances.hs
Normal file
@ -0,0 +1,203 @@
|
||||
{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Foundation.Instances
|
||||
( ButtonClass(..), YesodPersistBackend, AuthId, MonadCryptoKey
|
||||
, unsafeHandler
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.List as List
|
||||
import Data.List (inits)
|
||||
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
import qualified Yesod.Auth.Message as Auth
|
||||
|
||||
import Utils.Form
|
||||
import Auth.LDAP
|
||||
import Auth.PWHash
|
||||
import Auth.Dummy
|
||||
|
||||
import qualified Foundation.Yesod.Session as UniWorX
|
||||
import qualified Foundation.Yesod.Middleware as UniWorX
|
||||
import qualified Foundation.Yesod.ErrorHandler as UniWorX
|
||||
import qualified Foundation.Yesod.StaticContent as UniWorX
|
||||
import qualified Foundation.Yesod.Persist as UniWorX
|
||||
import qualified Foundation.Yesod.Auth as UniWorX
|
||||
|
||||
import Foundation.SiteLayout
|
||||
import Foundation.Type
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
import Foundation.Yesod.Auth hiding (authenticate)
|
||||
import Foundation.Routes
|
||||
import Foundation.DB
|
||||
|
||||
import Network.Wai.Parse (lbsBackEnd)
|
||||
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import UnliftIO.Pool (withResource)
|
||||
|
||||
|
||||
data instance ButtonClass UniWorX
|
||||
= BCIsButton
|
||||
| BCDefault
|
||||
| BCPrimary
|
||||
| BCSuccess
|
||||
| BCInfo
|
||||
| BCWarning
|
||||
| BCDanger
|
||||
| BCLink
|
||||
| BCMassInputAdd | BCMassInputDelete
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
instance PathPiece (ButtonClass UniWorX) where
|
||||
toPathPiece BCIsButton = "btn"
|
||||
toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
|
||||
fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
|
||||
|
||||
instance Button UniWorX ButtonSubmit where
|
||||
btnClasses BtnSubmit = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
|
||||
-- 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
|
||||
|
||||
makeSessionBackend = UniWorX.makeSessionBackend
|
||||
|
||||
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 = UniWorX.yesodMiddleware
|
||||
|
||||
-- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
|
||||
defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
|
||||
|
||||
errorHandler = UniWorX.errorHandler
|
||||
|
||||
defaultLayout = siteLayout' Nothing
|
||||
|
||||
-- The page to be redirected to when authentication is required.
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
|
||||
isAuthorized = evalAccess
|
||||
|
||||
addStaticContent = UniWorX.addStaticContent
|
||||
|
||||
fileUpload _site _length = FileUploadMemory lbsBackEnd
|
||||
|
||||
-- What messages should be logged. The following includes all messages when
|
||||
-- in development, and warnings and errors in production.
|
||||
shouldLogIO app _source level = do
|
||||
LogSettings{..} <- readTVarIO $ appLogSettings app
|
||||
return $ logAll || level >= logMinimumLevel
|
||||
|
||||
makeLogger = readTVarIO . snd . appLogger
|
||||
|
||||
unsafeHandler :: UniWorX -> HandlerFor UniWorX a -> IO a
|
||||
unsafeHandler f h = do
|
||||
logger <- makeLogger f
|
||||
Unsafe.fakeHandlerGetLogger (const logger) f h
|
||||
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist UniWorX where
|
||||
type YesodPersistBackend UniWorX = SqlBackend
|
||||
runDB = UniWorX.runDB
|
||||
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = UniWorX.getDBRunner
|
||||
|
||||
|
||||
instance YesodAuth UniWorX where
|
||||
type AuthId UniWorX = UserId
|
||||
|
||||
-- Where to send a user after successful login
|
||||
loginDest _ = NewsR
|
||||
-- Where to send a user after logout
|
||||
logoutDest _ = NewsR
|
||||
-- Override the above two destinations when a Referer: header is present
|
||||
redirectToReferer _ = True
|
||||
|
||||
loginHandler = do
|
||||
toParent <- getRouteToParent
|
||||
liftHandler . defaultLayout $ do
|
||||
plugins <- getsYesod authPlugins
|
||||
$logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
|
||||
|
||||
setTitleI MsgLoginTitle
|
||||
$(widgetFile "login")
|
||||
|
||||
authenticate = UniWorX.authenticate
|
||||
|
||||
authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
|
||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
]
|
||||
|
||||
authHttpManager = getsYesod appHttpManager
|
||||
|
||||
onLogin = liftHandler $ do
|
||||
mlang <- runDB $ updateUserLanguage Nothing
|
||||
app <- getYesod
|
||||
let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
|
||||
| otherwise = renderMessage app []
|
||||
addMessage Success . toHtml $ mr Auth.NowLoggedIn
|
||||
|
||||
onErrorHtml dest msg = do
|
||||
addMessage Error $ toHtml msg
|
||||
redirect dest
|
||||
|
||||
renderAuthMessage _ ls = case lang of
|
||||
("en" : _) -> Auth.englishMessage
|
||||
_other -> Auth.germanMessage
|
||||
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
|
||||
|
||||
instance YesodAuthPersist UniWorX where
|
||||
getAuthEntity = liftHandler . runDBRead . get
|
||||
|
||||
|
||||
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
|
||||
2308
src/Foundation/Navigation.hs
Normal file
2308
src/Foundation/Navigation.hs
Normal file
File diff suppressed because it is too large
Load Diff
@ -21,8 +21,8 @@ import Foundation.Routes.Definitions
|
||||
-- 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 ()
|
||||
-- type Handler x = HandlerFor UniWorX x
|
||||
-- type Widget = WidgetFor UniWorX ()
|
||||
mkYesodData "UniWorX" uniworxRoutes
|
||||
|
||||
deriving instance Generic CourseR
|
||||
|
||||
569
src/Foundation/SiteLayout.hs
Normal file
569
src/Foundation/SiteLayout.hs
Normal file
@ -0,0 +1,569 @@
|
||||
{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites`
|
||||
|
||||
module Foundation.SiteLayout
|
||||
( siteLayout', siteLayout
|
||||
, siteLayoutMsg', siteLayoutMsg
|
||||
, getSystemMessageState
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (embedFile)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Authorization
|
||||
import Foundation.Routes
|
||||
import Foundation.Navigation
|
||||
import Foundation.I18n
|
||||
import Foundation.DB
|
||||
|
||||
import Utils.SystemMessage
|
||||
import Utils.Form
|
||||
import Utils.Course
|
||||
import Utils.Metrics
|
||||
|
||||
import Handler.Utils.Routes
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Text.Cassius (cassiusFile)
|
||||
import Text.Hamlet (hamletFile)
|
||||
import Data.FileEmbed (embedFile)
|
||||
|
||||
|
||||
data MemcachedKeyFavourites
|
||||
= MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
|
||||
deriving instance Read AuthContext => Read MemcachedKeyFavourites
|
||||
deriving instance Show AuthContext => Show MemcachedKeyFavourites
|
||||
deriving instance Hashable AuthContext => Hashable MemcachedKeyFavourites
|
||||
deriving instance Binary AuthContext => Binary MemcachedKeyFavourites
|
||||
|
||||
data MemcachedLimitKeyFavourites
|
||||
= MemcachedLimitKeyFavourites
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Hashable, Binary)
|
||||
|
||||
|
||||
siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg = siteLayout . i18n
|
||||
|
||||
{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
|
||||
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayoutMsg' = siteLayoutMsg
|
||||
|
||||
siteLayout :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> WidgetFor UniWorX () -- ^ `pageHeading`
|
||||
-> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayout = siteLayout' . Just
|
||||
|
||||
siteLayout' :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
|
||||
-> WidgetFor UniWorX () -> HandlerFor UniWorX Html
|
||||
siteLayout' overrideHeading widget = do
|
||||
AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
|
||||
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
|
||||
primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages
|
||||
|
||||
mcurrentRoute <- getCurrentRoute
|
||||
let currentHandler = classifyHandler <$> mcurrentRoute
|
||||
|
||||
currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)
|
||||
|
||||
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
|
||||
let
|
||||
breadcrumbs' mcRoute = do
|
||||
mr <- getMessageRender
|
||||
case mcRoute of
|
||||
Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
|
||||
Just cRoute -> do
|
||||
(title, next) <- breadcrumb cRoute
|
||||
crumbs <- go [] next
|
||||
return (title, crumbs)
|
||||
where
|
||||
go crumbs Nothing = return crumbs
|
||||
go crumbs (Just cRoute) = do
|
||||
hasAccess <- hasReadAccessTo cRoute
|
||||
(title, next) <- breadcrumb cRoute
|
||||
go ((cRoute, title, hasAccess) : crumbs) next
|
||||
(title, parents) <- breadcrumbs' mcurrentRoute
|
||||
|
||||
-- let isParent :: Route UniWorX -> Bool
|
||||
-- isParent r = r == (fst parents)
|
||||
|
||||
isAuth <- isJust <$> maybeAuthId
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
-- Lookup Favourites & Theme if possible
|
||||
(favourites', maxFavouriteTerms, currentTheme) <- do
|
||||
muid <- maybeAuthPair
|
||||
|
||||
favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
|
||||
E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
|
||||
E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
|
||||
|
||||
let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
|
||||
isCurrent
|
||||
| Just (CourseR tid ssh csh _) <- mcurrentRoute
|
||||
= course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
| otherwise
|
||||
= E.false
|
||||
notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
|
||||
E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
|
||||
E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
|
||||
isParticipant = E.exists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
|
||||
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
isLecturer = E.exists . E.from $ \lecturer ->
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
|
||||
isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
|
||||
E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
|
||||
isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
|
||||
isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
|
||||
courseVisible = courseIsVisible now course Nothing
|
||||
|
||||
reason = E.case_
|
||||
[ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent
|
||||
, E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
|
||||
] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
|
||||
|
||||
E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
|
||||
|
||||
return (course, reason, courseVisible)
|
||||
|
||||
favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
|
||||
mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
return (course, reason, courseVisible, mayView, mayEdit)
|
||||
|
||||
let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
|
||||
|
||||
return ( favCourses
|
||||
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
|
||||
, maybe userDefaultTheme userTheme $ view _2 <$> muid
|
||||
)
|
||||
|
||||
let favouriteTerms :: [TermIdentifier]
|
||||
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
|
||||
|
||||
favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
|
||||
-> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
favouriteReason = fromMaybe FavouriteCurrent mFavourite
|
||||
in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
|
||||
ctx <- getAuthContext
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
langs <- selectLanguages appLanguages <$> languages
|
||||
let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
|
||||
items <- memcachedLimitedKeyTimeoutBy
|
||||
MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
|
||||
(Right <$> appFavouritesQuickActionsCacheTTL)
|
||||
appFavouritesQuickActionsTimeout
|
||||
cK
|
||||
cK
|
||||
. observeFavouritesQuickActionsDuration $ do
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
|
||||
items' <- pageQuickActions NavQuickViewFavourite courseRoute
|
||||
items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
|
||||
return items
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
|
||||
return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit)
|
||||
|
||||
nav'' <- mconcat <$> sequence
|
||||
[ defaultLinks
|
||||
, maybe (return []) pageActions mcurrentRoute
|
||||
]
|
||||
nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
|
||||
nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
|
||||
|
||||
mmsgs <- if
|
||||
| isModal -> return mempty
|
||||
| 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
|
||||
|
||||
-- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
|
||||
-- let langFormView' = wrapForm langFormView def
|
||||
-- { formAction = Just $ SomeRoute LangR
|
||||
-- , formSubmit = FormAutoSubmit
|
||||
-- , formEncoding = langFormEnctype
|
||||
-- }
|
||||
|
||||
let highlight :: HasRoute UniWorX url => url -> Bool
|
||||
-- ^ highlight last route in breadcrumbs, favorites taking priority
|
||||
highlight = (highR ==) . Just . urlRoute
|
||||
where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
|
||||
navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
|
||||
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
|
||||
highlightNav = (||) <$> navForceActive <*> highlight
|
||||
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
|
||||
favouriteTermReason tid favReason' = favourites
|
||||
& filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
|
||||
& sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
|
||||
|
||||
-- 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.
|
||||
|
||||
navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> WidgetFor UniWorX ()
|
||||
navWidget (n, navIdent, navRoute', navChildren') = case n of
|
||||
NavHeader{ navLink = navLink@NavLink{..}, .. }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/item")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/navbar/item")
|
||||
NavPageActionPrimary{ navLink = navLink@NavLink{..} }
|
||||
-> let pWidget
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
= customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/primary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
= let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/pageaction/primary")
|
||||
| otherwise
|
||||
= error "not implemented"
|
||||
sWidgets = navChildren'
|
||||
& map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
|
||||
in $(widgetFile "widgets/pageaction/primary-wrapper")
|
||||
NavPageActionSecondary{ navLink = navLink@NavLink{..} }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/secondary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/pageaction/secondary")
|
||||
NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container")
|
||||
NavFooter{ navLink = navLink@NavLink{..} }
|
||||
| NavTypeLink{..} <- navType
|
||||
, not navModal
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/footer/link")
|
||||
_other -> error "not implemented"
|
||||
|
||||
navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)])
|
||||
-> (NavLink, Text, Text)
|
||||
-> WidgetFor UniWorX ()
|
||||
navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
|
||||
NavHeaderContainer{}
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just iNavIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute iN
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = iNavRoute
|
||||
ident = iNavIdent
|
||||
in $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
| NavTypeButton{..} <- navType -> do
|
||||
csrfToken <- reqToken <$> getRequest
|
||||
wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
|
||||
{ formMethod = navMethod
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute iN
|
||||
}
|
||||
_other -> error "not implemented"
|
||||
|
||||
navbar :: WidgetFor UniWorX ()
|
||||
navbar = do
|
||||
$(widgetFile "widgets/navbar/navbar")
|
||||
forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) ->
|
||||
toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius")
|
||||
where isNavHeaderPrimary = has $ _1 . _navHeaderRole . only NavHeaderPrimary
|
||||
isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary
|
||||
asidenav :: WidgetFor UniWorX ()
|
||||
asidenav = $(widgetFile "widgets/asidenav/asidenav")
|
||||
where
|
||||
logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
|
||||
footer :: WidgetFor UniWorX ()
|
||||
footer = $(widgetFile "widgets/footer/footer")
|
||||
where isNavFooter = has $ _1 . _NavFooter
|
||||
alerts :: WidgetFor UniWorX ()
|
||||
alerts = $(widgetFile "widgets/alerts/alerts")
|
||||
contentHeadline :: Maybe (WidgetFor UniWorX ())
|
||||
contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute)
|
||||
breadcrumbsWgt :: WidgetFor UniWorX ()
|
||||
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
|
||||
pageaction :: WidgetFor UniWorX ()
|
||||
pageaction = $(widgetFile "widgets/pageaction/pageaction")
|
||||
-- functions to determine if there are page-actions (primary or secondary)
|
||||
hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
|
||||
hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
|
||||
hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav
|
||||
hasPrimaryPageActions = has (folded . _1 . _NavPageActionPrimary ) nav
|
||||
hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav
|
||||
contentRibbon :: Maybe (WidgetFor UniWorX ())
|
||||
contentRibbon = fmap toWidget appRibbon
|
||||
|
||||
isNavHeaderContainer = has $ _1 . _NavHeaderContainer
|
||||
isPageActionPrimary = has $ _1 . _NavPageActionPrimary
|
||||
isPageActionSecondary = has $ _1 . _NavPageActionSecondary
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
-- See Utils.Frontend.I18n and files in messages/frontend for message definitions
|
||||
frontendI18n = toJSON (mr :: FrontendMessage -> Text)
|
||||
frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
|
||||
|
||||
pc <- widgetToPageContent $ do
|
||||
webpackLinks_main StaticR
|
||||
toWidget $(juliusFile "templates/i18n.julius")
|
||||
whenIsJust currentApproot' $ \currentApproot ->
|
||||
toWidget $(juliusFile "templates/approot.julius")
|
||||
whenIsJust mcurrentRoute $ \currentRoute' -> do
|
||||
currentRoute <- toTextUrl currentRoute'
|
||||
toWidget $(juliusFile "templates/current-route.julius")
|
||||
wellKnownHtmlLinks
|
||||
|
||||
$(widgetFile "default-layout")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
|
||||
|
||||
getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => SystemMessageId -> m UserSystemMessageState
|
||||
getSystemMessageState smId = liftHandler $ do
|
||||
muid <- maybeAuthId
|
||||
reqSt <- $cachedHere getSystemMessageStateRequest
|
||||
dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
|
||||
let MergeHashMap smSt = reqSt <> dbSt
|
||||
smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
|
||||
when (smSt' /= reqSt) $
|
||||
setRegisteredCookieJson CookieSystemMessageState
|
||||
=<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: HandlerFor UniWorX (HashMap CryptoUUIDSystemMessage _))) smSt'
|
||||
|
||||
return . fromMaybe mempty $ HashMap.lookup smId smSt
|
||||
where
|
||||
getSystemMessageStateRequest =
|
||||
(lookupRegisteredCookiesJson id CookieSystemMessageState :: HandlerFor UniWorX (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
|
||||
>>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v))
|
||||
getDBSystemMessageState uid = runDBRead . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
|
||||
where foldSt (Entity _ SystemMessageHidden{..})
|
||||
= MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
|
||||
|
||||
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m ()
|
||||
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
|
||||
lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
|
||||
|
||||
cRoute <- lift getCurrentRoute
|
||||
guard $ cRoute /= Just NewsR
|
||||
|
||||
lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
|
||||
where
|
||||
syncSystemMessageHidden :: UserId -> HandlerFor UniWorX ()
|
||||
syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do
|
||||
smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
|
||||
iforM_ smSt $ \cID UserSystemMessageState{..} -> do
|
||||
smId <- decrypt cID
|
||||
whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
|
||||
upsert SystemMessageHidden
|
||||
{ systemMessageHiddenMessage = smId
|
||||
, systemMessageHiddenUser = uid
|
||||
, systemMessageHiddenTime
|
||||
}
|
||||
[ SystemMessageHiddenTime =. systemMessageHiddenTime ]
|
||||
|
||||
when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
|
||||
deleteBy $ UniqueSystemMessageHidden uid smId
|
||||
|
||||
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
|
||||
-> fmap MergeHashMap . assertM' (/= mempty) $
|
||||
HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
|
||||
|
||||
applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) ()
|
||||
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
|
||||
guard $ not systemMessageNewsOnly
|
||||
|
||||
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
|
||||
|
||||
UserSystemMessageState{..} <- lift $ getSystemMessageState smId
|
||||
guard $ userSystemMessageShown <= Just systemMessageLastChanged
|
||||
guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
|
||||
|
||||
(_, 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
|
||||
|
||||
tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
|
||||
HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
|
||||
|
||||
|
||||
-- FIXME: Move headings into their respective handlers
|
||||
|
||||
-- | Method for specifying page heading for handlers that call defaultLayout
|
||||
--
|
||||
-- All handlers whose code is under our control should use
|
||||
-- `siteLayout` instead; `pageHeading` is only a fallback solution for
|
||||
-- e.g. subsites like `AuthR`
|
||||
pageHeading :: ( YesodPersist UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
) => Route UniWorX -> Maybe Widget
|
||||
pageHeading (AuthR _)
|
||||
= Just $ i18n MsgLoginHeading
|
||||
pageHeading NewsR
|
||||
= Just $ i18n MsgNewsHeading
|
||||
pageHeading UsersR
|
||||
= Just $ i18n MsgUsers
|
||||
pageHeading (AdminUserR _)
|
||||
= Just $ i18n MsgAdminUserHeading
|
||||
pageHeading AdminTestR
|
||||
= Just [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading AdminErrMsgR
|
||||
= Just $ i18n MsgErrMsgHeading
|
||||
|
||||
pageHeading InfoR
|
||||
= Just $ i18n MsgInfoHeading
|
||||
pageHeading LegalR
|
||||
= Just $ i18n MsgLegalHeading
|
||||
pageHeading VersionR
|
||||
= Just $ i18n MsgVersionHeading
|
||||
|
||||
pageHeading HelpR
|
||||
= Just $ i18n MsgHelpRequest
|
||||
|
||||
pageHeading ProfileR
|
||||
= Just $ i18n MsgProfileHeading
|
||||
pageHeading ProfileDataR
|
||||
= Just $ i18n MsgProfileDataHeading
|
||||
|
||||
pageHeading TermShowR
|
||||
= Just $ i18n MsgTermsHeading
|
||||
pageHeading TermCurrentR
|
||||
= Just $ i18n MsgTermCurrent
|
||||
pageHeading TermEditR
|
||||
= Just $ i18n MsgTermEditHeading
|
||||
pageHeading (TermEditExistR tid)
|
||||
= Just $ i18n $ MsgTermEditTid tid
|
||||
pageHeading (TermCourseListR tid)
|
||||
= Just . i18n . MsgTermCourseListHeading $ tid
|
||||
pageHeading (TermSchoolCourseListR tid ssh)
|
||||
= Just $ do
|
||||
School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh
|
||||
i18n $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading CourseListR
|
||||
= Just $ i18n MsgCourseListTitle
|
||||
pageHeading CourseNewR
|
||||
= Just $ i18n MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
= Just $ do
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
toWidget courseName
|
||||
-- (CourseR tid csh CRegisterR) -- just for POST
|
||||
pageHeading (CourseR tid ssh csh CEditR)
|
||||
= Just $ i18n $ MsgCourseEditHeading tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh CCorrectionsR)
|
||||
= Just $ i18n $ MsgSubmissionsCourse tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetListR)
|
||||
= Just $ i18n $ MsgSheetList tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetNewR)
|
||||
= Just $ i18n $ MsgSheetNewHeading tid ssh csh
|
||||
pageHeading (CSheetR tid ssh csh shn SShowR)
|
||||
= Just $ i18n $ MsgSheetTitle tid ssh csh shn
|
||||
-- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
|
||||
pageHeading (CSheetR tid ssh csh shn SEditR)
|
||||
= Just $ i18n $ MsgSheetEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SDelR)
|
||||
= Just $ i18n $ MsgSheetDelHead tid ssh csh shn
|
||||
pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
|
||||
= Just $ i18n $ MsgSubmissionsSheet shn
|
||||
pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
|
||||
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
|
||||
= Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid
|
||||
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
|
||||
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
|
||||
|
||||
pageHeading CorrectionsR
|
||||
= Just $ i18n MsgCorrectionsTitle
|
||||
pageHeading CorrectionsUploadR
|
||||
= Just $ i18n MsgCorrUpload
|
||||
pageHeading CorrectionsCreateR
|
||||
= Just $ i18n MsgCorrCreate
|
||||
pageHeading CorrectionsGradeR
|
||||
= Just $ i18n MsgCorrGrade
|
||||
pageHeading (MessageR _)
|
||||
= Just $ i18n MsgSystemMessageHeading
|
||||
pageHeading MessageListR
|
||||
= Just $ i18n MsgSystemMessageListHeading
|
||||
|
||||
-- TODO: add headings for more single course- and single term-pages
|
||||
pageHeading _
|
||||
= Nothing
|
||||
@ -7,6 +7,7 @@ module Foundation.Type
|
||||
, _SessionStorageMemcachedSql, _SessionStorageAcid
|
||||
, SMTPPool
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
|
||||
, DB, Form, MsgRenderer, MailM
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -74,3 +75,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
|
||||
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
|
||||
readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
|
||||
|
||||
|
||||
type DB = YesodDB UniWorX
|
||||
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
type MailM a = MailT (HandlerFor UniWorX) a
|
||||
|
||||
498
src/Foundation/Yesod/Auth.hs
Normal file
498
src/Foundation/Yesod/Auth.hs
Normal file
@ -0,0 +1,498 @@
|
||||
module Foundation.Yesod.Auth
|
||||
( authenticate
|
||||
, upsertCampusUser
|
||||
, CampusUserConversionException(..)
|
||||
, campusUserFailoverMode, updateUserLanguage
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (authenticate)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Types
|
||||
import Foundation.I18n
|
||||
|
||||
import Handler.Utils.Profile
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.SchoolLdap
|
||||
|
||||
import Yesod.Auth.Message
|
||||
import Auth.LDAP
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Control.Monad.Catch as C (Handler(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Ldap.Client as Ldap
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Data.List as List ((\\))
|
||||
|
||||
import qualified Data.UUID as UUID
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (SHAKE128)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
|
||||
|
||||
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, YesodAuth UniWorX, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Creds UniWorX -> m (AuthenticationResult UniWorX)
|
||||
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
||||
upsertMode = creds ^? _upsertCampusUserMode
|
||||
|
||||
isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
|
||||
isOther = is (_Just . _UpsertCampusUserOther) upsertMode
|
||||
|
||||
excRecovery res
|
||||
| isDummy || isOther
|
||||
= do
|
||||
case res of
|
||||
UserError err -> addMessageI Error err
|
||||
ServerError err -> addMessage Error $ toHtml err
|
||||
_other -> return ()
|
||||
acceptExisting
|
||||
| otherwise
|
||||
= return res
|
||||
|
||||
excHandlers =
|
||||
[ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr MsgInternalLdapError
|
||||
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
|
||||
$logErrorS "LDAP" $ tshow cExc
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr cExc
|
||||
]
|
||||
|
||||
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
|
||||
acceptExisting = do
|
||||
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
case res of
|
||||
Authenticated uid
|
||||
-> associateUserSchoolsByTerms uid
|
||||
_other
|
||||
-> return ()
|
||||
case res of
|
||||
Authenticated uid
|
||||
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
UniWorX{..} <- getYesod
|
||||
|
||||
flip catches excHandlers $ case appLdapPool of
|
||||
Just ldapPool
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidIdent
|
||||
| CampusUserInvalidEmail
|
||||
| CampusUserInvalidDisplayName
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidSex
|
||||
| CampusUserInvalidFeaturesOfStudy Text
|
||||
| CampusUserInvalidAssociatedSchools Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
|
||||
_upsertCampusUserMode mMode cs@Creds{..}
|
||||
| credsPlugin == "dummy" = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
|
||||
| credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
|
||||
| otherwise = setMode <$> mMode UpsertCampusUser
|
||||
where
|
||||
setMode UpsertCampusUser
|
||||
= cs{ credsPlugin = "LDAP" }
|
||||
setMode (UpsertCampusUserDummy ident)
|
||||
= cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
|
||||
setMode (UpsertCampusUserOther ident)
|
||||
= cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
|
||||
|
||||
others = "PWHash" :| []
|
||||
|
||||
upsertCampusUser :: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
||||
upsertCampusUser plugin ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
|
||||
userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
|
||||
userEmail' = fold $ do
|
||||
k' <- toList ldapUserEmail
|
||||
(k, v) <- ldapData
|
||||
guard $ k' == k
|
||||
return v
|
||||
userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||
userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ]
|
||||
userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ]
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserOther plugin
|
||||
= error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- userIdent''
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
|
||||
-> return userIdent'
|
||||
| Just userIdent' <- plugin ^? _upsertCampusUserIdent
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
userEmail <- if
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userDisplayName' <- if
|
||||
| [bs] <- userDisplayName''
|
||||
, Right userDisplayName' <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidDisplayName
|
||||
userFirstName <- if
|
||||
| [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidGivenName
|
||||
userSurname <- if
|
||||
| [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSurname
|
||||
userTitle <- if
|
||||
| all ByteString.null userTitle'
|
||||
-> return Nothing
|
||||
| [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidTitle
|
||||
userMatrikelnummer <- if
|
||||
| [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| [] <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidMatriculation
|
||||
userSex <- if
|
||||
| [bs] <- userSex'
|
||||
, Right userSex'' <- Text.decodeUtf8' bs
|
||||
, Just userSex''' <- readMay userSex''
|
||||
, Just userSex <- userSex''' ^? iso5218
|
||||
-> return $ Just userSex
|
||||
| [] <- userSex'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSex
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
-- , UserDisplayName =. userDisplayName
|
||||
, UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserTitle =. userTitle
|
||||
, UserEmail =. userEmail
|
||||
, UserSex =. userSex
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
|
||||
|
||||
user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
|
||||
update userId [ UserDisplayName =. userDisplayName' ]
|
||||
|
||||
let
|
||||
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserStudyFeatures
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` CI.mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserFieldName
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
|
||||
userSubTermsSemesters' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSubTermsSemester
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
||||
sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
|
||||
subTermsKeys = unStudyTermsKey . fst <$> sts
|
||||
|
||||
(,) <$> sfKeys ++ subTermsKeys <*> termNames
|
||||
|
||||
let
|
||||
assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures]
|
||||
assimilateSubTerms [] xs = return xs
|
||||
assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
|
||||
standalone <- lift $ get subterm
|
||||
case standalone of
|
||||
_other
|
||||
| (match : matches, unusedFeats') <- partition
|
||||
(\StudyFeatures{..} -> subterm == studyFeaturesField
|
||||
&& subSemester == studyFeaturesSemester
|
||||
) unusedFeats
|
||||
-> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
|
||||
(:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
|
||||
| any ((== subterm) . studyFeaturesField) unusedFeats
|
||||
-> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
|
||||
assimilateSubTerms subterms unusedFeats
|
||||
Just StudyTerms{..}
|
||||
| Just defDegree <- studyTermsDefaultDegree
|
||||
, Just defType <- studyTermsDefaultType
|
||||
-> do
|
||||
$logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
|
||||
(:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
|
||||
Nothing
|
||||
| [] <- unusedFeats -> do
|
||||
$logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
|
||||
tell $ Set.singleton (subterm, Nothing)
|
||||
assimilateSubTerms subterms []
|
||||
_other -> do
|
||||
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
||||
let matchingFeatures = case knownParents of
|
||||
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
||||
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||
if
|
||||
| not $ null knownParents -> do
|
||||
$logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
|
||||
let setSuperField sf = sf
|
||||
& _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
|
||||
& _studyFeaturesField .~ subterm
|
||||
(++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
|
||||
| otherwise -> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
|
||||
assimilateSubTerms subterms unusedFeats
|
||||
$logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
|
||||
(fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
|
||||
|
||||
let
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runConduitPure
|
||||
$ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
|
||||
|
||||
candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
|
||||
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
|
||||
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
|
||||
E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
|
||||
let studyTermNameCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudyTermNameCandidate{..}
|
||||
insertMany_ studyTermCandidates'
|
||||
|
||||
let
|
||||
studySubTermParentCandidates' = do
|
||||
(StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
|
||||
let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudySubTermParentCandidate{..}
|
||||
insertMany_ studySubTermParentCandidates'
|
||||
|
||||
let
|
||||
studyTermStandaloneCandidates' = do
|
||||
(StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
|
||||
let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
|
||||
return StudyTermStandaloneCandidate{..}
|
||||
insertMany_ studyTermStandaloneCandidates'
|
||||
|
||||
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||
oldFs <- selectKeysList
|
||||
[ StudyFeaturesUser ==. studyFeaturesUser
|
||||
, StudyFeaturesDegree ==. studyFeaturesDegree
|
||||
, StudyFeaturesField ==. studyFeaturesField
|
||||
, StudyFeaturesType ==. studyFeaturesType
|
||||
, StudyFeaturesSemester ==. studyFeaturesSemester
|
||||
]
|
||||
[]
|
||||
case oldFs of
|
||||
[oldF] -> update oldF
|
||||
[ StudyFeaturesUpdated =. now
|
||||
, StudyFeaturesValid =. True
|
||||
, StudyFeaturesField =. studyFeaturesField
|
||||
, StudyFeaturesSuperField =. studyFeaturesSuperField
|
||||
]
|
||||
_other -> void $ upsert f
|
||||
[ StudyFeaturesUpdated =. now
|
||||
, StudyFeaturesValid =. True
|
||||
, StudyFeaturesSuperField =. studyFeaturesSuperField
|
||||
]
|
||||
associateUserSchoolsByTerms userId
|
||||
|
||||
let
|
||||
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSchoolAssociation
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
|
||||
|
||||
forM_ ss $ \frag -> void . runMaybeT $ do
|
||||
let
|
||||
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
||||
infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
|
||||
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
||||
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
||||
return schoolLdap
|
||||
Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
|
||||
ssh <- hoistMaybe schoolLdapSchool
|
||||
|
||||
lift . void $ insertUnique UserSchool
|
||||
{ userSchoolUser = userId
|
||||
, userSchoolSchool = ssh
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
forM_ ss $ void . insertUnique . SchoolLdap Nothing
|
||||
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
sfs <- selectList [StudyFeaturesUser ==. uid] []
|
||||
|
||||
forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
|
||||
schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
|
||||
forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
|
||||
void $ insertUnique UserSchool
|
||||
{ userSchoolUser = uid
|
||||
, userSchoolSchool = schoolTermsSchool
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Maybe Lang -> SqlPersistT m (Maybe Lang)
|
||||
updateUserLanguage (Just lang) = do
|
||||
unless (lang `elem` appLanguages) $
|
||||
invalidArgs ["Unsupported language"]
|
||||
|
||||
muid <- maybeAuthId
|
||||
for_ muid $ \uid -> do
|
||||
langs <- languages
|
||||
update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
|
||||
setRegisteredCookie CookieLang lang
|
||||
return $ Just lang
|
||||
updateUserLanguage Nothing = runMaybeT $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
User{..} <- MaybeT $ get uid
|
||||
setLangs <- toList . selectLanguages appLanguages <$> languages
|
||||
highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
|
||||
let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
|
||||
lang <- case (userLanguages', setLangs, highPrioSetLangs) of
|
||||
(_, _, hpl : _)
|
||||
-> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
|
||||
(Just (l : _), _, _)
|
||||
-> return l
|
||||
(Nothing, l : _, _)
|
||||
-> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
|
||||
(Just [], l : _, _)
|
||||
-> return l
|
||||
(_, [], _)
|
||||
-> mzero
|
||||
setRegisteredCookie CookieLang lang
|
||||
return lang
|
||||
|
||||
campusUserFailoverMode :: FailoverMode
|
||||
campusUserFailoverMode = FailoverUnlimited
|
||||
|
||||
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|
||||
90
src/Foundation/Yesod/ErrorHandler.hs
Normal file
90
src/Foundation/Yesod/ErrorHandler.hs
Normal file
@ -0,0 +1,90 @@
|
||||
module Foundation.Yesod.ErrorHandler
|
||||
( errorHandler
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (errorHandler)
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
import Foundation.SiteLayout
|
||||
import Foundation.Routes
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
|
||||
, MonadSecretBox (WidgetFor UniWorX)
|
||||
, BearerAuthSite UniWorX
|
||||
, Button UniWorX ButtonSubmit
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> ErrorResponse -> HandlerFor UniWorX TypedContent
|
||||
errorHandler err = do
|
||||
shouldEncrypt <- do
|
||||
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
|
||||
shouldEncrypt <- getsYesod $ view _appEncryptErrors
|
||||
return $ shouldEncrypt && not canDecrypt
|
||||
|
||||
sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
|
||||
setSessionJson SessionError sessErr
|
||||
|
||||
selectRep $ do
|
||||
provideRep $ do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
|
||||
encrypted plaintextJson plaintext = do
|
||||
if
|
||||
| shouldEncrypt -> 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)}|]
|
||||
siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
||||
toWidget
|
||||
[cassius|
|
||||
.errMsg
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
|]
|
||||
errPage
|
||||
provideRep . fmap PrettyValue $ case err of
|
||||
PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
|
||||
InternalError err'
|
||||
| shouldEncrypt -> do
|
||||
ciphertext <- encodedSecretBox SecretBoxShort err'
|
||||
return $ object [ "message" JSON..= ciphertext
|
||||
, "encrypted" JSON..= True
|
||||
]
|
||||
| otherwise -> return $ object [ "message" JSON..= err' ]
|
||||
InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
|
||||
_other -> return $ object []
|
||||
provideRep $ case err of
|
||||
PermissionDenied err' -> return err'
|
||||
InternalError err'
|
||||
| shouldEncrypt -> do
|
||||
addHeader "Encrypted-Error-Message" "True"
|
||||
encodedSecretBox SecretBoxPretty err'
|
||||
| otherwise -> return err'
|
||||
InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
|
||||
_other -> return Text.empty
|
||||
251
src/Foundation/Yesod/Middleware.hs
Normal file
251
src/Foundation/Yesod/Middleware.hs
Normal file
@ -0,0 +1,251 @@
|
||||
module Foundation.Yesod.Middleware
|
||||
( yesodMiddleware
|
||||
, updateFavourites
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (yesodMiddleware)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Routes
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
|
||||
import Utils.Metrics
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
|
||||
|
||||
|
||||
yesodMiddleware :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> HandlerFor UniWorX res -> HandlerFor UniWorX res
|
||||
yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
|
||||
where
|
||||
dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
dryRunMiddleware handler = do
|
||||
dryRun <- isDryRun
|
||||
if | dryRun -> do
|
||||
hData <- ask
|
||||
prevState <- readIORef (handlerState hData)
|
||||
let
|
||||
restoreSession =
|
||||
modifyIORef (handlerState hData) $
|
||||
\hst -> hst { ghsSession = ghsSession prevState
|
||||
, ghsCache = ghsCache prevState
|
||||
, ghsCacheBy = ghsCacheBy prevState
|
||||
}
|
||||
site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
|
||||
handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
|
||||
|
||||
addCustomHeader HeaderDryRun $ toPathPiece True
|
||||
|
||||
handler' `finally` restoreSession
|
||||
| otherwise -> handler
|
||||
updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX 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
|
||||
lift . updateFavourites $ Just (tid, ssh, csh)
|
||||
_other -> return ()
|
||||
normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX 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 :: HandlerFor UniWorX a -> HandlerFor UniWorX 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_ addMessage') $
|
||||
addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
|
||||
observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
|
||||
csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
csrfMiddleware handler = do
|
||||
hasBearer <- is _Just <$> lookupBearerAuth
|
||||
|
||||
if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
|
||||
| otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
|
||||
where
|
||||
csrfSetCookieMiddleware' handler' = do
|
||||
mcsrf <- reqToken <$> getRequest
|
||||
whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
|
||||
handler'
|
||||
storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
storeBearerMiddleware handler = do
|
||||
askBearer >>= \case
|
||||
Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
|
||||
Nothing -> return ()
|
||||
|
||||
handler
|
||||
|
||||
updateFavourites :: forall m backend.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlBackend backend
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
)
|
||||
=> Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
|
||||
-> ReaderT backend m ()
|
||||
updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
|
||||
$logDebugS "updateFavourites" "Updating favourites"
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- MaybeT $ liftHandler maybeAuthId
|
||||
mcid <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
|
||||
User{userMaxFavourites} <- MaybeT $ get uid
|
||||
|
||||
-- update Favourites
|
||||
for_ mcid $ \cid ->
|
||||
void . lift $ upsertBy
|
||||
(UniqueCourseFavourite uid cid)
|
||||
(CourseFavourite uid cid FavouriteVisited now)
|
||||
[CourseFavouriteLastVisit =. now]
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
|
||||
let deleteFavs = oldFavs
|
||||
& sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
|
||||
& drop userMaxFavourites
|
||||
& filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
|
||||
& map entityKey
|
||||
unless (null deleteFavs) $
|
||||
lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
|
||||
|
||||
|
||||
routeNormalizers :: forall m backend.
|
||||
( BackendCompatible SqlReadBackend backend
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
|
||||
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
|
||||
[ normalizeRender
|
||||
, ncSchool
|
||||
, ncAllocation
|
||||
, ncCourse
|
||||
, ncSheet
|
||||
, ncMaterial
|
||||
, ncTutorial
|
||||
, ncExam
|
||||
, ncExternalExam
|
||||
, verifySubmission
|
||||
, verifyCourseApplication
|
||||
, verifyCourseNews
|
||||
]
|
||||
where
|
||||
normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
||||
normalizeRender route = route <$ do
|
||||
YesodRequest{..} <- liftHandler 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 :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
|
||||
-> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
||||
maybeOrig f route = maybeT (return route) $ f route
|
||||
|
||||
caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
|
||||
caseChanged a b
|
||||
| ((/=) `on` CI.original) a b = do
|
||||
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
|
||||
tell $ Any True
|
||||
| otherwise = return ()
|
||||
|
||||
ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
|
||||
let schoolShort :: SchoolShorthand
|
||||
schoolShort = unSchoolKey ssh
|
||||
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
|
||||
(caseChanged `on` unSchoolKey) ssh ssh'
|
||||
return ssh'
|
||||
ncAllocation = maybeOrig $ \route -> do
|
||||
AllocationR tid ssh ash _ <- return route
|
||||
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
caseChanged ash allocationShorthand
|
||||
return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
|
||||
ncCourse = maybeOrig $ \route -> do
|
||||
CourseR tid ssh csh _ <- return route
|
||||
Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
caseChanged csh courseShorthand
|
||||
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
|
||||
ncSheet = maybeOrig $ \route -> do
|
||||
CSheetR tid ssh csh shn _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
|
||||
caseChanged shn sheetName
|
||||
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
|
||||
ncMaterial = maybeOrig $ \route -> do
|
||||
CMaterialR tid ssh csh mnm _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
|
||||
caseChanged mnm materialName
|
||||
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
|
||||
ncTutorial = maybeOrig $ \route -> do
|
||||
CTutorialR tid ssh csh tutn _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
|
||||
caseChanged tutn tutorialName
|
||||
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
|
||||
ncExam = maybeOrig $ \route -> do
|
||||
CExamR tid ssh csh examn _ <- return route
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
|
||||
caseChanged examn examName
|
||||
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
|
||||
ncExternalExam = maybeOrig $ \route -> do
|
||||
EExamR tid ssh coursen examn _ <- return route
|
||||
Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
|
||||
caseChanged coursen externalExamCourseName
|
||||
caseChanged examn externalExamExamName
|
||||
return $ route
|
||||
& typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
|
||||
& typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
|
||||
verifySubmission = maybeOrig $ \route -> do
|
||||
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
|
||||
sId <- $cachedHereBinary cID $ decrypt cID
|
||||
Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
|
||||
Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
|
||||
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyCourseApplication = maybeOrig $ \route -> do
|
||||
CApplicationR _tid _ssh _csh cID sr <- return route
|
||||
aId <- decrypt cID
|
||||
CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
|
||||
let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyCourseNews = maybeOrig $ \route -> do
|
||||
CNewsR _tid _ssh _csh cID sr <- return route
|
||||
aId <- decrypt cID
|
||||
CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
|
||||
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
44
src/Foundation/Yesod/Persist.hs
Normal file
44
src/Foundation/Yesod/Persist.hs
Normal file
@ -0,0 +1,44 @@
|
||||
module Foundation.Yesod.Persist
|
||||
( runDB, getDBRunner
|
||||
, module Foundation.DB
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (runDB, getDBRunner)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.DB
|
||||
import Foundation.Authorization
|
||||
|
||||
import Database.Persist.Sql (transactionUndo)
|
||||
|
||||
|
||||
runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> YesodDB UniWorX a -> HandlerFor UniWorX a
|
||||
runDB action = do
|
||||
-- stack <- liftIO currentCallStack
|
||||
-- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
|
||||
$logDebugS "YesodPersist" "runDB"
|
||||
dryRun <- isDryRun
|
||||
let action'
|
||||
| dryRun = action <* transactionUndo
|
||||
| otherwise = action
|
||||
|
||||
runSqlPoolRetry action' . appConnPool =<< getYesod
|
||||
|
||||
getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
|
||||
getDBRunner = do
|
||||
(DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
|
||||
return . (, cleanup) $ DBRunner
|
||||
(\action -> do
|
||||
dryRun <- isDryRun
|
||||
let action'
|
||||
| dryRun = action <* transactionUndo
|
||||
| otherwise = action
|
||||
$logDebugS "YesodPersist" "runDBRunner"
|
||||
runDBRunner action'
|
||||
)
|
||||
62
src/Foundation/Yesod/Session.hs
Normal file
62
src/Foundation/Yesod/Session.hs
Normal file
@ -0,0 +1,62 @@
|
||||
module Foundation.Yesod.Session
|
||||
( makeSessionBackend
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (makeSessionBackend)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Web.ServerSession.Core as ServerSession
|
||||
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.HTTP.Types.Header as W
|
||||
import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
|
||||
|
||||
import Web.Cookie
|
||||
|
||||
|
||||
makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
cfg = JwtSession.ServerSessionJwtConfig
|
||||
{ sJwtJwkSet = appJSONWebKeySet
|
||||
, sJwtStart = Nothing
|
||||
, sJwtExpiration = appSessionTokenExpiration
|
||||
, sJwtEncoding = appSessionTokenEncoding
|
||||
, sJwtIssueBy = appInstanceID
|
||||
, sJwtIssueFor = appClusterID
|
||||
}
|
||||
mkBackend :: forall sto.
|
||||
( ServerSession.SessionData sto ~ Map Text ByteString
|
||||
, ServerSession.Storage sto
|
||||
)
|
||||
=> ServerSession.State sto -> IO (Maybe SessionBackend)
|
||||
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
|
||||
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
|
||||
stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
|
||||
sameSite
|
||||
| Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= strictSameSiteSessions
|
||||
| Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= laxSameSiteSessions
|
||||
| otherwise
|
||||
= id
|
||||
notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
||||
notForBearer = fmap $ fmap notForBearer'
|
||||
where notForBearer' :: SessionBackend -> SessionBackend
|
||||
notForBearer' (SessionBackend load)
|
||||
= let load' req
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just . W.extractBearerAuth) aHdrs
|
||||
= return (mempty, const $ return [])
|
||||
| otherwise
|
||||
= load req
|
||||
in SessionBackend load'
|
||||
49
src/Foundation/Yesod/StaticContent.hs
Normal file
49
src/Foundation/Yesod/StaticContent.hs
Normal file
@ -0,0 +1,49 @@
|
||||
module Foundation.Yesod.StaticContent
|
||||
( addStaticContent
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (addStaticContent)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
import Data.Bits (Bits(zeroBits))
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
addStaticContent :: Text
|
||||
-> Text
|
||||
-> Lazy.ByteString
|
||||
-> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
|
||||
addStaticContent ext _mime content = do
|
||||
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
|
||||
let expiry = maybe 0 ceiling memcachedExpiry
|
||||
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
||||
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
||||
catchIf Memcached.isKeyNotFound touch . const $
|
||||
handleIf Memcached.isKeyExists (const $ 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~~ for backwards compatability
|
||||
fileName = (<.> unpack ext)
|
||||
. unpack
|
||||
. decodeUtf8
|
||||
. Base64.encodeUnpadded
|
||||
. (convert :: Digest (SHAKE256 144) -> ByteString)
|
||||
. runConduitPure
|
||||
$ C.sourceLazy content .| sinkHash
|
||||
@ -4,8 +4,6 @@ module Handler.Admin
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
import Handler.Admin.StudyFeatures as Handler.Admin
|
||||
|
||||
@ -47,8 +47,8 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
|
||||
modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
|
||||
|
||||
return $ TestDownloadOptions
|
||||
<$> pure randomSeed
|
||||
<*> maxSizeRes
|
||||
randomSeed
|
||||
<$> maxSizeRes
|
||||
<*> pure (2^20)
|
||||
<*> modeRes
|
||||
|
||||
|
||||
@ -88,7 +88,7 @@ postAdminTokensR = do
|
||||
|
||||
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
|
||||
|
||||
siteLayoutMsg' MsgMenuAdminTokens $ do
|
||||
siteLayoutMsg MsgMenuAdminTokens $ do
|
||||
setTitleI MsgMenuAdminTokens
|
||||
|
||||
let bearerForm = wrapForm bearerView def
|
||||
|
||||
@ -64,7 +64,7 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception ApplicationFormException
|
||||
|
||||
applicationForm :: (Maybe AllocationId)
|
||||
applicationForm :: Maybe AllocationId
|
||||
-> CourseId
|
||||
-> UserId
|
||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||
@ -75,7 +75,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||
course <- getJust cid
|
||||
(fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
(fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||
@ -105,7 +105,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
|
||||
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
||||
(True , True , True , Nothing)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
|
||||
(True , True , True , Just _ )
|
||||
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
||||
(True , True , False, _ )
|
||||
@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
|
||||
filesLinkView <- if
|
||||
| fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
-> let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
-> return Nothing
|
||||
|
||||
filesWarningView <- if
|
||||
| fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
| Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
@ -174,15 +174,15 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
in if
|
||||
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
|
||||
-> return $ (FormSuccess Nothing, Nothing)
|
||||
-> return (FormSuccess Nothing, Nothing)
|
||||
| otherwise
|
||||
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
||||
|
||||
(vetoRes, vetoView) <- if
|
||||
| afmLecturer
|
||||
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
|
||||
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
|
||||
| otherwise
|
||||
-> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
|
||||
-> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
|
||||
|
||||
(pointsRes, pointsView) <- if
|
||||
| afmLecturer
|
||||
@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
, courseApplicationRatingTime = guardOn rated now
|
||||
}
|
||||
|
||||
runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
audit $ TransactionCourseApplicationEdit cid uid appId
|
||||
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
|
||||
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
|
||||
|
||||
@ -139,7 +139,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
addView' = $(widgetFile "course/lecturerMassInput/add")
|
||||
return (addRes'', addView')
|
||||
|
||||
@ -199,10 +199,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
|
||||
_allIOtherCases -> do
|
||||
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
||||
return ( Just (Just now)
|
||||
, (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
||||
return ( Just $ Just now
|
||||
, Just . toMidnight . termStart . entityVal <$> mbLastTerm
|
||||
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
|
||||
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
|
||||
)
|
||||
|
||||
let
|
||||
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
||||
@ -243,7 +244,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
|
||||
let
|
||||
userAdmin = not $ null adminSchools
|
||||
mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
|
||||
mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
|
||||
|
||||
allocationForm' =
|
||||
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
||||
@ -265,8 +266,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
|
||||
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
(cfCourseId =<< template)
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
||||
@ -333,7 +334,7 @@ validateCourse = do
|
||||
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
||||
$ NTop cfRegFrom <= NTop cfRegTo
|
||||
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
||||
$ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
|
||||
$ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
|
||||
unless userAdmin $
|
||||
guardValidation MsgCourseUserMustBeLecturer
|
||||
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
||||
@ -538,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
|
||||
let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
|
||||
|
||||
upsertAllocationCourse cid $ cfAllocation res
|
||||
|
||||
@ -556,7 +557,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
|
||||
upsertAllocationCourse cid cfAllocation = do
|
||||
now <- liftIO getCurrentTime
|
||||
Course{..} <- getJust cid
|
||||
Course{} <- getJust cid
|
||||
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
||||
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
||||
userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
|
||||
|
||||
@ -33,8 +33,8 @@ postCNEditR tid ssh csh cID = do
|
||||
, courseNewsSummary = cnfSummary
|
||||
, courseNewsLastEdit = now
|
||||
}
|
||||
let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ]
|
||||
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
|
||||
let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
|
||||
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
|
||||
addMessageI Success MsgCourseNewsEdited
|
||||
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
|
||||
|
||||
@ -92,11 +92,11 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
|
||||
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
||||
res <- act -- insertUnique
|
||||
|
||||
@ -118,7 +118,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
|
||||
when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
|
||||
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
|
||||
let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -136,7 +136,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
|]
|
||||
in void $ wforced filesLinkField (fslI filesMsg) Nothing
|
||||
|
||||
when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
|
||||
|
||||
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
@ -288,7 +288,7 @@ deregisterParticipant :: UserId -> CourseId -> DB ()
|
||||
deregisterParticipant uid cid = do
|
||||
deleteApplications uid cid
|
||||
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
|
||||
forM_ part $ \(Entity partId CourseParticipant{..}) -> do
|
||||
forM_ part $ \(Entity partId CourseParticipant{}) -> do
|
||||
update partId [CourseParticipantState =. CourseParticipantInactive False]
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
|
||||
@ -112,9 +112,8 @@ getCShowR tid ssh csh = do
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||
|
||||
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
|
||||
<$> pure alloc
|
||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
|
||||
<$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
regForm <- if
|
||||
| is _Just mbAid -> do
|
||||
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
||||
|
||||
@ -115,7 +115,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
|
||||
, formSubmit = FormAutoSubmit
|
||||
, formAnchor = Just registrationFieldFrag
|
||||
}
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
|
||||
formResult regFieldRes $ \courseParticipantField' -> do
|
||||
lift . runDB $ do
|
||||
update pId [ CourseParticipantField =. courseParticipantField' ]
|
||||
|
||||
@ -199,7 +199,7 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
|
||||
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
|
||||
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
|
||||
Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
|
||||
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points
|
||||
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
|
||||
_other -> mempty
|
||||
|
||||
|
||||
@ -404,33 +404,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ sortUserEmail queryUser
|
||||
, single $ sortUserMatriclenr queryUser
|
||||
, sortUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
, single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
E.subSelectMaybe . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||
, single ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
||||
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
||||
return . E.min_ $ tutorial E.^. TutorialName
|
||||
)
|
||||
, single $ ("exams" , SortColumn $ queryUser >>> \user ->
|
||||
, single ("exams" , SortColumn $ queryUser >>> \user ->
|
||||
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||
return . E.min_ $ exam E.^. ExamName
|
||||
)
|
||||
, single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||
, single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||
, mconcat
|
||||
[ single ( SortingKey $ "sheet-" <> sheetName
|
||||
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -450,28 +450,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ fltrUserMatriclenr queryUser
|
||||
, single $ fltrUserNameEmail queryUser
|
||||
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single $ ("field" , FilterColumn $ E.anyFilter
|
||||
, single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single ("field" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
||||
] )
|
||||
, single $ ("degree" , FilterColumn $ E.anyFilter
|
||||
, single ("degree" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||
] )
|
||||
, single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
, single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
||||
)
|
||||
, single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
, single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
@ -480,15 +480,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
)
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||
, single $ ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
|
||||
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
|
||||
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
)
|
||||
, single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||
, single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
|
||||
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
|
||||
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
)
|
||||
]
|
||||
where single = uncurry Map.singleton
|
||||
dbtFilterUI mPrev = mconcat $
|
||||
@ -652,7 +652,7 @@ postCUsersR tid ssh csh = do
|
||||
hasExams = not $ null exams
|
||||
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
|
||||
examOccActs = examOccurrencesPerExam
|
||||
& (map (bimap entityKey hoistMaybe))
|
||||
& map (bimap entityKey hoistMaybe)
|
||||
& Map.fromListWith (<>)
|
||||
& imap (\k v -> case v of
|
||||
[] -> pure (k, Nothing)
|
||||
|
||||
@ -5,6 +5,8 @@ module Handler.CryptoIDDispatch
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..))
|
||||
@ -45,7 +47,7 @@ instance CryptoRoute UUID UserId where
|
||||
(_ :: UserId) <- decrypt cID
|
||||
return $ AdminUserR cID
|
||||
|
||||
class Dispatch ciphertext (x :: [*]) where
|
||||
class Dispatch ciphertext (x :: [Type]) where
|
||||
dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
|
||||
|
||||
instance Dispatch ciphertext '[] where
|
||||
|
||||
@ -65,7 +65,7 @@ postECorrectR tid ssh csh examn = do
|
||||
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
response <- runDB . exceptT (<$ transactionUndo) return $ do
|
||||
Entity eId Exam{..} <- lift $ fetchExam tid ssh csh examn
|
||||
Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
|
||||
euid <- traverse decrypt ciqUser
|
||||
|
||||
guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $
|
||||
|
||||
@ -96,7 +96,7 @@ examForm template html = do
|
||||
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
||||
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
||||
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
||||
<*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
<* aformSection MsgExamFormParts
|
||||
@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let
|
||||
addRes'
|
||||
| otherwise
|
||||
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||
, not $ Set.null existing
|
||||
@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
|
||||
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
||||
let
|
||||
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
|
||||
| any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
|
||||
| any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
|
||||
-> FormFailure [mr MsgExamPartAlreadyExists]
|
||||
| otherwise -> FormSuccess $ pure newDat
|
||||
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
||||
@ -336,10 +336,10 @@ validateExam = do
|
||||
|
||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||||
guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
|
||||
@ -81,10 +81,9 @@ mkExamTable (Entity cid Course{..}) = do
|
||||
|
||||
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamListR tid ssh csh = do
|
||||
(Entity _ Course{..}, examTable) <- runDB $ do
|
||||
examTable <- runDB $ do
|
||||
c <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
(_, examTable) <- mkExamTable c
|
||||
return (c, examTable)
|
||||
view _2 <$> mkExamTable c
|
||||
|
||||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
|
||||
|
||||
@ -36,9 +36,9 @@ instance Button UniWorX ButtonExamRegister where
|
||||
|
||||
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
postERegisterR tid ssh csh examn = do
|
||||
Entity uid User{..} <- requireAuth
|
||||
uid <- requireAuthId
|
||||
|
||||
Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
|
||||
Entity eId Exam{} <- runDB $ fetchExam tid ssh csh examn
|
||||
|
||||
((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister]
|
||||
|
||||
@ -63,11 +63,11 @@ postERegisterR tid ssh csh examn = do
|
||||
|
||||
postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html
|
||||
postERegisterOccR tid ssh csh examn occn = do
|
||||
Entity uid User{..} <- requireAuth
|
||||
(Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do
|
||||
eexam@(Entity eId _) <- fetchExam tid ssh csh examn
|
||||
occ <- getBy404 $ UniqueExamOccurrence eId occn
|
||||
return (eexam, occ)
|
||||
uid <- requireAuthId
|
||||
(eId, occId) <- runDB $ do
|
||||
Entity eId _ <- fetchExam tid ssh csh examn
|
||||
occ <- getKeyBy404 $ UniqueExamOccurrence eId occn
|
||||
return (eId, occ)
|
||||
|
||||
((btnResult, _), _) <- runFormPost buttonForm
|
||||
|
||||
|
||||
@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
sumRegisteredCount = sumOf (folded . _3) occurrences
|
||||
|
||||
noBonus = fromMaybe False $ do
|
||||
noBonus = (Just True ==) $ do
|
||||
guardM $ bonusOnlyPassed <$> examBonusRule
|
||||
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
|
||||
sumPoints = fmap getSum . mconcat $ catMaybes
|
||||
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
|
||||
@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
|
||||
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
||||
|
||||
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
|
||||
$(widgetFile "exam-show")
|
||||
|
||||
@ -598,7 +598,7 @@ postEUsersR tid ssh csh examn = do
|
||||
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
|
||||
when (is _Just examGradingRule) $
|
||||
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
|
||||
when (not $ null examParts) $
|
||||
unless (null examParts) $
|
||||
tell =<< optionsF [ ExamUserSetPartResult ]
|
||||
when doBonus $
|
||||
tell =<< optionsF [ ExamUserSetBonus ]
|
||||
@ -652,7 +652,7 @@ postEUsersR tid ssh csh examn = do
|
||||
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
||||
yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
|
||||
when (newFeatures /= oldFeatures) $
|
||||
@ -694,7 +694,7 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
|
||||
newResults = sequence (csvEUserExamPartResults dbCsvNew)
|
||||
<|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
|
||||
<|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
|
||||
|
||||
newBonus, oldBonus :: Maybe Points
|
||||
newBonus = join (csvEUserBonus dbCsvNew)
|
||||
|
||||
@ -75,7 +75,7 @@ queryIsSynced now office = to . runReader $ do
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
||||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
||||
E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
|
||||
open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed'
|
||||
open examClosed' = E.maybe E.true (E.>. E.val now) examClosed'
|
||||
return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
|
||||
|
||||
|
||||
@ -150,11 +150,9 @@ getEOExamsR = do
|
||||
|
||||
case (exam, course, externalExam) of
|
||||
(Just exam', Just course', Nothing) ->
|
||||
(,,)
|
||||
<$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Nothing, Nothing, Just externalExam') ->
|
||||
(,,)
|
||||
<$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
_other -> return $ error "Got exam & externalExam in same result"
|
||||
|
||||
|
||||
|
||||
@ -78,7 +78,7 @@ postEOFieldsR = do
|
||||
oldFields <- runDB $ do
|
||||
fields <- E.select . E.from $ \examOfficeField -> do
|
||||
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
|
||||
return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
||||
return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
||||
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
|
||||
|
||||
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
|
||||
|
||||
@ -23,7 +23,7 @@ getVersionR = selectRep $ do
|
||||
-- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
|
||||
getLegalR :: Handler Html
|
||||
getLegalR =
|
||||
siteLayoutMsg' MsgMenuLegal $ do
|
||||
siteLayoutMsg MsgMenuLegal $ do
|
||||
setTitleI MsgLegalHeading
|
||||
let dataProtection = $(i18nWidgetFile "data-protection")
|
||||
termsUse = $(i18nWidgetFile "terms-of-use")
|
||||
@ -48,7 +48,7 @@ getInfoR = -- do
|
||||
|
||||
getInfoLecturerR :: Handler Html
|
||||
getInfoLecturerR =
|
||||
siteLayoutMsg' MsgInfoLecturerTitle $ do
|
||||
siteLayoutMsg MsgInfoLecturerTitle $ do
|
||||
setTitleI MsgInfoLecturerTitle
|
||||
$(i18nWidgetFile "info-lecturer")
|
||||
where
|
||||
@ -76,7 +76,7 @@ getInfoLecturerR =
|
||||
|
||||
getGlossaryR :: Handler Html
|
||||
getGlossaryR =
|
||||
siteLayoutMsg' MsgGlossaryTitle $ do
|
||||
siteLayoutMsg MsgGlossaryTitle $ do
|
||||
setTitleI MsgGlossaryTitle
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
@ -137,7 +137,7 @@ faqsWidget mLimit route = do
|
||||
|
||||
getFaqR :: Handler Html
|
||||
getFaqR =
|
||||
siteLayoutMsg' MsgFaqTitle $ do
|
||||
siteLayoutMsg MsgFaqTitle $ do
|
||||
setTitleI MsgFaqTitle
|
||||
|
||||
fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing
|
||||
|
||||
@ -28,6 +28,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Jobs
|
||||
|
||||
import Foundation.Yesod.Auth (updateUserLanguage)
|
||||
|
||||
|
||||
data SettingsForm = SettingsForm
|
||||
{ stgDisplayName :: UserDisplayName
|
||||
|
||||
@ -6,8 +6,6 @@ module Handler.Sheet
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Handler.Sheet.CorrectorInvite as Handler.Sheet (getSCorrInviteR, postSCorrInviteR)
|
||||
import Handler.Sheet.Delete as Handler.Sheet
|
||||
|
||||
@ -5,6 +5,7 @@ module Handler.Sheet.Current
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Utils.Sheet
|
||||
|
||||
|
||||
|
||||
@ -86,7 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
, sheetAutoDistribute = sfAutoDistribute
|
||||
, sheetAnonymousCorrection = sfAnonymousCorrection
|
||||
, sheetRequireExamRegistration = sfRequireExamRegistration
|
||||
, sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF
|
||||
, sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
|
||||
runConduit $
|
||||
maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
|
||||
.| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF)
|
||||
.| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF)
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
@ -127,7 +127,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
return True
|
||||
when saveOkay $
|
||||
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
||||
(FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
||||
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
||||
|
||||
@ -97,7 +97,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
||||
<*> correctorForm (maybe mempty sfCorrectors template)
|
||||
where
|
||||
makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
|
||||
makeSheetPersonalisedFilesForm template' = do
|
||||
@ -162,7 +162,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
||||
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
|
||||
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads
|
||||
|
||||
|
||||
let
|
||||
@ -173,7 +173,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
return user
|
||||
|
||||
miAdd :: ListPosition
|
||||
@ -199,7 +199,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
miCell _ userIdent initRes nudge csrf = do
|
||||
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
||||
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
let
|
||||
res :: FormResult (CorrectorState, Load)
|
||||
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
||||
|
||||
@ -69,7 +69,7 @@ getSheetListR tid ssh csh = do
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
(Just (Entity sid Submission{})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid' <- mkCid
|
||||
|
||||
@ -11,6 +11,8 @@ import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient)
|
||||
import qualified Data.Binary as Binary (encode)
|
||||
import qualified Crypto.KDF.HKDF as HKDF
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
data StorageKeyType
|
||||
= SKTExamCorrect
|
||||
|
||||
@ -25,6 +25,8 @@ import Handler.Submission.Create
|
||||
import Handler.Submission.Grade
|
||||
import Handler.Submission.Upload
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case results of
|
||||
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
||||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||||
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
|
||||
pointsForm = case sheetType of
|
||||
NotGraded
|
||||
-> pure Nothing
|
||||
|
||||
@ -104,7 +104,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
submittorsForm' = maybeT submittorsForm $ do
|
||||
restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
|
||||
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
|
||||
submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
||||
submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
||||
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
|
||||
|
||||
|
||||
@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
guard $ Map.size dat > 1
|
||||
|
||||
-- User may drop from submission only if it already exists; no directly creating submissions for other people
|
||||
guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid
|
||||
guard $ Just (Right uid) /= dat !? delPos || isJust msmid
|
||||
|
||||
miDeleteList dat delPos
|
||||
|
||||
@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
|
||||
corrector <- fmap join $ traverse getEntity submissionRatingBy
|
||||
corrector <- join <$> traverse getEntity submissionRatingBy
|
||||
|
||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
|
||||
|
||||
|
||||
@ -122,7 +122,7 @@ colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnad
|
||||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } ->
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } ->
|
||||
let
|
||||
csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
@ -136,8 +136,8 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
|
||||
| otherwise -> mempty
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
|
||||
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
|
||||
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
| otherwise -> mempty
|
||||
|
||||
@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
|
||||
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
||||
NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
|
||||
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
@ -201,7 +201,7 @@ colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (Form
|
||||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
|
||||
|
||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
@ -398,11 +398,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
||||
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in any (\c -> c `isInfixOf` cid) criteria'
|
||||
in any (`isInfixOf` cid) criteria'
|
||||
)
|
||||
]
|
||||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
|
||||
, dbtParams
|
||||
, dbtIdent = "corrections" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
||||
-- return (tableRes, statistics)
|
||||
|
||||
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||
let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
<&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
||||
|
||||
formResult actionRes $ \case
|
||||
@ -610,7 +610,7 @@ assignAction selId = ( CorrSetCorrector
|
||||
|
||||
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
|
||||
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
|
||||
E.distinct $ return user
|
||||
|
||||
|
||||
@ -57,9 +57,8 @@ postMessageR cID = do
|
||||
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
||||
$ (,)
|
||||
<$> fmap (Entity tId)
|
||||
( SystemMessageTranslation
|
||||
<$> pure systemMessageTranslationMessage
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||
( SystemMessageTranslation systemMessageTranslationMessage
|
||||
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
|
||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
|
||||
)
|
||||
@ -71,9 +70,8 @@ postMessageR cID = do
|
||||
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
|
||||
|
||||
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
||||
$ SystemMessageTranslation
|
||||
<$> pure smId
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||
$ SystemMessageTranslation smId
|
||||
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
|
||||
|
||||
|
||||
@ -43,7 +43,7 @@ tutorialForm cid template html = do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser . Just $ tutUserSuggestions uid) (fslI MsgTutorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let
|
||||
addRes'
|
||||
| otherwise
|
||||
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||
, not $ Set.null existing
|
||||
|
||||
@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCTutorialListR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
let
|
||||
|
||||
@ -16,7 +16,7 @@ import Handler.Tutorial.TutorInvite
|
||||
getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCTutorialNewR = postCTutorialNewR
|
||||
postCTutorialNewR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
|
||||
|
||||
|
||||
@ -74,7 +74,7 @@ getUsersR = postUsersR
|
||||
postUsersR = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
dbtColonnade = mconcat $
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
|
||||
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
(AdminUserR <$> encrypt uid)
|
||||
@ -233,7 +233,7 @@ postUsersR = do
|
||||
formResult allUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
addMessageI Success $ MsgSynchroniseLdapAllUsersQueued
|
||||
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||
redirect UsersR
|
||||
let allUsersWgt' = wrapForm allUsersWgt def
|
||||
{ formSubmit = FormNoSubmit
|
||||
@ -569,7 +569,7 @@ functionInvitationConfig = InvitationConfig{..}
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
|
||||
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
@ -157,3 +157,21 @@ studyFeaturesWidget featId = do
|
||||
|
||||
getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
|
||||
|
||||
|
||||
-- | Conditional redirect that hides the URL if the user is not authorized for the route
|
||||
redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
redirectAccess url = liftHandler $ do
|
||||
-- must hide URL if not authorized
|
||||
access <- isAuthorized url False
|
||||
case access of
|
||||
Authorized -> redirect url
|
||||
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
||||
|
||||
redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
|
||||
redirectAccessWith status url = liftHandler $ do
|
||||
-- must hide URL if not authorized
|
||||
access <- isAuthorized url False
|
||||
case access of
|
||||
Authorized -> redirectWith status url
|
||||
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
||||
|
||||
@ -19,7 +19,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
import qualified Control.Monad.State.Class as State (get, modify')
|
||||
|
||||
import Data.List (genericLength, elemIndex)
|
||||
import Data.List (genericLength)
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Vector.Lens (vector)
|
||||
import qualified Data.Set as Set
|
||||
@ -201,7 +201,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
|
||||
withNumericGrade :: Rational -> Rational
|
||||
withNumericGrade
|
||||
| Just grade' <- grade
|
||||
= let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||
= let numberGrade' = maybe (error "non-passing grade") fromIntegral (elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||
passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
|
||||
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
|
||||
in (+) numericGrade
|
||||
@ -244,7 +244,7 @@ doAllocation :: AllocationId
|
||||
-> DB ()
|
||||
doAllocation allocId now regs =
|
||||
forM_ regs $ \(uid, cid) -> do
|
||||
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
void $ upsert
|
||||
(CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. now
|
||||
|
||||
@ -151,7 +151,7 @@ encodeCsv hdr = do
|
||||
| otherwise
|
||||
= encodeLazyByteString enc . decodeLazyByteString UTF8
|
||||
where enc = csvOpts ^. _csvFormat . _csvEncoding
|
||||
fmap (encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy . recode'
|
||||
C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr
|
||||
|
||||
timestampCsv :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
|
||||
@ -175,7 +175,7 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM
|
||||
]
|
||||
, do
|
||||
guard $ uncurry (/=) amPm
|
||||
guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm]
|
||||
guard . not $ all (all Char.isLower) [fst amPm, snd amPm]
|
||||
Just
|
||||
[ DateTimeFormat "%I:%M %P"
|
||||
, DateTimeFormat "%I:%M:%S %P"
|
||||
|
||||
@ -367,7 +367,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
wordMap = Map.fromListWith (+) wordLengths
|
||||
|
||||
wordIx :: Iso' wordId Int
|
||||
wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords
|
||||
wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords
|
||||
in ix'
|
||||
)
|
||||
(collapsedWords Array.!)
|
||||
@ -477,7 +477,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
||||
bestOption = case rule of
|
||||
ExamRoomSurname -> do
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
|
||||
-- traceM $ show cost
|
||||
return res
|
||||
ExamRoomMatriculation -> do
|
||||
|
||||
@ -34,7 +34,7 @@ sourceFile FileReference{..} = do
|
||||
-> maybeT (throwM SourceFilesContentUnavailable) $ do
|
||||
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
|
||||
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
|
||||
fmap Just . (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
|
||||
fmap Just . hoistMaybe <=< runAppMinio . runMaybeT $ do
|
||||
objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
|
||||
lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
|
||||
| fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent
|
||||
|
||||
@ -15,14 +15,12 @@ import Handler.Utils.Pandoc
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import Handler.Utils.Widgets
|
||||
|
||||
import Handler.Utils.I18n
|
||||
|
||||
import Handler.Utils.Files
|
||||
|
||||
import Import
|
||||
import Data.Char (chr, ord)
|
||||
import Data.Char ( chr, ord, isDigit )
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -55,8 +53,6 @@ import Data.Aeson.Text (encodeToLazyText)
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import Data.Text.Lens (unpacked)
|
||||
|
||||
import Data.Char (isDigit)
|
||||
import Text.Blaze (toMarkup)
|
||||
|
||||
import Handler.Utils.Form.MassInput
|
||||
@ -64,6 +60,8 @@ import Handler.Utils.Form.MassInput
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
----------------------------
|
||||
-- Buttons (new version ) --
|
||||
@ -257,7 +255,7 @@ multiActionField :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiActionField minp acts (actField, actExternal, actMessage) fs@FieldSettings{..} defAction csrf = do
|
||||
multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do
|
||||
(actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction
|
||||
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
|
||||
|
||||
@ -285,15 +283,15 @@ multiActionOpts' :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
|
||||
multiActionOpts' minp acts mActsOpts fs defAction csrf = do
|
||||
actsOpts <- liftHandler mActsOpts
|
||||
let actsOpts' = OptionList
|
||||
{ olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
|
||||
, olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
|
||||
, olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts
|
||||
}
|
||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
|
||||
|
||||
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
||||
actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
||||
actExternal = fmap optionExternalValue . actOption
|
||||
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
||||
|
||||
@ -397,13 +395,13 @@ explainedMultiAction' :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
explainedMultiAction' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
|
||||
explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
|
||||
(actsOpts, actsReadExternal) <- liftHandler mActsOpts
|
||||
let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
|
||||
actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal
|
||||
actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal
|
||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
|
||||
|
||||
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
||||
actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
||||
actExternal = fmap optionExternalValue . actOption
|
||||
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
||||
|
||||
@ -463,7 +461,7 @@ pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
|
||||
pointsField = pointsFieldMinMax (Just 0) Nothing
|
||||
|
||||
pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
|
||||
pointsFieldMax limit = pointsFieldMinMax (Just 0) limit
|
||||
pointsFieldMax = pointsFieldMinMax (Just 0)
|
||||
|
||||
pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
|
||||
pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
|
||||
@ -795,7 +793,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
|
||||
|
||||
let errors
|
||||
| anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
|
||||
| FormSuccess bounds' <- sequence $ map (view _1) bounds
|
||||
| FormSuccess bounds' <- mapM (view _1) bounds
|
||||
, not $ monotone bounds'
|
||||
= [mr MsgPointsMustBeMonotonic]
|
||||
| otherwise
|
||||
@ -967,7 +965,7 @@ genericFileField mkOpts = Field{..}
|
||||
.| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
|
||||
.| C.filter (\(fTitle, _) ->
|
||||
fieldMultiple
|
||||
|| ( (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals)
|
||||
|| ( bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals)
|
||||
&& null files
|
||||
)
|
||||
)
|
||||
@ -1091,7 +1089,7 @@ fileUploadForm isReq mkFs = \case
|
||||
UploadAny{..}
|
||||
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
|
||||
UploadSpecific{..}
|
||||
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
|
||||
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles)
|
||||
where
|
||||
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
|
||||
specificFileForm spec@UploadSpecificFile{..}
|
||||
@ -1445,7 +1443,7 @@ examOccurrenceField :: ( MonadHandler m
|
||||
=> ExamId
|
||||
-> Field m ExamOccurrenceId
|
||||
examOccurrenceField eid
|
||||
= hoistField liftHandler . selectField . (fmap $ fmap entityKey)
|
||||
= hoistField liftHandler . selectField . fmap (fmap entityKey)
|
||||
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
|
||||
|
||||
|
||||
@ -1553,7 +1551,7 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
whenIsJust suggestions $ \suggestions' -> do
|
||||
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
||||
user <- suggestions'
|
||||
return $ ( E.case_
|
||||
return ( E.case_
|
||||
[ E.when_ (unique UserDisplayEmail user)
|
||||
E.then_ (user E.^. UserDisplayEmail)
|
||||
, E.when_ (unique UserEmail user)
|
||||
@ -1768,7 +1766,7 @@ examField :: forall m.
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId
|
||||
examField optMsg cId = hoistField liftHandler . selectField' optMsg . (fmap $ fmap entityKey) $
|
||||
examField optMsg cId = hoistField liftHandler . selectField' optMsg . fmap (fmap entityKey) $
|
||||
optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName
|
||||
|
||||
|
||||
|
||||
@ -37,6 +37,8 @@ import Text.Hamlet (hamletFile)
|
||||
|
||||
import Algebra.Lattice.Ordered (Ordered(..))
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
$(mapM tupleBoxCoord [2..4])
|
||||
|
||||
@ -149,7 +151,7 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
|
||||
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
|
||||
|
||||
|
||||
type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> (BoxCoord liveliness) -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
||||
type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> BoxCoord liveliness -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
||||
|
||||
|
||||
miDeleteList :: MassInputDelete ListLength
|
||||
@ -330,9 +332,9 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
guard $ isn't _FormMissing btnRes
|
||||
res
|
||||
miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
|
||||
addRes'' <- miAdd' & mapped . _Just . _1 %~ wBtnRes
|
||||
addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
|
||||
addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
|
||||
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
|
||||
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
|
||||
case remDims of
|
||||
[] -> return dimRes'
|
||||
((_, BoxDimension dim) : _) -> do
|
||||
@ -373,7 +375,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
delShapeUpdate
|
||||
| [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
|
||||
| otherwise = Nothing
|
||||
delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate
|
||||
delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
|
||||
|
||||
|
||||
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
|
||||
@ -490,7 +492,7 @@ massInputList :: forall handler cellResult ident msg.
|
||||
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
|
||||
massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
|
||||
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
|
||||
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
|
||||
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
|
||||
, miCell = \pos () iRes nudge csrf ->
|
||||
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
|
||||
, miDelete = miDeleteList
|
||||
@ -544,7 +546,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
|
||||
miAdd :: ListPosition -> Natural
|
||||
-> (Text -> Text) -> FieldView UniWorX
|
||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
||||
miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
|
||||
|
||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||
@ -622,7 +624,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
|
||||
miAdd :: ListPosition -> Natural
|
||||
-> (Text -> Text) -> FieldView UniWorX
|
||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
||||
miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
|
||||
|
||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||
|
||||
@ -6,6 +6,7 @@ module Handler.Utils.Form.MassInput.Liveliness
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Web.PathPieces (PathPiece)
|
||||
import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
|
||||
@ -38,7 +39,7 @@ boxDimension n
|
||||
-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
|
||||
|
||||
class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
|
||||
type BoxCoord a :: *
|
||||
type BoxCoord a :: Type
|
||||
liveCoords :: Prism' (Set (BoxCoord a)) a
|
||||
liveCoord :: BoxCoord a -> Prism' Bool a
|
||||
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
|
||||
|
||||
@ -30,7 +30,7 @@ tupleBoxCoord tupleDim = do
|
||||
|
||||
instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
|
||||
[ funD 'boxDimensions
|
||||
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
|
||||
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) $ map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(fieldLenses !! field) . dim) boxDimensions|]) [0..pred tupleDim]) []
|
||||
]
|
||||
, funD 'boxOrigin
|
||||
[ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
|
||||
|
||||
@ -58,7 +58,7 @@ i18nWidgetFilesAvailable' basename = do
|
||||
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
|
||||
fileKinds :: Map Text [Text]
|
||||
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
|
||||
toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds'
|
||||
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
|
||||
|
||||
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
|
||||
|
||||
|
||||
@ -44,19 +44,19 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
|
||||
, Typeable junction
|
||||
) => IsInvitableJunction junction where
|
||||
-- | One side of the junction is always `User`; `InvitationFor junction` is the other
|
||||
type InvitationFor junction :: *
|
||||
type InvitationFor junction :: Type
|
||||
-- | `junction` without `Key User` and `Key (InvitationFor junction)`
|
||||
data InvitableJunction junction :: *
|
||||
data InvitableJunction junction :: Type
|
||||
|
||||
-- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
|
||||
--
|
||||
-- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
|
||||
type InvitationData junction = (dat :: *) | dat -> junction
|
||||
type InvitationData junction = (dat :: Type) | dat -> junction
|
||||
type InvitationData junction = (InvitationDBData junction, InvitationTokenData junction)
|
||||
-- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
|
||||
data InvitationDBData junction :: *
|
||||
data InvitationDBData junction :: Type
|
||||
-- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
|
||||
data InvitationTokenData junction :: *
|
||||
data InvitationTokenData junction :: Type
|
||||
|
||||
_InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
|
||||
|
||||
@ -274,7 +274,7 @@ sourceInvitations :: forall junction m backend.
|
||||
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
||||
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
||||
where
|
||||
decode (Entity _ (Invitation{invitationEmail, invitationData}))
|
||||
decode (Entity _ Invitation{invitationEmail, invitationData})
|
||||
= case fromJSON invitationData of
|
||||
JSON.Success dbData -> return (invitationEmail, dbData)
|
||||
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
|
||||
|
||||
@ -30,7 +30,7 @@ import Crypto.Hash.Algorithms (SHAKE256)
|
||||
|
||||
import qualified Data.ByteArray as BA
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH hiding (Type)
|
||||
|
||||
import Data.Typeable (typeRep)
|
||||
import Type.Reflection (typeOf, TypeRep)
|
||||
@ -52,7 +52,7 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
|
||||
type Expiry = (Either UTCTime DiffTime)
|
||||
type Expiry = Either UTCTime DiffTime
|
||||
|
||||
_MemcachedExpiry :: Prism' Expiry Memcached.Expiry
|
||||
_MemcachedExpiry = prism' fromExpiry toExpiry
|
||||
@ -169,7 +169,7 @@ memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
=> Maybe Expiry -> a -> m ()
|
||||
memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
|
||||
|
||||
memcachedInvalidate :: forall (a :: *) m p.
|
||||
memcachedInvalidate :: forall (a :: Type) m p.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, Typeable a
|
||||
)
|
||||
@ -389,9 +389,9 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lif
|
||||
Nothing -> do
|
||||
startAct <- liftIO newEmptyTMVarIO
|
||||
act' <- async $ do
|
||||
$logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
|
||||
$logDebugS "liftAsyncTimeout" "Waiting for confirmation..."
|
||||
atomically $ takeTMVar startAct
|
||||
$logDebugS "liftAsyncTimeout" $ "Confirmed."
|
||||
$logDebugS "liftAsyncTimeout" "Confirmed."
|
||||
act
|
||||
act'' <- atomically $ do
|
||||
hm <- readTVar memcachedAsync
|
||||
|
||||
@ -31,7 +31,7 @@ import qualified Data.Char as Char
|
||||
|
||||
|
||||
validateRating :: SheetType -> Rating' -> [RatingValidityException]
|
||||
validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
|
||||
validateRating ratingSheetType Rating'{ ratingPoints=Just rp }
|
||||
| rp < 0
|
||||
= [RatingNegative]
|
||||
| NotGraded <- ratingSheetType
|
||||
@ -93,7 +93,7 @@ ratingFile :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> CryptoFileNameSubmission -> Rating -> m File
|
||||
ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
|
||||
ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do
|
||||
mr'@(MsgRenderer mr) <- getMsgRenderer
|
||||
dtFmt <- getDateTimeFormatter
|
||||
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
|
||||
|
||||
@ -29,8 +29,6 @@ import qualified Data.YAML.Event as YAML.Event
|
||||
import qualified Data.YAML.Token as YAML (Encoding(..))
|
||||
import Data.YAML.Aeson () -- ToYAML Value
|
||||
|
||||
import Data.List (elemIndex)
|
||||
|
||||
import Control.Monad.Trans.State.Lazy (evalState)
|
||||
|
||||
import qualified System.FilePath.Cryptographic as Explicit
|
||||
|
||||
@ -169,7 +169,7 @@ planSubmissions sid restriction = do
|
||||
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
|
||||
oldSubmissionData = Map.withoutKeys submissionData targetSubmissions
|
||||
|
||||
whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing ->
|
||||
whenIsJust (fromNullable . (`Set.difference` targetSubmissions) =<< restriction) $ \missing ->
|
||||
throwM $ SubmissionsNotFound missing
|
||||
|
||||
let
|
||||
@ -236,7 +236,7 @@ planSubmissions sid restriction = do
|
||||
| otherwise
|
||||
= Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
|
||||
|
||||
when (not $ null acceptableCorrectors) $ do
|
||||
unless (null acceptableCorrectors) $ do
|
||||
deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
|
||||
let
|
||||
bestCorrectors :: Set UserId
|
||||
@ -320,7 +320,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
|
||||
let
|
||||
fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
|
||||
fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
@ -574,7 +574,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
sinkSubmission' :: SubmissionId
|
||||
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
|
||||
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||||
Left file@(FileReference{..}) -> do
|
||||
Left file@FileReference{..} -> do
|
||||
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
|
||||
|
||||
alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
|
||||
@ -591,7 +591,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
, submissionFileIsUpdate sf == isUpdate
|
||||
]
|
||||
underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
|
||||
, submissionFileIsUpdate sf == False
|
||||
, not (submissionFileIsUpdate sf)
|
||||
]
|
||||
anyChanges
|
||||
| not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
|
||||
@ -658,7 +658,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
--
|
||||
-- 'fileModified' is simply stored and never inspected while
|
||||
-- 'submissionChanged' is always set to @now@.
|
||||
let anyChanges = any (\f -> f submission submission') $
|
||||
let anyChanges = any (\f -> f submission submission')
|
||||
[ (/=) `on` submissionRatingPoints
|
||||
, (/=) `on` submissionRatingComment
|
||||
, (/=) `on` submissionRatingDone
|
||||
@ -675,7 +675,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
|
||||
tellSt mempty { sinkSubmissionNotifyRating = Any True }
|
||||
lift $ replace submissionId submission'
|
||||
sheetId <- lift $ getSheetId
|
||||
sheetId <- lift getSheetId
|
||||
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
|
||||
where
|
||||
a /~ b = not $ a ~~ b
|
||||
@ -699,14 +699,14 @@ sinkSubmission userId mExists isUpdate = do
|
||||
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
|
||||
touchSubmission = do
|
||||
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
||||
when (not alreadyTouched) $ do
|
||||
unless alreadyTouched $ do
|
||||
now <- liftIO getCurrentTime
|
||||
case isUpdate of
|
||||
False -> lift . insert_ $ SubmissionEdit userId now submissionId
|
||||
True -> do
|
||||
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
||||
when (is _Just submissionRatingTime) $
|
||||
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
||||
if
|
||||
| isUpdate -> do
|
||||
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
||||
when (is _Just submissionRatingTime) $
|
||||
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
||||
| otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
|
||||
tellSt $ mempty{ sinkSubmissionTouched = Any True }
|
||||
|
||||
getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
|
||||
@ -720,15 +720,36 @@ sinkSubmission userId mExists isUpdate = do
|
||||
finalize SubmissionSinkState{..} = do
|
||||
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
||||
when (not isUpdate) $
|
||||
unless isUpdate $
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
||||
E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||||
|
||||
return sf
|
||||
|
||||
case isUpdate of
|
||||
False -> do
|
||||
if
|
||||
| isUpdate -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
|
||||
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
||||
|
||||
if
|
||||
| not shadowing -> do
|
||||
delete sfId
|
||||
audit $ TransactionSubmissionFileDelete sfId submissionId
|
||||
| submissionFileIsUpdate -> do
|
||||
update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
||||
audit $ TransactionSubmissionFileEdit sfId submissionId
|
||||
| otherwise -> do
|
||||
now <- liftIO getCurrentTime
|
||||
sfId' <- insert $ SubmissionFile
|
||||
{ submissionFileSubmission = submissionId
|
||||
, submissionFileTitle
|
||||
, submissionFileModified = now
|
||||
, submissionFileContent = Nothing
|
||||
, submissionFileIsUpdate = True
|
||||
, submissionFileIsDeletion = True
|
||||
}
|
||||
audit $ TransactionSubmissionFileEdit sfId' submissionId
|
||||
| otherwise -> do
|
||||
shadowed <- selectKeysList
|
||||
[ SubmissionFileSubmission ==. submissionId
|
||||
, SubmissionFileIsUpdate ==. False
|
||||
@ -737,27 +758,6 @@ sinkSubmission userId mExists isUpdate = do
|
||||
forM_ shadowed $ \sfId' -> do
|
||||
delete sfId'
|
||||
audit $ TransactionSubmissionFileDelete sfId' submissionId
|
||||
True -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
|
||||
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
||||
|
||||
if
|
||||
| not shadowing -> do
|
||||
delete sfId
|
||||
audit $ TransactionSubmissionFileDelete sfId submissionId
|
||||
| submissionFileIsUpdate -> do
|
||||
update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
||||
audit $ TransactionSubmissionFileEdit sfId submissionId
|
||||
| otherwise -> do
|
||||
now <- liftIO getCurrentTime
|
||||
sfId' <- insert $ SubmissionFile
|
||||
{ submissionFileSubmission = submissionId
|
||||
, submissionFileTitle
|
||||
, submissionFileModified = now
|
||||
, submissionFileContent = Nothing
|
||||
, submissionFileIsUpdate = True
|
||||
, submissionFileIsDeletion = True
|
||||
}
|
||||
audit $ TransactionSubmissionFileEdit sfId' submissionId
|
||||
|
||||
if
|
||||
| isUpdate
|
||||
@ -833,7 +833,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
| otherwise = return Nothing
|
||||
Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
|
||||
return (msId, fp)
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
||||
(msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
||||
case msId of
|
||||
Nothing -> do
|
||||
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
|
||||
@ -842,7 +842,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
cID <- encrypt sId
|
||||
lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
|
||||
feed sId $ Left f{ fileReferenceTitle = fileTitle' }
|
||||
when (not $ null ignoredFiles) $ do
|
||||
unless (null ignoredFiles) $ do
|
||||
mr <- (toHtml .) <$> getMessageRender
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
|
||||
@ -903,7 +903,7 @@ submissionDeleteRoute drRecords = DeleteRoute
|
||||
uid <- maybeAuthId
|
||||
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
|
||||
if
|
||||
| length subUsers >= 1
|
||||
| not $ null subUsers
|
||||
, maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
|
||||
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
|
||||
| otherwise
|
||||
|
||||
@ -302,8 +302,8 @@ sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryN
|
||||
colApplicationId :: OpticColonnade CourseApplicationId
|
||||
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
|
||||
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
|
||||
header = Sortable Nothing $ i18nCell MsgCourseApplicationId
|
||||
body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId
|
||||
|
||||
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
||||
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
||||
|
||||
@ -54,7 +54,6 @@ import Handler.Utils.Form
|
||||
import Handler.Utils.Csv
|
||||
import Handler.Utils.ContentDisposition
|
||||
import Handler.Utils.I18n
|
||||
import Handler.Utils.Widgets
|
||||
import Utils
|
||||
import Utils.Lens
|
||||
|
||||
@ -92,7 +91,7 @@ import Colonnade.Encode hiding (row)
|
||||
|
||||
import Text.Hamlet (hamletFile)
|
||||
|
||||
import Data.List (elemIndex, inits)
|
||||
import Data.List (inits)
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
@ -450,7 +449,7 @@ instance Traversable DBRow where
|
||||
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
|
||||
instance Default (PSValidator m x) where
|
||||
def = PSValidator $ \DBTable{..} -> \case
|
||||
def = PSValidator $ \DBTable{} -> \case
|
||||
Nothing -> def
|
||||
Just pi -> swap . (\act -> execRWS act pi def) $ do
|
||||
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
|
||||
@ -665,12 +664,12 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
|
||||
}
|
||||
|
||||
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
|
||||
data DBParams m x :: *
|
||||
type DBResult m x :: *
|
||||
-- type DBResult' m x :: *
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
|
||||
data DBParams m x :: Type
|
||||
type DBResult m x :: Type
|
||||
-- type DBResult' m x :: Type
|
||||
|
||||
data DBCell m x :: *
|
||||
data DBCell m x :: Type
|
||||
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
|
||||
@ -10,6 +10,7 @@ module Handler.Utils.Users
|
||||
|
||||
import Import
|
||||
import Auth.LDAP (campusUserMatr')
|
||||
import Foundation.Yesod.Auth (upsertCampusUser)
|
||||
|
||||
import Crypto.Hash (hashlazy)
|
||||
|
||||
@ -156,14 +157,14 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
|
||||
if
|
||||
| x : [] <- users'
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
-> return $ Just $ Right x
|
||||
| x : x' : _ <- users'
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
, GT <- x `closeness` x'
|
||||
-> return $ Just $ Right x
|
||||
| xs@(x:_:_) <- takeClosest users'
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
-> return $ Just $ Left $ NonEmpty.fromList xs
|
||||
| not didLdap
|
||||
, userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
|
||||
|
||||
@ -148,12 +148,6 @@ invDualCoHeat :: ( Real a, Real b, Real c )
|
||||
-- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
|
||||
invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
|
||||
|
||||
i18n :: forall m msg.
|
||||
( MonadWidget m
|
||||
, RenderMessage (HandlerSite m) msg
|
||||
) => msg -> m ()
|
||||
i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
|
||||
|
||||
|
||||
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
|
||||
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
|
||||
|
||||
@ -39,6 +39,7 @@ import Utils as Import
|
||||
import Utils.Frontend.I18n as Import
|
||||
import Utils.DB as Import
|
||||
import Utils.Sql as Import
|
||||
import Utils.Widgets as Import
|
||||
|
||||
import Data.Fixed as Import
|
||||
|
||||
@ -60,6 +61,7 @@ import GHC.Exts as Import (IsList)
|
||||
import Data.Ix as Import (Ix)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List as Import (elemIndex)
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Min(..), Max(..))
|
||||
@ -78,6 +80,8 @@ import Database.Persist.Sql as Import (SqlReadBackend, SqlReadT, SqlWriteT, IsSq
|
||||
|
||||
import Ldap.Client.Pool as Import
|
||||
|
||||
import Control.Monad as Import (zipWithM)
|
||||
|
||||
import System.Random as Import (Random(..))
|
||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||
|
||||
@ -167,6 +171,7 @@ import Network.Minio.Instances as Import ()
|
||||
import System.Clock.Instances as Import ()
|
||||
import Data.Word.Word24.Instances as Import ()
|
||||
import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
|
||||
import Database.Persist.Sql.Types.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
|
||||
import Crypto.Random as Import (ChaChaDRG, Seed)
|
||||
@ -189,6 +194,8 @@ import GHC.TypeLits as Import (KnownSymbol)
|
||||
|
||||
import Data.Word.Word24 as Import
|
||||
|
||||
import Data.Kind as Import (Type, Constraint)
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
|
||||
@ -493,7 +493,7 @@ jLocked jId act = do
|
||||
liftIO . atomically $ writeTVar hasLock True
|
||||
return val
|
||||
|
||||
unlock = whenM (liftIO . atomically $ readTVar hasLock) $
|
||||
unlock = whenM (readTVarIO hasLock) $
|
||||
runDB . setSerializable $
|
||||
update jId [ QueuedJobLockInstance =. Nothing
|
||||
, QueuedJobLockTime =. Nothing
|
||||
|
||||
@ -27,7 +27,7 @@ import qualified Database.Esqueleto as E
|
||||
determineCrontab :: DB (Crontab JobCtl)
|
||||
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
|
||||
determineCrontab = execWriterT $ do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
|
||||
|
||||
case appJobFlushInterval of
|
||||
Just interval -> tell $ HashMap.singleton
|
||||
@ -354,7 +354,7 @@ determineCrontab = execWriterT $ do
|
||||
|
||||
|
||||
let
|
||||
externalExamJobs (Entity nExternalExam ExternalExam{..}) = do
|
||||
externalExamJobs nExternalExam = do
|
||||
newestResult <- lift . E.select . E.from $ \externalExamResult -> do
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
|
||||
return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
|
||||
@ -371,7 +371,7 @@ determineCrontab = execWriterT $ do
|
||||
}
|
||||
_other -> return ()
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalExamJobs
|
||||
runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
|
||||
|
||||
let
|
||||
allocationJobs (Entity nAllocation Allocation{..}) = do
|
||||
|
||||
@ -20,7 +20,7 @@ import qualified Data.Text as Text
|
||||
|
||||
dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler ()
|
||||
dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}, initiator, coSubmittors) <- liftHandler . runDB $ do
|
||||
(Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do
|
||||
submission <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
@ -55,7 +55,7 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai
|
||||
|
||||
dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler ()
|
||||
dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do
|
||||
(User{..}, Course{..}, Sheet{..}, Submission{..}, coSubmittors) <- liftHandler . runDB $ do
|
||||
(User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do
|
||||
submission <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
|
||||
@ -8,6 +8,7 @@ import Import
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Auth.LDAP
|
||||
import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
@ -38,7 +39,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
|
||||
|
||||
dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
|
||||
dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
UniWorX{..} <- getYesod
|
||||
case appLdapPool of
|
||||
Just ldapPool ->
|
||||
runDB . void . runMaybeT . handleExc $ do
|
||||
|
||||
@ -38,6 +38,8 @@ module Mail
|
||||
|
||||
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
|
||||
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Model.Types.Languages
|
||||
|
||||
import Network.Mail.Mime hiding (addPart, addAttachment)
|
||||
@ -231,7 +233,7 @@ instance Exception MailException
|
||||
|
||||
class Yesod site => YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
|
||||
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
||||
|
||||
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
mailObjectIdDomain = pack <$> liftIO getHostName
|
||||
@ -325,7 +327,7 @@ instance Monoid (PrioritisedAlternatives m) where
|
||||
mappend = (<>)
|
||||
|
||||
class YesodMail site => ToMailPart site a where
|
||||
type MailPartReturn site a :: *
|
||||
type MailPartReturn site a :: Type
|
||||
type MailPartReturn site a = ()
|
||||
toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
|
||||
|
||||
|
||||
@ -105,17 +105,17 @@ requiresMigration :: forall m.
|
||||
=> ReaderT SqlBackend m Bool
|
||||
requiresMigration = mapReaderT (exceptT return return) $ do
|
||||
initial <- either id (map snd) <$> parseMigration initialMigration
|
||||
when (not $ null initial) $ do
|
||||
unless (null initial) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " initial
|
||||
throwError True
|
||||
|
||||
customs <- mapReaderT lift $ getMissingMigrations @_ @m
|
||||
when (not $ Map.null customs) $ do
|
||||
unless (Map.null customs) $ do
|
||||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||||
throwError True
|
||||
|
||||
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
||||
when (not $ null automatic) $ do
|
||||
unless (null automatic) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " automatic
|
||||
throwError True
|
||||
|
||||
@ -188,7 +188,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
other -> error $ "Could not parse theme: " <> show other
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
|
||||
, whenM (tableExists "sheet") $ -- Better JSON encoding
|
||||
, whenM (tableExists "sheet") -- Better JSON encoding
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
|
||||
ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
|
||||
@ -265,13 +265,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
_other -> error "Empty userDisplayName found"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
||||
, whenM (tableExists "sheet") $
|
||||
, whenM (tableExists "sheet")
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
|
||||
, whenM (columnExists "user" "plugin") $
|
||||
, whenM (columnExists "user" "plugin")
|
||||
-- <> is standard sql for /=
|
||||
[executeQQ|
|
||||
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
|
||||
@ -280,7 +280,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
|
||||
, whenM (tableExists "user") $
|
||||
, whenM (tableExists "user")
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
|
||||
|]
|
||||
@ -291,13 +291,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
|
||||
, whenM (tableExists "cluster_config") $
|
||||
, whenM (tableExists "cluster_config")
|
||||
[executeQQ|
|
||||
UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|]
|
||||
, whenM (tableExists "sheet") $
|
||||
, whenM (tableExists "sheet")
|
||||
[executeQQ|
|
||||
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
|
||||
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
|
||||
@ -315,10 +315,10 @@ customMigrations = Map.fromListWith (>>)
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
|
||||
, do
|
||||
whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
|
||||
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
|
||||
@ -388,7 +388,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
|
||||
|]
|
||||
|
||||
whenM (tableExists "user") $
|
||||
whenM (tableExists "user")
|
||||
[executeQQ|
|
||||
UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
|
||||
|]
|
||||
@ -572,13 +572,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|]
|
||||
, whenM (tableExists "exam") $
|
||||
, whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
|
||||
, whenM (tableExists "course_favourite") $
|
||||
, whenM (tableExists "course_favourite")
|
||||
[executeQQ|
|
||||
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
|
||||
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
||||
@ -596,7 +596,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
_other -> error "Cannot reconstruct course_participant.allocated"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
|
||||
, whenM (tableExists "allocation") $
|
||||
, whenM (tableExists "allocation")
|
||||
[executeQQ|
|
||||
CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL);
|
||||
INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null));
|
||||
@ -605,7 +605,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
|
||||
, whenM (tableExists "user") $
|
||||
, whenM (tableExists "user")
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
|
||||
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
|
||||
@ -617,7 +617,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
tableDropEmpty "exam_part_corrector"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
|
||||
, whenM (tableExists "study_features") $
|
||||
, whenM (tableExists "study_features")
|
||||
[executeQQ|
|
||||
ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
|
||||
UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
|
||||
@ -625,7 +625,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|]
|
||||
, whenM (tableExists "exam") $
|
||||
, whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
|
||||
ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
|
||||
@ -640,7 +640,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|]
|
||||
, whenM (tableExists "exam") $
|
||||
, whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
|
||||
UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
||||
@ -650,7 +650,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|]
|
||||
, whenM (tableExists "external_exam") $
|
||||
, whenM (tableExists "external_exam")
|
||||
[executeQQ|
|
||||
ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
|
||||
UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
||||
@ -849,7 +849,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log";
|
||||
|]
|
||||
|
||||
whenM (tableExists "session_file") $
|
||||
whenM (tableExists "session_file")
|
||||
[executeQQ|
|
||||
ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
|
||||
UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");
|
||||
|
||||
@ -59,6 +59,8 @@ import qualified Data.Foldable
|
||||
|
||||
import Data.Aeson (genericToJSON, genericParseJSON)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
data ExamResult' res = ExamAttended { examResult :: res }
|
||||
| ExamNoShow
|
||||
@ -170,7 +172,7 @@ derivePersistFieldJSON ''ExamOccurrenceRule
|
||||
makePrisms ''ExamOccurrenceRule
|
||||
|
||||
examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
|
||||
examOccurrenceRuleAutomatic x = or $ map ($ x)
|
||||
examOccurrenceRuleAutomatic x = any ($ x)
|
||||
[ is _ExamRoomSurname
|
||||
, is _ExamRoomMatriculation
|
||||
, is _ExamRoomRandom
|
||||
|
||||
@ -28,7 +28,7 @@ makeLenses_ ''FileReference
|
||||
|
||||
|
||||
class HasFileReference record where
|
||||
data FileReferenceResidual record :: *
|
||||
data FileReferenceResidual record :: Type
|
||||
|
||||
_FileReference :: Iso' record (FileReference, FileReferenceResidual record)
|
||||
|
||||
|
||||
@ -162,7 +162,7 @@ instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
|
||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
||||
|
||||
instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
|
||||
toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
|
||||
toPathPiece = Text.unwords . map (Text.intercalate "AND" . map toPathPiece . otoList) . otoList . dnfTerms
|
||||
fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
|
||||
|
||||
type AuthLiteral = PredLiteral AuthTag
|
||||
|
||||
@ -21,7 +21,7 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
import Data.List (elemIndex, genericIndex)
|
||||
import Data.List (genericIndex)
|
||||
import Data.Bits
|
||||
import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
@ -118,7 +118,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
|
||||
|
||||
pseudonymWords :: Fold Text PseudonymWord
|
||||
pseudonymWords = folding
|
||||
$ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||
$ \(CI.mk -> input) -> maybe [] (map (view _2)) . listToMaybe . groupBy ((==) `on` view _1) . sortOn (view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||
where
|
||||
distance = damerauLevenshtein `on` CI.foldedCase
|
||||
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
||||
|
||||
@ -420,7 +420,7 @@ instance FromJSON AppSettings where
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
|
||||
[ not $ null connectHost
|
||||
, numConnection > 0
|
||||
, connectionIdleTime >= 0
|
||||
@ -587,3 +587,10 @@ compileTimeAppSettings =
|
||||
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
|
||||
Aeson.Error e -> error e
|
||||
Aeson.Success settings -> settings
|
||||
|
||||
|
||||
getTimeLocale' :: [Lang] -> TimeLocale
|
||||
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
|
||||
|
||||
appTZ :: TZ
|
||||
appTZ = $(includeSystemTZ "Europe/Berlin")
|
||||
|
||||
@ -8,6 +8,8 @@ module Settings.Cluster
|
||||
import ClassyPrelude.Yesod
|
||||
import Web.HttpApiData
|
||||
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Utils
|
||||
import Data.Universe
|
||||
|
||||
@ -59,7 +61,7 @@ instance FromHttpApiData ClusterSettingsKey where
|
||||
|
||||
|
||||
class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
|
||||
type ClusterSettingValue key :: *
|
||||
type ClusterSettingValue key :: Type
|
||||
initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
|
||||
knownClusterSetting :: forall p. p key -> ClusterSettingsKey
|
||||
|
||||
|
||||
@ -142,7 +142,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do
|
||||
[ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) []
|
||||
| fName <- Set.toList fileNames
|
||||
]
|
||||
, funD 'fromPathMultiPiece $
|
||||
, funD 'fromPathMultiPiece
|
||||
[ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
|
||||
]
|
||||
]
|
||||
|
||||
15
src/Utils.hs
15
src/Utils.hs
@ -51,6 +51,7 @@ import Control.Lens as Utils (none)
|
||||
import Control.Lens.Extras (is)
|
||||
import Data.Set.Lens
|
||||
|
||||
import Control.Monad (zipWithM)
|
||||
import Control.Arrow as Utils ((>>>))
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
@ -154,8 +155,8 @@ maybeAttribute a c (Just v) = [(a,c v)]
|
||||
|
||||
|
||||
newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
|
||||
deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
|
||||
|
||||
instance ToContent PrettyValue where
|
||||
toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
|
||||
@ -169,8 +170,8 @@ toPrettyJSON = PrettyValue . toJSON
|
||||
|
||||
|
||||
newtype YamlValue = YamlValue { unYamlValue :: Value }
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
|
||||
deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
|
||||
|
||||
instance ToContent YamlValue where
|
||||
toContent = toContent . Yaml.encode
|
||||
@ -182,7 +183,6 @@ instance HasContentType YamlValue where
|
||||
toYAML :: ToJSON a => a -> YamlValue
|
||||
toYAML = YamlValue . toJSON
|
||||
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
---------------------
|
||||
@ -723,7 +723,7 @@ shortCircuitM sc binOp mx my = do
|
||||
x <- mx
|
||||
if
|
||||
| sc x -> return x
|
||||
| otherwise -> binOp <$> pure x <*> my
|
||||
| otherwise -> binOp x <$> my
|
||||
|
||||
|
||||
guardM :: MonadPlus m => m Bool -> m ()
|
||||
@ -1193,8 +1193,7 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
|
||||
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
|
||||
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
|
||||
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
|
||||
fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
|
||||
zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
||||
fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
||||
where
|
||||
uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
|
||||
uc = unsafeCoerce
|
||||
|
||||
@ -20,7 +20,7 @@ import Control.Monad.Writer (tell)
|
||||
|
||||
import Control.Monad.ST
|
||||
|
||||
import Data.List ((!!), elemIndex)
|
||||
import Data.List ((!!))
|
||||
|
||||
|
||||
type CourseIndex = Int
|
||||
@ -127,11 +127,11 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
|
||||
(newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||
|
||||
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
|
||||
isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
|
||||
isUnstableWith cn' (stO, cnO) = Just True == (do
|
||||
c' <- matchingCourse st cn'
|
||||
rMe <- courseRating c' (st, cn')
|
||||
rOther <- courseRating c' (stO, cnO)
|
||||
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))
|
||||
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO)))
|
||||
|
||||
if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
|
||||
-> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
|
||||
|
||||
@ -24,51 +24,51 @@ emptyOrIn criterion testSet
|
||||
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
|
||||
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
|
||||
|
||||
getJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
=> Unique record -> ReaderT backend m (Entity record)
|
||||
getJustBy u = getBy u >>= maybe
|
||||
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
||||
return
|
||||
|
||||
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
getKeyBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m (Maybe (Key record))
|
||||
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
||||
|
||||
getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyJustBy u = getKeyBy u >>= maybe
|
||||
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
||||
return
|
||||
|
||||
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
|
||||
getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
||||
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
|
||||
=> Key val -> ReaderT backend m (Entity val)
|
||||
getEntity404 k = Entity <$> pure k <*> get404 k
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
|
||||
=> Key record -> ReaderT backend m (Entity record)
|
||||
getEntity404 k = Entity k <$> get404 k
|
||||
|
||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
existsBy = fmap (is _Just) . getKeyBy
|
||||
|
||||
existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
|
||||
existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m ()
|
||||
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
|
||||
|
||||
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
|
||||
existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> Key record -> ReaderT backend m Bool
|
||||
existsKey = exists . pure . (persistIdField ==.)
|
||||
|
||||
exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
|
||||
exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> [Filter record] -> ReaderT backend m Bool
|
||||
exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
|
||||
|
||||
exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
|
||||
exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
||||
=> [Filter record] -> ReaderT backend m ()
|
||||
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
|
||||
|
||||
existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
|
||||
existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
||||
=> Key record -> ReaderT backend m ()
|
||||
existsKey404 = bool notFound (return ()) <=< existsKey
|
||||
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user