fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 205-klausuren

Browse Source
This commit is contained in:
Gregor Kleen 2019-09-25 14:10:52 +02:00
commit 9569c4f026
131 changed files with 1092 additions and 1129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
README.md
View File

@ -5,6 +5,14 @@ The following description applies to Ubuntu and similar debian based Linux distr
## Prerequisites
These are the things you need to do/install before you can get started working on Uni2work.
### Install german locale
You will need to install the german locale at compile time.
Install:
- Edit `/etc/locale.gen` as root and uncomment/add the line `de_DE.UTF-8 UTF-8`
- Save the file and run `sudo locale-gen`
### Clone repository
Clone this repository and navigate into it
```sh
@ -41,7 +49,7 @@ You'll get a prompt:
```sh
Enter name of role to add: uniworx
Shall the new role be a superuser? (y/n) [not exactly sure. Guess not?]
Shall the new role be a superuser? (y/n) y [user must be superuser to create extensions]
Password: uniworx
...
```
@ -89,18 +97,6 @@ $ sudo apt-get install pkg-config
$ sudo apt-get install libsodium-dev
```
Build the app:
```sh
$ stack build
```
This might take a few minutes... if not hours... be prepared.
install yesod:
```sh
$ stack install yesod-bin --install-ghc
```
### `Node` & `npm`
Node and Npm are needed to compile the frontend.
@ -110,6 +106,18 @@ $ curl -sL https://deb.nodesource.com/setup_12.x | sudo -E bash -
$ sudo apt-get install -y nodejs
```
Build the app:
```sh
$ npm run build
```
This might take a few minutes... if not hours... be prepared.
install yesod:
```sh
$ stack install yesod-bin --install-ghc
```
### Add dummy data to the database
After building the app you can prepare the database and add some dummy data:
```sh
@ -118,7 +126,7 @@ $ ./db.sh -f
## Run Uni2work
```sh
$ npm start
$ npm run start
```
This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary.

4
nixpkgs.nix
View File

@ -4,6 +4,6 @@
import ((nixpkgs {}).fetchFromGitHub {
owner = "NixOS";
repo = "nixpkgs";
rev = "19.03";
sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy";
rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf";
sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm";
})

12
package-lock.json generated
View File

@ -7702,9 +7702,9 @@
"dev": true
},
"handlebars": {
"version": "4.1.2",
"resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz",
"integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==",
"version": "4.3.1",
"resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz",
"integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==",
"dev": true,
"requires": {
"neo-async": "^2.6.0",
@ -15623,9 +15623,9 @@
"dev": true
},
"uglify-js": {
"version": "3.5.15",
"resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz",
"integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==",
"version": "3.6.0",
"resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz",
"integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==",
"dev": true,
"optional": true,
"requires": {

2
package.json
View File

@ -14,7 +14,9 @@
"yesod:start": "./start.sh",
"yesod:lint": "./hlint.sh",
"yesod:test": "./test.sh",
"yesod:test:watch": "./test.sh --file-watch",
"yesod:build": "./build.sh",
"yesod:build:watch": "./build.sh --file-watch",
"frontend:lint": "eslint frontend/src",
"frontend:test": "karma start --conf karma.conf.js",
"frontend:test:watch": "karma start --conf karma.conf.js --single-run false",

54
package.yaml
View File

@ -2,40 +2,38 @@ name: uniworx
version: 6.11.1
dependencies:
# Due to a bug in GHC 8.0.1, we block its usage
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
# version 1.0 had a bug in reexporting Handler, causing trouble
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
- foreign-store
- yesod >=1.4.3 && <1.5
- yesod-core >=1.4.30 && <1.5
- yesod-auth >=1.4.0 && <1.5
- yesod-static >=1.4.0.3 && <1.6
- yesod-form >=1.4.0 && <1.5
- classy-prelude >=0.10.2
- classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11
- base >=4.9.1.0 && <5
- yesod >=1.6 && <1.7
- yesod-core >=1.6 && <1.7
- yesod-auth >=1.6 && <1.7
- yesod-static >=1.6 && <1.7
- yesod-form >=1.6 && <1.7
- classy-prelude >=1.5 && <1.6
- classy-prelude-conduit >=1.5 && <1.6
- classy-prelude-yesod >=1.5 && <1.6
- bytestring >=0.10 && <0.11
- text >=0.11 && <2.0
- persistent >=2.7.2 && <2.8
- persistent-postgresql >=2.1.1 && <2.8
- persistent-template >=2.0 && <2.8
- persistent >=2.9 && <2.10
- persistent-postgresql >=2.9 && <2.10
- persistent-template >=2.5 && <2.9
- persistent-qq >=2.9 && <2.10
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9
- http-conduit >=2.1 && <2.3
- yaml >=0.11 && <0.12
- http-conduit >=2.3 && <2.4
- directory >=1.1 && <1.4
- warp >=3.0 && <3.3
- data-default
- aeson >=0.6 && <1.3
- aeson >=1.4 && <1.5
- conduit >=1.0 && <2.0
- conduit-combinators
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4
- foreign-store
- file-embed
- safe
- unordered-containers
@ -52,11 +50,12 @@ dependencies:
- http-api-data
- profunctors
- colonnade >=1.1.1
- yesod-colonnade >=1.1.0
- blaze-markup
- zip-stream
- encoding
- filepath
- transformers
- transformers-base
- wl-pprint-text
- uuid-types
- path-pieces
@ -100,8 +99,10 @@ dependencies:
- th-abstraction
- HaskellNet
- HaskellNet-SSL
- network
- resource-pool
- network >=3
- network-bsd
- unliftio
- unliftio-pool
- mime-mail
- hashable
- aeson-pretty
@ -116,7 +117,6 @@ dependencies:
- pkcs7
- memcached-binary
- directory-tree
- lifted-base
- lattices
- hsass
- semigroupoids
@ -126,7 +126,6 @@ dependencies:
- mono-traversable
- lens-aeson
- systemd
- lifted-async
- streaming-commons
- hourglass
- unix
@ -138,6 +137,7 @@ dependencies:
- pqueue
- deepseq
- multiset
- retry
other-extensions:
- GeneralizedNewtypeDeriving
@ -183,6 +183,7 @@ default-extensions:
- DeriveLift
- DeriveFunctor
- DerivingStrategies
- DerivingVia
- DataKinds
- BinaryLiterals
- PolyKinds
@ -190,9 +191,12 @@ default-extensions:
- TypeApplications
- RecursiveDo
- TypeFamilyDependencies
- QuantifiedConstraints
ghc-options:
- -Wall
- -Wmissing-home-modules
- -Wredundant-constraints
- -fno-warn-type-defaults
- -fno-warn-unrecognised-pragmas
- -fno-warn-partial-type-signatures

8
shell.nix
View File

@ -19,7 +19,7 @@ let
'';
override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-12_x postgresql openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = ''
export PROMPT_INFO="${oldAttrs.name}"
@ -47,6 +47,12 @@ let
set +xe
fi
if [ -n "$ZSH_VERSION" ]; then
autoload -U +X compinit && compinit
autoload -U +X bashcompinit && bashcompinit
fi
eval "$(stack --bash-completion-script stack)"
${oldAttrs.shellHook}
'';
};

25
src/Application.hs
View File

@ -54,7 +54,9 @@ import qualified Data.ByteString.Lazy as LBS
import Network.HaskellNet.SSL hiding (Settings)
import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
import Data.Pool
import UnliftIO.Concurrent
import UnliftIO.Pool
import Control.Monad.Trans.Resource
@ -70,13 +72,12 @@ import System.Exit
import qualified Database.Memcached.Binary.IO as Memcached
import qualified System.Systemd.Daemon as Systemd
import Control.Concurrent.Async.Lifted.Safe
import System.Environment (lookupEnv)
import System.Posix.Process (getProcessID)
import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
import qualified System.Posix.Signals as Signals (Handler(..))
import Network (socketPort)
import Network.Socket (socketPort)
import qualified Network.Socket as Socket (close)
import Control.Concurrent.STM.Delay
@ -120,7 +121,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
makeFoundation appSettings'@AppSettings{..} = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
@ -146,7 +147,7 @@ makeFoundation appSettings'@AppSettings{..} = do
oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
rmLoggerSet $ loggerSet oldLogger
updateLogger newSettings
(tVar, ) <$> fork (updateLogger initialSettings)
(tVar, ) <$> forkIO (updateLogger initialSettings)
appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
let appStatic = embeddedStatic
@ -250,7 +251,7 @@ readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFil
instanceId <- UUID.nextRandom
LBS.writeFile idFile $ UUID.toByteString instanceId
return instanceId
| otherwise = throw e
| otherwise = throwIO e
createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
@ -327,7 +328,7 @@ warpSettings foundation = defaultSettings
void $ liftIO Systemd.notifyReady
if
| foundation ^. _appHealthCheckDelayNotify
-> void . fork $ do
-> void . forkIO $ do
let activeChecks = Set.fromList universeF
& Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
atomically $ do
@ -369,7 +370,7 @@ develMain = runResourceT $ do
liftIO . develMainHelper $ return (wsettings, app)
-- | The @main@ function for an executable running this site.
appMain :: MonadResourceBase m => m ()
appMain :: MonadUnliftIO m => m ()
appMain = runResourceT $ do
settings <- getAppSettings
@ -445,7 +446,7 @@ appMain = runResourceT $ do
_other -> return ()
go status
in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
in void $ allocateLinkedAsync notifyWatchdog
_other -> return ()
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
@ -461,7 +462,7 @@ appMain = runResourceT $ do
foundationStoreNum :: Word32
foundationStoreNum = 2
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
getApplicationRepl :: (MonadResource m, MonadUnliftIO m) => m (Int, UniWorX, Application)
getApplicationRepl = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
@ -475,7 +476,7 @@ getApplicationRepl = do
return (getPort wsettings, foundation, app1)
shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m ()
shutdownApp app = do
stopJobCtl app
liftIO $ do
@ -494,7 +495,7 @@ handler :: Handler a -> IO a
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
-- | Run DB queries
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
db :: DB a -> IO a
db = handler . runDB
addPWEntry :: User

5
src/Audit.hs
View File

@ -22,7 +22,7 @@ import qualified Network.Socket as Wai
import qualified Net.IP as IP
import qualified Net.IPv6 as IPv6
import Control.Exception (ErrorCall(..), evaluate)
import Control.Exception (ErrorCall(..))
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
@ -79,7 +79,6 @@ instance Exception AuditException
audit :: ( AuthId (HandlerSite m) ~ Key User
, AuthEntity (HandlerSite m) ~ User
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
@ -99,7 +98,7 @@ audit (toJSON -> transactionLogInfo) = do
transactionLogTime <- liftIO getCurrentTime
transactionLogInstance <- getsYesod $ view instanceID
transactionLogInitiator <- liftHandlerT maybeAuthId
transactionLogInitiator <- liftHandler maybeAuthId
transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
insert_ TransactionLog{..}

40
src/Auth/Dummy.hs
View File

@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
dummyForm :: ( RenderMessage site FormMessage
, RenderMessage site DummyMessage
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, Button site ButtonSubmit
) => AForm (HandlerT site IO) (CI Text)
dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage (HandlerSite m) DummyMessage
, YesodPersist (HandlerSite m)
, SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
, Button (HandlerSite m) ButtonSubmit
, MonadHandler m
) => AForm m (CI Text)
dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
where
userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
dummyLogin :: ( YesodAuth site
dummyLogin :: forall site.
( YesodAuth site
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site AFormMessage
, RenderMessage site DummyMessage
, Button site ButtonSubmit
) => AuthPlugin site
dummyLogin = AuthPlugin{..}
where
apName :: Text
apName = "dummy"
-- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
apDispatch "POST" [] = do
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
apDispatch "POST" [] = liftSubHandler $ do
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm
tp <- getRouteToParent
case loginRes of
FormFailure errs -> do
lift . forM_ errs $ addMessage Error . toHtml
redirect LoginR
forM_ errs $ addMessage Error . toHtml
redirect $ tp LoginR
FormMissing -> do
lift $ addMessageI Warning MsgDummyNoFormData
redirect LoginR
addMessageI Warning MsgDummyNoFormData
redirect $ tp LoginR
FormSuccess ident ->
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
setCredsRedirect $ Creds "dummy" (CI.original ident) []
apDispatch _ _ = notFound
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
let loginForm = wrapForm login FormSettings

32
src/Auth/LDAP.hs
View File

@ -84,7 +84,7 @@ instance Exception CampusUserException
makePrisms ''CampusUserException
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
Ldap.bind ldap ldapDn ldapPassword
results <- case lookup "DN" credsExtra of
@ -109,15 +109,15 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
]
campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
campusUser' conf pool User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage
, Button site ButtonSubmit
) => WForm (HandlerT site IO) (FormResult CampusLogin)
campusForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage (HandlerSite m) CampusMessage
, MonadHandler m
) => WForm m (FormResult CampusLogin)
campusForm = do
MsgRenderer mr <- getMsgRenderer
@ -133,24 +133,26 @@ apLdap = "LDAP"
campusLogin :: forall site.
( YesodAuth site
, RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site AFormMessage
, Button site ButtonSubmit
) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
where
apName :: Text
apName = apLdap
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
apDispatch "POST" [] = do
((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
apDispatch "POST" [] = liftSubHandler $ do
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
tp <- getRouteToParent
case loginRes of
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
redirect LoginR
FormMissing -> redirect LoginR
redirect $ tp LoginR
FormMissing -> redirect $ tp LoginR
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
ldapResult <- withLdap pool $ \ldap -> do
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
Ldap.bind ldap ldapDn ldapPassword
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
case searchResults of
@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
$logErrorS "LDAP" $ "Error during login: " <> tshow err
loginErrorMessageI LoginR Msg.AuthError
Right (Right (userDN, credsIdent)) ->
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
Right (Left searchResults) -> do
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
loginErrorMessageI LoginR Msg.AuthError
apDispatch _ _ = notFound
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm
let loginForm = wrapForm login FormSettings

56
src/Auth/PWHash.hs
View File

@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
hashForm :: ( RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, Button site ButtonSubmit
) => AForm (HandlerT site IO) HashLogin
hashForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage (HandlerSite m) PWHashMessage
, MonadHandler m
) => AForm m HashLogin
hashForm = HashLogin
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
hashLogin :: ( YesodAuth site
hashLogin :: forall site.
( YesodAuth site
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, PersistRecordBackend User (YesodPersistBackend site)
, RenderMessage site PWHashMessage
, RenderMessage site AFormMessage
, Button site ButtonSubmit
) => PWHashAlgorithm -> AuthPlugin site
hashLogin pwHashAlgo = AuthPlugin{..}
where
apName :: Text
apName = "PWHash"
apDispatch "POST" [] = do
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
apDispatch "POST" [] = liftSubHandler $ do
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm
tp <- getRouteToParent
case loginRes of
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
redirect LoginR
FormMissing -> redirect LoginR
redirect $ tp LoginR
FormMissing -> redirect $ tp LoginR
FormSuccess HashLogin{..} -> do
user <- lift . runDB . getBy $ UniqueAuthentication hashIdent
user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
case user of
Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
| verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic.
lift . setCredsRedirect $ Creds apName userIdent []
setCredsRedirect $ Creds apName userIdent []
other -> do
$logDebugS "PWHash" $ tshow other
loginErrorMessageI LoginR Msg.InvalidLogin
-- apDispatch "GET" [] = do
-- authData <- lookupBasicAuth
-- pwdata <- liftIO $ Yaml.decodeFileEither fp
-- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
-- case pwdata of
-- Left err -> $logDebugS "Auth" $ tshow err
-- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
-- case (authData, pwdata) of
-- (Nothing, _) -> do
-- notAuthenticated
-- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
-- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
-- <- [ pwe | pwe@PWEntry{..} <- pwdata'
-- , let User{..} = pwUser
-- , userIdent == usr
-- , userPlugin == apName
-- ]
-- , verifyPassword pw pwHash
-- -> lift $ do
-- runDB . void $ insertUnique pwUser
-- setCredsRedirect $ Creds apName userIdent []
-- _ -> permissionDenied "Invalid auth"
apDispatch _ _ = notFound
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
let loginForm = wrapForm login FormSettings

17
src/Control/Concurrent/Async/Lifted/Safe/Utils.hs
View File

@ -1,17 +0,0 @@
module Control.Concurrent.Async.Lifted.Safe.Utils
( allocateAsync, allocateLinkedAsync
) where
import ClassyPrelude hiding (cancel)
import Control.Lens
import Control.Concurrent.Async.Lifted.Safe
import Control.Monad.Trans.Resource
allocateLinkedAsync, allocateAsync :: forall m a.
MonadResource m
=> IO a -> m (Async a)
allocateAsync = fmap (view _2) . flip allocate cancel . async
allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync

8
src/CryptoID.hs
View File

@ -8,11 +8,12 @@ module CryptoID
, module System.FilePath.Cryptographic.ImplicitNamespace
) where
import CryptoID.TH
import ClassyPrelude
import Import.NoModel
import Model
import CryptoID.TH
import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace
@ -20,9 +21,6 @@ import System.FilePath.Cryptographic.ImplicitNamespace
import qualified Data.Text as Text
-- import Data.UUID.Types
import Web.PathPieces
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

1
src/Data/CaseInsensitive/Instances.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Data.CaseInsensitive.Instances
(

2
src/Data/CryptoID/Instances.hs
View File

@ -43,5 +43,5 @@ instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
toField = Csv.toField . CID.ciphertext
instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where
instance {-# OVERLAPS #-} Csv.ToField s => Csv.ToField (CID.CryptoID c (CI s)) where
toField = Csv.toField . CI.foldedCase . CID.ciphertext

12
src/Data/List/NonEmpty/Instances.hs
View File

@ -1,12 +0,0 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.List.NonEmpty.Instances
(
) where
import Data.List.NonEmpty
import Language.Haskell.TH.Syntax (Lift(..))
instance Lift a => Lift (NonEmpty a) where
lift (toList -> xs) = [e|fromList xs|]

13
src/Database/Esqueleto/Utils.hs
View File

@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Database.Esqueleto.Utils
( true, false
@ -61,24 +62,22 @@ false :: E.SqlExpr (E.Value Bool)
false = E.val False
-- | Negation of `isNothing` which is missing
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
isJust = E.not_ . E.isNothing
infix 4 `isInfixOf`, `hasInfix`
-- | Check if the first string is contained in the text derived from the second argument
isInfixOf :: ( E.Esqueleto query expr backend
, E.SqlString s1
isInfixOf :: ( E.SqlString s1
, E.SqlString s2
)
=> expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool)
=> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool)
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
hasInfix :: ( E.Esqueleto query expr backend
, E.SqlString s1
hasInfix :: ( E.SqlString s1
, E.SqlString s2
)
=> expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
=> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool)
hasInfix = flip isInfixOf
and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)

84
src/Foundation.hs
View File

@ -5,7 +5,6 @@
module Foundation where
import Import.NoFoundation hiding (embedFile)
import qualified ClassyPrelude.Yesod as Yesod (getHttpManager)
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
@ -48,9 +47,6 @@ import Data.List (nubBy, (!!), findIndex)
import Data.Monoid (Any(..))
import Data.Pool
import Data.Conduit (($$))
import Data.Conduit.List (sourceList)
import qualified Database.Esqueleto as E
@ -94,6 +90,8 @@ import Data.FileEmbed (embedFile)
import qualified Ldap.Client as Ldap
import UnliftIO.Pool
type SMTPPool = Pool SMTPConnection
@ -162,9 +160,9 @@ deriving instance Generic (Route UniWorX)
-- | Convenient Type Synonyms:
type DB = YesodDB UniWorX
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
type MsgRenderer = MsgRendererS UniWorX -- see Utils
type MailM a = MailT (HandlerT UniWorX IO) a
type MailM a = MailT (HandlerFor UniWorX) a
-- Pattern Synonyms for convenience
pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX
@ -531,13 +529,13 @@ class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
evalAccessPred aPred aid r w = liftHandler $ case aPred of
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w
(APDB p) -> runDB $ p aid r w
instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
evalAccessPred aPred aid r w = mapReaderT liftHandler $ case aPred of
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> lift $ p aid r w
(APDB p) -> p aid r w
@ -573,7 +571,6 @@ falseAP = APPure . const . const . const $ falseAR <$> ask -- included for compl
askTokenUnsafe :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadLogger m
, MonadCatch m
)
=> ExceptT AuthResult m (BearerToken (UniWorX))
@ -690,7 +687,7 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI Error MsgDeprecatedRoute
allow <- view _appAllowDeprecated
allow <- getsYesod $ view _appAllowDeprecated
return $ bool (Unauthorized "Deprecated Route") Authorized allow
tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
$logWarnS "AccessControl" ("route in development: " <> tshow r)
@ -1107,9 +1104,9 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
cTime <- liftIO getCurrentTime
let authorizedIfExists f = do
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
whenExceptT ok Authorized
let
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
-- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
@ -1395,42 +1392,42 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
return result
evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor mAuthId route isWrite = do
dnf <- either throwM return $ routeAuthTags route
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessForDB = evalAccessFor
evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess route isWrite = do
mAuthId <- liftHandlerT maybeAuthId
mAuthId <- liftHandler maybeAuthId
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
dnf <- either throwM return $ routeAuthTags route
(result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
result <$ tellSessionJson SessionInactiveAuthTags deactivated
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB = evalAccess
-- | Check whether the current user is authorized by `evalAccess` for the given route
-- Convenience function for a commonly used code fragment
hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool
hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool
hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
-- | Check whether the current user is authorized by `evalAccess` to read from the given route
-- Convenience function for a commonly used code fragment
hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
hasReadAccessTo = flip hasAccessTo False
-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
-- Convenience function for a commonly used code fragment
hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool
hasWriteAccessTo = flip hasAccessTo True
-- | Conditional redirect that hides the URL if the user is not authorized for the route
redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
redirectAccess url = do
-- must hide URL if not authorized
access <- evalAccess url False
@ -1439,7 +1436,7 @@ redirectAccess url = do
_ -> permissionDeniedI MsgUnauthorizedRedirect
-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX)
evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
=> TermId -> SchoolId -> CourseShorthand -> m AuthResult
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
@ -1481,7 +1478,7 @@ instance Yesod UniWorX where
$logDebugS "updateFavourites" "Updating favourites"
now <- liftIO $ getCurrentTime
uid <- MaybeT $ liftHandlerT maybeAuthId
uid <- MaybeT $ liftHandler maybeAuthId
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid
@ -1533,7 +1530,7 @@ instance Yesod UniWorX where
encrypted :: ToJSON a => a -> Widget -> Widget
encrypted plaintextJson plaintext = do
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
shouldEncrypt <- view _appEncryptErrors
shouldEncrypt <- getsYesod $ view _appEncryptErrors
if
| shouldEncrypt
, not canDecrypt -> do
@ -1596,14 +1593,13 @@ instance Yesod UniWorX where
. decodeUtf8
. Base64.encode
. (convert :: Digest (SHAKE256 144) -> ByteString)
. runIdentity
$ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
. runConduitPure
$ sourceList (Lazy.ByteString.toChunks content) .| sinkHash
fileUpload _site _length = FileUploadMemory lbsBackEnd
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLog _ _ _ = error "Must use shouldLogIO"
shouldLogIO app _source level = do
LogSettings{..} <- readTVarIO $ appLogSettings app
return $ logAll || level >= logMinimumLevel
@ -1626,7 +1622,7 @@ siteLayout = siteLayout' . Just
siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
-> Widget -> Handler Html
siteLayout' headingOverride widget = do
AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
isModal <- hasCustomHeader HeaderIsModal
@ -1747,7 +1743,7 @@ siteLayout' headingOverride widget = do
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
where
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
cID <- encrypt smId
@ -2548,7 +2544,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
case muid of
Nothing -> return False
(Just uid) -> do
[E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
@ -2744,7 +2740,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
, menuItemModal = True
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
uid <- MaybeT $ liftHandler maybeAuthId
submissions <- lift $ submissionList tid csh shn uid
guard $ null submissions
return True
@ -2756,7 +2752,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
uid <- MaybeT $ liftHandler maybeAuthId
submissions <- lift $ submissionList tid csh shn uid
guard . not $ null submissions
return True
@ -2966,7 +2962,7 @@ pageActions (CorrectionsR) =
, menuItemRoute = SomeRoute CorrectionsCreateR
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
uid <- MaybeT $ liftHandler maybeAuthId
sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
@ -3005,7 +3001,7 @@ pageActions (CorrectionsGradeR) =
, menuItemRoute = SomeRoute CorrectionsCreateR
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
uid <- MaybeT $ liftHandler maybeAuthId
sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
@ -3024,7 +3020,7 @@ pageActions _ = []
i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m ()
i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg
i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg
-- | only used in defaultLayout; better use siteLayout instead!
pageHeading :: Route UniWorX -> Maybe Widget
@ -3131,7 +3127,7 @@ pageHeading _
= Nothing
routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)]
routeNormalizers =
[ normalizeRender
, ncSchool
@ -3142,7 +3138,7 @@ routeNormalizers =
]
where
normalizeRender route = route <$ do
YesodRequest{..} <- liftHandlerT getRequest
YesodRequest{..} <- liftHandler getRequest
let original = (W.pathInfo reqWaiRequest, reqGetParams)
rendered = renderRoute route
if
@ -3338,10 +3334,10 @@ upsertCampusUser ldapData Creds{..} = do
. UUID.fromByteString
. fromStrict
. (convert :: Digest (SHAKE128 128) -> ByteString)
. runIdentity
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
. runConduitPure
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash
[E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
candidatesRecorded <- E.selectExists . E.from $ \candidate ->
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
unless candidatesRecorded $ do
@ -3419,14 +3415,14 @@ instance YesodAuth UniWorX where
loginHandler = do
toParent <- getRouteToParent
lift . defaultLayout $ do
liftHandler . defaultLayout $ do
plugins <- getsYesod authPlugins
$logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
setTitleI MsgLoginTitle
$(widgetFile "login")
authenticate Creds{..} = runDB $ do
authenticate Creds{..} = liftHandler . runDB $ do
now <- liftIO getCurrentTime
let
@ -3495,7 +3491,7 @@ instance YesodAuth UniWorX where
, dummyLogin <$ guard appAuthDummyLogin
]
authHttpManager = Yesod.getHttpManager
authHttpManager = getsYesod appHttpManager
onLogin = addMessageI Success Auth.NowLoggedIn

10
src/Handler/Admin.hs
View File

@ -54,7 +54,7 @@ instance Button UniWorX ButtonCreate where
btnClasses CreateInf = [BCIsButton, BCPrimary]
-- END Button needed only here
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
emailTestForm = (,)
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
<*> ( MailContext
@ -112,7 +112,7 @@ postAdminTestR = do
jId <- queueJob $ JobSendTestEmail email ls
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
return jId
writeJobCtl $ JobCtlPerform jId
runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
let emailWidget' = wrapForm emailWidget def
@ -189,7 +189,7 @@ postAdminTestR = do
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
deleteCell = miDeleteList
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
@ -374,7 +374,7 @@ postAdminFeaturesR = do
-> Getter (DBRow r) (Maybe Text)
-> Getter (DBRow r) i
-> DBRow r
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
<$> mopt textField "" (Just $ row ^. lensDefault)
@ -385,7 +385,7 @@ postAdminFeaturesR = do
-> Getter (DBRow r) Bool
-> Getter (DBRow r) i
-> DBRow r
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)

12
src/Handler/Allocation/Application.hs
View File

@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm
{ afPriority :: Maybe Natural
, afField :: Maybe StudyFeaturesId
, afText :: Maybe Text
, afFiles :: Maybe (Source Handler File)
, afFiles :: Maybe (ConduitT () File Handler ())
, afRatingVeto :: Bool
, afRatingPoints :: Maybe ExamGrade
, afRatingComment :: Maybe Text
@ -77,11 +77,11 @@ applicationForm :: (Maybe AllocationId)
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
course <- getJust cid
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
(fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
@ -146,7 +146,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)
hasFiles <- for mApp $ \(Entity appId _)
-> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
-> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
appCID <- for mApp $ encrypt . entityKey
let appFilesInfo = (,) <$> hasFiles <*> appCID
@ -296,7 +296,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
fId <- insert file
insert_ $ CourseApplicationFile appId fId
forM_ afFiles $ \afFiles' ->
runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
audit $ TransactionCourseApplicationEdit cid uid appId
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
@ -327,7 +327,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
fId <- lift $ insert file
lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId
in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
return changes
| otherwise

2
src/Handler/Allocation/List.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Allocation.List
( getAllocationListR
) where

4
src/Handler/Allocation/Show.hs
View File

@ -68,10 +68,10 @@ getAShowR tid ssh ash = do
let Entity cid Course{..} = cEntry ^. resultCourse
hasApplicationTemplate = cEntry ^. resultHasTemplate
mApp = cEntry ^? resultCourseApplication
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
tRoute <- case mApp of
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR

30
src/Handler/Corrections.hs
View File

@ -1,6 +1,6 @@
module Handler.Corrections where
import Import
import Import hiding (link)
-- import System.FilePath (takeFileName)
import Jobs
@ -71,8 +71,8 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
E.where_ $ whereClause t
return $ returnStatement t
lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit))
=> expr (Entity Submission) -> expr (E.Value (Maybe UTCTime))
lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
=> E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
return $ E.max_ $ edit E.^. SubmissionEditTime
@ -216,7 +216,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
)
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (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 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
@ -238,7 +238,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
)
in (submission, sheet, crse, corrector, lastEditQuery submission)
)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
@ -398,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData
| CorrAutoSetCorrectorData SheetId
| CorrDeleteData
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
{ drAbort = SomeRoute currentRoute
@ -416,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
, dbParamsFormAdditional = \frag -> do
(actionRes, action) <- multiActionM actions "" Nothing mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = _1
, dbParamsFormIdent = def
}
@ -466,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
]
addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
auditAllSubEdit sIds
(E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission
E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
@ -537,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
where
authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do
[(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
(E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=<
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@ -547,7 +547,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
let route = CSubmissionR tid ssh csh shn cID SubAssignR
(== Authorized) <$> evalAccessDB route True
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
downloadAction, deleteAction :: ActionCorrections'
downloadAction = ( CorrDownload
@ -560,7 +560,7 @@ deleteAction = ( CorrDelete
assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
, wFormToAForm $ do
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@ -573,7 +573,7 @@ assignAction selId = ( CorrSetCorrector
correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
)
@ -740,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do
}
formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
uid <- liftHandlerT requireAuthId
uid <- liftHandler requireAuthId
now <- liftIO getCurrentTime
if
@ -1013,7 +1013,7 @@ postCorrectionsGradeR = do
, colCommentField
] -- Continue here
psValidator = def
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
cID <- encrypt subId

4
src/Handler/Course/Application/Files.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Course.Application.Files
( getCAFilesR
, getCAppsFilesR
@ -47,7 +49,7 @@ getCAppsFilesR tid ssh csh = do
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
let
fsSource :: Source DB File
fsSource :: ConduitT () File DB ()
fsSource = do
apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation

3
src/Handler/Course/Application/List.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Course.Application.List
( getCApplicationsR, postCApplicationsR
@ -103,7 +104,7 @@ instance Csv.ToField CourseApplicationsTableVeto where
instance Csv.FromField CourseApplicationsTableVeto where
parseField f = do
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
return . CourseApplicationsTableVeto $ any (== t)
return . CourseApplicationsTableVeto $ elem t
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
data CourseApplicationsTableCsv = CourseApplicationsTableCsv

28
src/Handler/Course/Edit.hs
View File

@ -44,7 +44,7 @@ data CourseForm = CourseForm
, cfAllocation :: Maybe AllocationCourseForm
, cfAppRequired :: Bool
, cfAppInstructions :: Maybe Html
, cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File))
, cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
, cfAppText :: Bool
, cfAppFiles :: UploadMode
, cfAppRatingsVisible :: Bool
@ -101,13 +101,13 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
-- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs
-- let editCid = cfCourseId =<< template -- possible start for refactoring
MsgRenderer mr <- getMsgRenderer
uid <- liftHandlerT requireAuthId
(lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do
uid <- liftHandler requireAuthId
(lecturerSchools, adminSchools) <- liftHandler . runDB $ do
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
@ -116,7 +116,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
termsField <- case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
(Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course
(Just cform) | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course
_courseOld@Course{..} <- runDB $ get404 cid
mayEditTerm <- isAuthorized TermEditR True
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@ -128,7 +128,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
addRes' <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk
let addRes'' = case (,) <$> addRes <*> addRes' of
FormSuccess (CI.mk -> email, mLid) ->
let new = maybe (Left email) Right mLid
@ -143,7 +143,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
miCell _ (Right lid) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
return (Just <$> lrwRes,lrwView')
miCell _ (Left lEmail) defType nudge = \csrf -> do
@ -153,7 +153,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
miDelete = miDeleteList
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
@ -194,7 +194,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
_allIOtherCases -> do
mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
@ -202,7 +202,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
let
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
allocationForm = wFormToAForm $ do
availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid ->
@ -226,7 +226,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1
mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do
mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do
cID <- encrypt aId :: Handler CryptoUUIDAllocation
return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
@ -295,7 +295,7 @@ validateCourse = do
CourseForm{..} <- State.get
now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId
uid <- liftHandler requireAuthId
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
@ -517,7 +517,7 @@ courseEditHandler miButtonAction mbCourseForm = do
tell $ Set.singleton fId
lift $
void . insertUnique $ CourseAppInstructionFile cid fId
keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
@ -534,7 +534,7 @@ courseEditHandler miButtonAction mbCourseForm = do
, formEncoding = formEnctype
}
upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime
Course{..} <- getJust cid

11
src/Handler/Course/LecturerInvite.hs
View File

@ -57,16 +57,19 @@ lecturerInvitationConfig = InvitationConfig{..}
where
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
invitationResolveFor _ = do
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
cRoute <- getCurrentRoute
case cRoute of
Just (CourseR tid csh ssh CLecInviteR) ->
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
_other -> error "lecturerInvitationConfig called from unsupported route"
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
Nothing -> areq (selectField optionsFinite) lFs Nothing
Just lType -> aforced (selectField optionsFinite) lFs lType
where

2
src/Handler/Course/List.hs
View File

@ -86,7 +86,7 @@ makeCourseTable whereClause colChoices psValidator = do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
return user
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj :: DBRow _ -> MaybeT DB CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)

15
src/Handler/Course/ParticipantInvite.hs
View File

@ -70,13 +70,17 @@ participantInvitationConfig = InvitationConfig{..}
where
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
invitationResolveFor _ = do
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
cRoute <- getCurrentRoute
case cRoute of
Just (CourseR tid csh ssh CInviteR) ->
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
_other ->
error "participantInvitationConfig called from unsupported route"
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
@ -98,9 +102,12 @@ data AddRecipientsResult = AddRecipientsResult
, aurSuccess :: [UserEmail]
} deriving (Read, Show, Generic, Typeable)
instance Semigroup AddRecipientsResult where
(<>) = mappenddefault
instance Monoid AddRecipientsResult where
mempty = memptydefault
mappend = mappenddefault
mappend = (<>)
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR

8
src/Handler/Course/Register.hs
View File

@ -41,12 +41,12 @@ instance Button UniWorX ButtonCourseRegister where
data CourseRegisterForm = CourseRegisterForm
{ crfStudyFeatures :: Maybe StudyFeaturesId
, crfApplicationText :: Maybe Text
, crfApplicationFiles :: Maybe (Source Handler File)
, crfApplicationFiles :: Maybe (ConduitT () File Handler ())
}
courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
-- ^ `CourseRegisterForm` for current user
courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
muid <- maybeAuthId
(registration, application) <- runDB $ do
registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid
@ -108,7 +108,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
-> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)
hasFiles <- for application $ \(Entity appId _)
-> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
-> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
appCID <- for application $ encrypt . entityKey
let appFilesInfo = (,) <$> hasFiles <*> appCID
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
@ -191,7 +191,7 @@ postCRegisterR tid ssh csh = do
whenIsJust appRes $
audit . TransactionCourseApplicationEdit cid uid
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
return appRes
| otherwise
= return $ Just ()

15
src/Handler/Course/Show.hs
View File

@ -125,11 +125,12 @@ getCShowR tid ssh csh = do
, sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
Nothing -> mempty
Just tutorialCapacity' -> sqlCell $ do
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
in return $ E.val tutorialCapacity' E.-. numParticipants
return . toWidget . tshow $ max 0 freeCapacity
freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
. E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
in return $ E.val tutorialCapacity' E.-. numParticipants
return . toWidget $ tshow freeCapacity
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
isRegistered <- case mbAid of
@ -137,7 +138,7 @@ getCShowR tid ssh csh = do
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
if
| mayRegister -> do
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
(tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm tutRegisterForm def
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
, formEncoding = tutRegisterEnctype
@ -198,7 +199,7 @@ getCShowR tid ssh csh = do
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
-- if
-- | mayRegister -> do
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-- return $ wrapForm examRegisterForm def
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
-- , formEncoding = examRegisterEnctype

2
src/Handler/Course/User.hs
View File

@ -159,7 +159,7 @@ postCUserR tid ssh csh uCId = do
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute
Nothing -> invalidArgs ["User already registered"]
_other -> fail "Invalid @regButton@"
_other -> error "Invalid @regButton@"
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime

4
src/Handler/Course/Users.hs
View File

@ -139,7 +139,7 @@ makeCourseUserTable :: forall h acts.
-> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
-> DB (FormResult (Element acts, Set UserId), Widget)
makeCourseUserTable cid acts restrict colChoices psValidator = do
Just currentRoute <- liftHandlerT getCurrentRoute
currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
-- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
@ -210,7 +210,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
= renderAForm FormStandard
$ (, mempty) . First . Just
<$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}

7
src/Handler/Exam/AddUser.hs
View File

@ -29,9 +29,12 @@ data AddRecipientsResult = AddRecipientsResult
, aurSuccessCourse :: [UserEmail]
} deriving (Read, Show, Generic, Typeable)
instance Semigroup AddRecipientsResult where
(<>) = mappenddefault
instance Monoid AddRecipientsResult where
mempty = memptydefault
mappend = mappenddefault
mappend = (<>)
getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
@ -40,7 +43,7 @@ postEAddUserR tid ssh csh examn = do
eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
now <- liftIO getCurrentTime
occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
let
localNow = utcToLocalTime now

10
src/Handler/Exam/CorrectorInvite.hs
View File

@ -55,15 +55,19 @@ examCorrectorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse
return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
invitationResolveFor _ = do
Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
fetchExamId tid csh ssh examn
cRoute <- getCurrentRoute
case cRoute of
Just (CExamR tid csh ssh examn ECInviteR) ->
fetchExamId tid csh ssh examn
_other ->
error "examCorrectorInvitationConfig called from unsupported route"
invitationSubject (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ())

10
src/Handler/Exam/Form.hs
View File

@ -105,8 +105,8 @@ examForm template html = do
examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
examCorrectorsForm mPrev = wFormToAForm $ do
MsgRenderer mr <- getMsgRenderer
Just currentRoute <- getCurrentRoute
uid <- liftHandlerT requireAuthId
currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
uid <- liftHandler requireAuthId
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
@ -140,7 +140,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
miCell' (Left email) =
$(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
miCell' (Right userId) = do
User{..} <- liftHandlerT . runDB $ get404 userId
User{..} <- liftHandler . runDB $ get404 userId
$(widgetFile "widgets/massinput/examCorrectors/cellKnown")
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
@ -150,7 +150,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
Just currentRoute <- getCurrentRoute
currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
@ -192,7 +192,7 @@ examOccurrenceForm prev = wFormToAForm $ do
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
examPartsForm prev = wFormToAForm $ do
Just currentRoute <- getCurrentRoute
currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag

14
src/Handler/Exam/RegistrationInvite.hs
View File

@ -63,15 +63,19 @@ examRegistrationInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse
return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
invitationResolveFor _ = do
Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
fetchExamId tid csh ssh examn
cRoute <- getCurrentRoute
case cRoute of
Just (CExamR tid csh ssh examn EInviteR) ->
fetchExamId tid csh ssh examn
_other ->
error "examRegistrationInvitationConfig called from unsupported route"
invitationSubject (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
itAddAuth
| not invDBExamRegistrationCourseRegister
@ -81,8 +85,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
itStartsAt = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do
isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
now <- liftIO getCurrentTime
case (isRegistered, invDBExamRegistrationCourseRegister) of

2
src/Handler/Exam/Show.hs
View File

@ -83,7 +83,7 @@ getEShowR tid ssh csh examn = do
registerWidget
| Just isRegistered <- registered
, mayRegister = Just $ do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
[whamlet|
<p>
$if isRegistered

26
src/Handler/Exam/Users.hs
View File

@ -588,7 +588,7 @@ postEUsersR tid ssh csh examn = do
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = _2
, dbParamsFormIdent = def
}
@ -627,14 +627,14 @@ postEUsersR tid ssh csh examn = do
DBCsvDiffMissing{dbCsvOldKey}
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
DBCsvDiffNew{dbCsvNewKey = Just _}
-> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
-> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
(isPart, uid) <- lift $ guessUser dbCsvNew
if
| isPart -> do
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
when (newFeatures /= oldFeatures) $
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
| otherwise ->
@ -660,7 +660,7 @@ postEUsersR tid ssh csh examn = do
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
let uid = dbCsvOld ^. resultUser . _entityKey
@ -820,13 +820,13 @@ postEUsersR tid ssh csh examn = do
delete nid
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId
uid <- liftHandler requireAuthId
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
insert_ $ CourseUserNoteEdit uid now nid
return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
ExamUserCsvCourseRegisterData{..} -> do
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
(User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@ -840,7 +840,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvRegisterData{..} -> do
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
(User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@ -850,7 +850,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvAssignOccurrenceData{..} -> do
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust
[whamlet|
$newline never
^{registeredUserName' examUserCsvActRegistration}
@ -860,7 +860,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvSetCourseFieldData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@ -870,7 +870,7 @@ postEUsersR tid ssh csh examn = do
, _{MsgCourseStudyFeatureNone}
|]
ExamUserCsvSetPartResultData{..} -> do
(User{..}, Entity _ ExamPart{..}) <- liftHandlerT . runDB $
(User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $
(,) <$> getJust examUserCsvActUser
<*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart)
[whamlet|
@ -886,7 +886,7 @@ postEUsersR tid ssh csh examn = do
, _{MsgExamResultNone}
|]
ExamUserCsvSetBonusData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@ -896,7 +896,7 @@ postEUsersR tid ssh csh examn = do
, _{MsgExamBonusNone}
|]
ExamUserCsvSetResultData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@ -906,7 +906,7 @@ postEUsersR tid ssh csh examn = do
, _{MsgExamResultNone}
|]
ExamUserCsvSetCourseNoteData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}

2
src/Handler/ExamOffice/Course.hs
View File

@ -16,7 +16,7 @@ import Handler.Utils
examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId)
-- ^ Deals with sets of _opt outs_
examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do
schools <- liftHandlerT . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced)
-> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template)

9
src/Handler/ExamOffice/Exam.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.ExamOffice.Exam
( getEGradesR, postEGradesR
, examCloseWidget
@ -84,7 +86,7 @@ type ExamUserTableData = DBRow ( Entity ExamResult
)
queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration)))
queryExamRegistration = to $ $(E.sqlLOJproj 4 2)
queryExamRegistration = to $(E.sqlLOJproj 4 2)
queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User))
queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)
@ -213,7 +215,7 @@ postEGradesR tid ssh csh examn = do
partAnchor :: Widget
partAnchor = do
let partId = x ^. resultUser . _entityKey
cID <- encrypt partId :: WidgetT UniWorX IO CryptoUUIDUser
cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser
[whamlet|
$newline never
<span ##{toPathPiece cID}>
@ -262,6 +264,7 @@ postEGradesR tid ssh csh examn = do
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)
E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid)
E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId
E.&&. examResult E.^. ExamResultExam E.==. E.val eid
@ -385,7 +388,7 @@ postEGradesR tid ssh csh examn = do
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}

2
src/Handler/ExamOffice/Exams.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.ExamOffice.Exams
( getEOExamsR
) where

6
src/Handler/ExamOffice/Fields.hs
View File

@ -45,7 +45,7 @@ eofModeField = Field{..}
makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool)
makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do
availableFields <- liftHandlerT . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
availableFields <- liftHandler . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms
E.where_ . E.exists . E.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
@ -75,7 +75,7 @@ getEOFieldsR = postEOFieldsR
postEOFieldsR = do
uid <- requireAuthId
oldFields <- liftHandlerT . runDB $ 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)
@ -84,7 +84,7 @@ postEOFieldsR = do
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
formResult fieldsRes $ \newFields -> do
liftHandlerT . runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
| Just forced <- Map.lookup fieldId newFields
, fieldId `Map.member` oldFields -> do
updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ]

12
src/Handler/ExamOffice/Users.hs
View File

@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
let itExpiresAt = Nothing
itStartsAt = Nothing
itAddAuth = Nothing
@ -85,7 +85,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
makeExamOfficeUsersForm template = renderWForm FormStandard $ do
Just cRoute <- getCurrentRoute
cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute
let
miAdd' :: (Text -> Text)
@ -105,7 +105,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
miCell' :: Either UserEmail UserId -> Widget
miCell' (Left email) = $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
miCell' (Right uid) = do
User{..} <- liftHandlerT . runDB $ getJust uid
User{..} <- liftHandler . runDB $ getJust uid
$(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
@ -119,7 +119,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
fRequired :: Bool
fRequired = False
template' <- for template $ \uids -> liftHandlerT . runDB $ do
template' <- for template $ \uids -> liftHandler . runDB $ do
let (invitations, knownUsers) = partitionEithers $ Set.toList uids
knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
@ -137,7 +137,7 @@ getEOUsersR = postEOUsersR
postEOUsersR = do
uid <- requireAuthId
oldUsers <- liftHandlerT . runDB $ do
oldUsers <- liftHandler . runDB $ do
users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do
E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
@ -148,7 +148,7 @@ postEOUsersR = do
((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
liftHandlerT . runDBJobs . forM_ changes $ \change -> if
liftHandler . runDBJobs . forM_ changes $ \change -> if
| change `Set.member` oldUsers -> case change of
Right change' -> do
deleteBy $ UniqueExamOfficeUser uid change'

2
src/Handler/Health.hs
View File

@ -27,7 +27,7 @@ getHealthR = do
waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
case waitResult of
Left False -> sendResponseStatus noContent204 ()
Left True -> fail "System is not generating HealthReports"
Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text)
Right _ -> redirect HealthR
Just healthReports -> do
let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports

8
src/Handler/Home.hs
View File

@ -58,7 +58,7 @@ homeUpcomingSheets uid = do
, E.Value UTCTime
, E.Value (Maybe SubmissionId)
))
(DBCell (HandlerT UniWorX IO) ())
(DBCell Handler ())
colonnade = mconcat
[ -- dbRow
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
@ -82,7 +82,7 @@ homeUpcomingSheets uid = do
(hasTickmark True)
]
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtColonnade = colonnade
@ -127,7 +127,7 @@ homeUpcomingSheets uid = do
homeUpcomingExams :: UserId -> Widget
homeUpcomingExams uid = do
now <- liftIO getCurrentTime
((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
User {userWarningDays} <- get404 uid
let fortnight = addUTCTime userWarningDays now
let -- code copied and slightly adapted from Handler.Course.getCShowR:
@ -202,7 +202,7 @@ homeUpcomingExams uid = do
isRegistered <- existsBy $ UniqueExamRegistration eId uid
if
| mayRegister -> do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
, formEncoding = examRegisterEnctype

15
src/Handler/Material.hs
View File

@ -28,7 +28,7 @@ data MaterialForm = MaterialForm
, mfType :: Maybe (CI Text)
, mfDescription :: Maybe Html
, mfVisibleFrom :: Maybe UTCTime
, mfFiles :: Maybe (Source Handler (Either FileId File))
, mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
}
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
@ -40,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
| Just source <- template >>= mfFiles
= runConduit $ source .| C.foldMap setIds
| otherwise = return Set.empty
typeOptions :: HandlerT UniWorX IO (OptionList (CI Text))
typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
typeOptions = do
let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
previouslyUsed <- runDB $
@ -77,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do
getKeyBy404 $ UniqueMaterial cid mnm
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
fetchMaterial tid ssh csh mnm = do
[matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints
fetchMaterial tid ssh csh mnm =
maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints
\(course `E.InnerJoin` material) -> do
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
@ -86,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. material E.^. MaterialName E.==. E.val mnm
return material
return matEnt
getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -245,7 +244,7 @@ postMEditR tid ssh csh mnm = do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
return $ file E.^. FileId
return (matEnt, (Left . E.unValue) <$> fileIds)
return (matEnt, Left . E.unValue <$> fileIds)
-- let cid = materialCourse
let template = Just MaterialForm
{ mfName = materialName
@ -308,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
when saveOk $ redirect -- redirect must happen outside of runDB
$ CourseR tid ssh csh (MaterialR mfName MShowR)
insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB ()
insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB ()
insertMaterialFile' mid fs = do
oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
return $ file E.^. FileId
let oldFileIds = setFromList $ map E.unValue oldFileIdVals
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId

6
src/Handler/Profile.hs
View File

@ -94,7 +94,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do
allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
let
schoolForm (Entity ssh School{schoolName})
@ -116,7 +116,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do
mbUid <- liftHandlerT maybeAuthId
mbUid <- liftHandler maybeAuthId
isAdmin <- hasReadAccessTo AdminR
let
@ -144,7 +144,7 @@ notificationForm template = wFormToAForm $ do
| otherwise
= return False
ntHidden <- liftHandlerT . runDB
ntHidden <- liftHandler . runDB
$ Set.fromList universeF
& Map.fromSet sectionIsHidden
& sequenceA

2
src/Handler/School.hs
View File

@ -70,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
where
ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text))
ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []

35
src/Handler/Sheet.hs
View File

@ -2,7 +2,7 @@
module Handler.Sheet where
import Import
import Import hiding (link)
import Jobs.Queue
@ -69,10 +69,7 @@ data SheetForm = SheetForm
, sfActiveTo :: UTCTime
, sfHintFrom :: Maybe UTCTime
, sfSolutionFrom :: Maybe UTCTime
, sfSheetF :: Maybe (Source Handler (Either FileId File))
, sfHintF :: Maybe (Source Handler (Either FileId File))
, sfSolutionF :: Maybe (Source Handler (Either FileId File))
, sfMarkingF :: Maybe (Source Handler (Either FileId File))
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfType :: SheetType
, sfGrouping :: SheetGroup
, sfSubmissionMode :: SubmissionMode
@ -93,7 +90,7 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
mr <- getMsgRenderer
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
@ -637,20 +634,20 @@ postSDelR tid ssh csh shn = do
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
insertSheetFile sid ftype finfo = do
runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
runConduit $ sourceFiles finfo .| C.mapM_ finsert
where
finsert file = do
fid <- insert file
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX ()
insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId)
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
@ -694,8 +691,8 @@ defaultLoads shid = do
correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
correctorForm shid = wFormToAForm $ do
Just currentRoute <- liftHandlerT getCurrentRoute
userId <- liftHandlerT requireAuthId
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
userId <- liftHandler requireAuthId
MsgRenderer mr <- getMsgRenderer
let
@ -703,9 +700,9 @@ correctorForm shid = wFormToAForm $ do
currentLoads = Map.union
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
<*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid)
(defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
(defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads
isWrite <- liftHandlerT $ isWriteRequest currentRoute
isWrite <- liftHandler $ isWriteRequest currentRoute
let
applyDefaultLoads = Map.null currentLoads' && not isWrite
@ -766,7 +763,7 @@ correctorForm shid = wFormToAForm $ do
identWidget <- case userIdent of
Left email -> return . toWidget $ mailtoHtml email
Right uid -> do
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
return $ nameEmailWidget userEmail userDisplayName userSurname
return (res, $(widgetFile "sheetCorrectors/cell"))
@ -894,15 +891,19 @@ correctorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 sheetCourse
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
invitationResolveFor _ = do
Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
fetchSheetId tid csh ssh shn
cRoute <- getCurrentRoute
case cRoute of
Just (CSheetR tid csh ssh shn SCorrInviteR) ->
fetchSheetId tid csh ssh shn
_other ->
error "correctorInvitationConfig called from unsupported route"
invitationSubject (Entity _ Sheet{..}) _ = do
Course{..} <- get404 sheetCourse
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())

22
src/Handler/Submission.hs
View File

@ -89,9 +89,13 @@ submissionUserInvitationConfig = InvitationConfig{..}
cID <- encrypt subId
return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
invitationResolveFor _ = do
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
subId <- decrypt cID
bool notFound (return subId) =<< existsKey subId
cRoute <- getCurrentRoute
case cRoute of
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do
subId <- decrypt cID
bool notFound (return subId) =<< existsKey subId
_other ->
error "submissionUserInvitationConfig called from unsupported route"
invitationSubject (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
@ -103,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
let itExpiresAt = Nothing
itStartsAt = Nothing
@ -121,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId))
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
<$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
<*> wFormToAForm submittorsForm
@ -129,7 +133,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
miCell' :: Markup -> Either UserEmail UserId -> Widget
miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
miCell' csrf (Right uid) = do
User{..} <- liftHandlerT . runDB $ getJust uid
User{..} <- liftHandler . runDB $ getJust uid
$(widgetFile "widgets/massinput/submissionUsers/cellKnown")
miLayout :: ListLength
@ -191,7 +195,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
| null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
| otherwise -> FormSuccess $ Set.fromList submittors'
| otherwise = do
uid <- liftHandlerT requireAuthId
uid <- liftHandler requireAuthId
mRoute <- getCurrentRoute
let
@ -275,7 +279,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe
submissionHelper tid ssh csh shn mcid = do
uid <- requireAuthId
msmid <- traverse decrypt mcid
Just actionUrl <- getCurrentRoute
actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
(Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
@ -478,7 +482,7 @@ submissionHelper tid ssh csh shn mcid = do
Nothing -> return ()
-- Maybe construct a table to display uploaded archive files
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ())
colonnadeFiles cid = mconcat
[ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)

8
src/Handler/SystemMessage.hs
View File

@ -179,7 +179,7 @@ postMessageListR = do
{ dbrOutput = (smE, smT)
, ..
}
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = (E.^. SystemMessageId)
@ -216,7 +216,7 @@ postMessageListR = do
]
(actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
@ -225,8 +225,8 @@ postMessageListR = do
, dbtCsvDecode = Nothing
}
let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
& mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
<&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
case tableRes of
FormMissing -> return ()

2
src/Handler/Term.hs
View File

@ -176,7 +176,7 @@ postTermEditExistR tid = do
termEditHandler :: TermFormTemplate -> Handler Html
termEditHandler term = do
Just eHandler <- getCurrentRoute
eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
case result of
(FormSuccess res) -> do

21
src/Handler/Tutorial.hs
View File

@ -14,6 +14,7 @@ import Handler.Utils.Invitations
import Jobs.Queue
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Data.Map ((!))
@ -198,7 +199,7 @@ postTCommR tid ssh csh tutn = do
)
]
, crRecipientAuth = Just $ \uid -> do
[E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
isTutorialUser <- E.selectExists . E.from $ \tutorialUser ->
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid
@ -250,15 +251,19 @@ tutorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 tutorialCourse
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
invitationResolveFor _ = do
Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
fetchTutorialId tid csh ssh tutn
cRoute <- getCurrentRoute
case cRoute of
Just (CTutorialR tid csh ssh tutn TInviteR) ->
fetchTutorialId tid csh ssh tutn
_other ->
error "tutorInvitationConfig called from unsupported route"
invitationSubject (Entity _ Tutorial{..}) _ = do
Course{..} <- get404 tutorialCourse
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionTutor, ())
@ -289,8 +294,8 @@ data TutorialForm = TutorialForm
tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
tutorialForm cid template html = do
MsgRenderer mr <- getMsgRenderer
Just cRoute <- getCurrentRoute
uid <- liftHandlerT requireAuthId
cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
uid <- liftHandler requireAuthId
let
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
@ -314,7 +319,7 @@ tutorialForm cid template html = do
miCell' (Left email) =
$(widgetFile "tutorial/tutorMassInput/cellInvitation")
miCell' (Right userId) = do
User{..} <- liftHandlerT . runDB $ get404 userId
User{..} <- liftHandler . runDB $ get404 userId
$(widgetFile "tutorial/tutorMassInput/cellKnown")
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
@ -338,7 +343,7 @@ tutorialForm cid template html = do
) (tfDeregisterUntil <$> template)
<*> tutorForm
where
tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text))
tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid

12
src/Handler/Users.hs
View File

@ -74,7 +74,7 @@ postUsersR = do
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
, flip foldMap universeF $ \function ->
sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
schools <- liftHandlerT . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@ -92,7 +92,7 @@ postUsersR = do
, formCellContents = do
cID <- encrypt uid
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
myUid <- liftHandlerT maybeAuthId
myUid <- liftHandler maybeAuthId
if
| mayHijack
, Just uid /= myUid
@ -191,7 +191,7 @@ postUsersR = do
= renderAForm FormStandard
$ (, mempty) . First . Just
<$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
@ -309,7 +309,7 @@ postAdminUserR uuid = do
campusHandler _ = mzero
campusResult <- runMaybeT . handle campusHandler $ do
(Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
case campusResult of
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
_other
@ -475,7 +475,7 @@ postUserPasswordR cID = do
formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
tell . pure =<< messageI Success MsgPasswordChangedSuccess
siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $
@ -545,7 +545,7 @@ functionInvitationConfig = InvitationConfig{..}
MsgRenderer mr <- getMsgRenderer
return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
itAuthority <- liftHandlerT requireAuthId
itAuthority <- liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBUserFunctionDeadline
itAddAuth = Nothing
itStartsAt = Nothing

12
src/Handler/Utils.hs
View File

@ -2,7 +2,7 @@ module Handler.Utils
( module Handler.Utils
) where
import Import
import Import hiding (link)
import qualified Data.Text.Encoding as T
import Data.Map ((!))
@ -38,7 +38,7 @@ sendThisFile File{..}
| otherwise = sendResponseStatus noContent204 ()
-- | Serve a single file, identified through a given DB query
serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
serveOneFile :: ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
serveOneFile source = do
results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
case results of
@ -51,7 +51,7 @@ serveOneFile source = do
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
--
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
serveSomeFiles :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
serveSomeFiles archiveName source = do
results <- runDB . runConduit $ source .| peekN 2
@ -69,7 +69,7 @@ serveSomeFiles archiveName source = do
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
--
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
serveZipArchive :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent
serveZipArchive archiveName source = do
results <- runDB . runConduit $ source .| peekN 2
@ -122,7 +122,7 @@ warnTermDays tid timeNames = do
-- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a
guardAuthorizedFor link val =
@ -138,7 +138,7 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
studyFeaturesWidget :: StudyFeaturesId -> Widget
studyFeaturesWidget featId = do
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
[whamlet|
$newline never
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}

4
src/Handler/Utils/Communication.hs
View File

@ -71,7 +71,7 @@ instance RenderMessage UniWorX RecipientCategory where
data CommunicationRoute = CommunicationRoute
{ crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
, crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
, crJobs :: Communication -> Source (YesodDB UniWorX) Job
, crJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crHeading :: SomeMessage UniWorX
, crUltDest :: SomeRoute UniWorX
}
@ -170,7 +170,7 @@ commR CommunicationRoute{..} = do
<*> aopt textField (fslI MsgCommSubject) Nothing
<*> areq htmlField (fslpI MsgCommBody "Html") Nothing
formResult commRes $ \comm -> do
runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
redirect crUltDest

2
src/Handler/Utils/ContentDisposition.hs
View File

@ -8,7 +8,7 @@ import Import
-- | Check whether the user's preference for files is inline-viewing or downloading
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do
mauth <- liftHandlerT maybeAuth
mauth <- liftHandler maybeAuth
case mauth of
Just (Entity _ User{..}) -> return userDownloadFiles
Nothing -> do

28
src/Handler/Utils/Csv.hs
View File

@ -52,7 +52,7 @@ extensionCsv :: Extension
extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => Conduit ByteString m csv
decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m ()
decodeCsv = transPipe throwExceptT $ do
testBuffer <- accumTestBuffer LBS.empty
mapM_ leftover $ LBS.toChunks testBuffer
@ -117,7 +117,7 @@ encodeCsv :: ( ToNamedRecord csv
, Monad m
)
=> Header
-> Conduit csv m ByteString
-> ConduitT csv ByteString m ()
-- ^ Encode a stream of records
--
-- Currently not streaming
@ -128,30 +128,30 @@ encodeDefaultOrderedCsv :: forall csv m.
, DefaultOrdered csv
, Monad m
)
=> Conduit csv m ByteString
=> ConduitT csv ByteString m ()
encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv)
respondCsv :: ToNamedRecord csv
=> Header
-> Source (HandlerT site IO) csv
-> HandlerT site IO TypedContent
-> ConduitT () csv (HandlerFor site) ()
-> HandlerFor site TypedContent
respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
respondDefaultOrderedCsv :: forall csv site.
( ToNamedRecord csv
, DefaultOrdered csv
)
=> Source (HandlerT site IO) csv
-> HandlerT site IO TypedContent
=> ConduitT () csv (HandlerFor site) ()
-> HandlerFor site TypedContent
respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv)
respondCsvDB :: ( ToNamedRecord csv
, YesodPersistRunner site
)
=> Header
-> Source (YesodDB site) csv
-> HandlerT site IO TypedContent
-> ConduitT () csv (YesodDB site) ()
-> HandlerFor site TypedContent
respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
respondDefaultOrderedCsvDB :: forall csv site.
@ -159,16 +159,17 @@ respondDefaultOrderedCsvDB :: forall csv site.
, DefaultOrdered csv
, YesodPersistRunner site
)
=> Source (YesodDB site) csv
-> HandlerT site IO TypedContent
=> ConduitT () csv (YesodDB site) ()
-> HandlerFor site TypedContent
respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv)
fileSourceCsv :: ( FromNamedRecord csv
, MonadResource m
, MonadLogger m
, MonadThrow m
)
=> FileInfo
-> Source m csv
-> ConduitT () csv m ()
fileSourceCsv = (.| decodeCsv) . fileSource
@ -178,7 +179,7 @@ data CsvRendered = CsvRendered
} deriving (Eq, Read, Show, Generic, Typeable)
instance ToWidget UniWorX CsvRendered where
toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered")
toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered")
where
csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row
| columnKey <- Vector.toList csvRenderedHeader
@ -190,7 +191,6 @@ instance ToWidget UniWorX CsvRendered where
toCsvRendered :: forall mono.
( ToNamedRecord (Element mono)
, DefaultOrdered (Element mono)
, MonoFoldable mono
)
=> Header

8
src/Handler/Utils/Database.hs
View File

@ -34,10 +34,10 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from
-- | Sub-Query to retrieve StudyFeatures with their human-readable names
studyFeaturesQuery :: E.Esqueleto query expr backend
=> expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
-> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms)
-> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms))
studyFeaturesQuery
:: E.SqlExpr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
-> E.SqlExpr (Entity StudyFeatures) `E.InnerJoin` E.SqlExpr (Entity StudyDegree) `E.InnerJoin` E.SqlExpr (Entity StudyTerms)
-> E.SqlQuery (E.SqlExpr (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms))
studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
E.on $ terms E.^. StudyTermsId E.==. features E.^. StudyFeaturesField
E.on $ degree E.^. StudyDegreeId E.==. features E.^. StudyFeaturesDegree

6
src/Handler/Utils/DateTime.hs
View File

@ -75,7 +75,7 @@ instance HasLocalTime UTCTime where
instance HasLocalTime TimeOfDay where
toLocalTime = LocalTime systemEpochDay
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
-- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
@ -92,12 +92,12 @@ formatTimeW s t = toWidget =<< formatTime s t
formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
getTimeLocale :: MonadHandler m => m TimeLocale
getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = do
mauth <- liftHandlerT maybeAuth
mauth <- liftHandler maybeAuth
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
let
fmt

8
src/Handler/Utils/Delete.hs
View File

@ -29,12 +29,12 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
import qualified Database.Esqueleto.Internal.Language as E (From)
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From tables) => DeleteRoute
{ drRecords :: Set (Key record) -- ^ Records to be deleted
, drGetInfo :: tables -> E.SqlQuery infoExpr -- ^ SQL-Query to get necessary information to render identifing information about records to the user (`drRenderRecord`, `drRecordConfirmString`); @tables@ is an arbitrary join, see `E.from`; @infoExpr@ gets converted to @info@ by esqueleto
, drUnjoin :: tables -> E.SqlExpr (Entity record) -- ^ `E.SqlExpr` of @Key record@ extracted from @tables@, `deleteR` restricts `drGetInfo` to `drRecords` automatically
, drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting
, drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
, drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting
, drCaption
, drSuccessMessage :: SomeMessage UniWorX
, drAbort
@ -98,7 +98,7 @@ getDeleteR DeleteRoute{..} = do
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
Just targetRoute <- getCurrentRoute
targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute
let deleteForm = wrapForm deleteFormWdgt def
{ formAction = Just $ SomeRoute targetRoute
, formEncoding = deleteFormEnctype

62
src/Handler/Utils/Form.hs
View File

@ -214,7 +214,7 @@ optionalActionW' minp justAct fs defAction = aFormToWForm $ optionalActionA' min
multiAction :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
( RenderMessage UniWorX action, PathPiece action, Ord action )
=> Map action (AForm Handler a)
-> FieldSettings UniWorX
-> Maybe action
@ -235,22 +235,22 @@ multiAction acts fs@FieldSettings{..} defAction csrf = do
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
=> Map action (AForm Handler a)
-> FieldSettings UniWorX
-> Maybe action
-> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
=> Map action (AForm Handler a)
-> FieldSettings UniWorX
-> Maybe action
-> WForm Handler (FormResult a)
multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
=> Map action (AForm Handler a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, Widget))
@ -279,7 +279,7 @@ routeField :: ( Monad m
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
-- | Variant that simply removes leading and trailing white space
htmlField' :: Field (HandlerT UniWorX IO) Html
htmlField' :: Field Handler Html
htmlField' = htmlField
{ fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
}
@ -444,9 +444,11 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
specificFileForm = wFormToAForm $ do
Just currentRoute <- getCurrentRoute
currentRoute' <- getCurrentRoute
let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
miButtonAction frag = do
currentRoute <- currentRoute'
return . SomeRoute $ currentRoute :#: frag
miIdent <- ("specific-files--" <>) <$> newIdent
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
where
@ -647,7 +649,7 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
| otherwise
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ())
specificFileField UploadSpecificFile{..} = Field{..}
where
fieldEnctype = Multipart
@ -665,7 +667,7 @@ specificFileField UploadSpecificFile{..} = Field{..}
zipFileField :: Bool -- ^ Unpack zips?
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
-> Field Handler (Source Handler File)
-> Field Handler (ConduitT () File Handler ())
zipFileField doUnpack permittedExtensions = Field{..}
where
fieldEnctype = Multipart
@ -684,7 +686,7 @@ zipFileField doUnpack permittedExtensions = Field{..}
fileUploadForm :: Bool -- ^ Required?
-> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
-> UploadMode -> AForm Handler (Maybe (Source Handler File))
-> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ()))
fileUploadForm isReq mkFs = \case
NoUpload
-> pure Nothing
@ -693,21 +695,21 @@ fileUploadForm isReq mkFs = \case
UploadSpecific{..}
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
where
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ()))
specificFileForm spec@UploadSpecificFile{..}
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ())
mergeFileSources (catMaybes -> sources) = case sources of
[] -> Nothing
fs -> Just $ sequence_ fs
multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler (Source Handler (Either FileId File))
multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler (ConduitT () (Either FileId File) Handler ())
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
-> Field Handler (Source Handler (Either FileId File))
-> Field Handler (ConduitT () (Either FileId File) Handler ())
multiFileField permittedFiles' = Field{..}
where
fieldEnctype = Multipart
@ -723,7 +725,7 @@ multiFileField permittedFiles' = Field{..}
.| C.filter (`elem` pVals)
.| C.map Left
let
handleFile :: FileInfo -> Source Handler File
handleFile :: FileInfo -> ConduitT () File Handler ()
handleFile
| doUnpack = sourceFiles
| otherwise = yieldM . acceptFile
@ -887,7 +889,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel
langField :: Bool -- ^ Only allow values from `appLanguages`
-> Field (HandlerT UniWorX IO) Lang
-> Field Handler Lang
langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts
where langCheck (T.splitOn "-" -> lParts)
= all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
@ -910,7 +912,7 @@ jsonField hide = Field{..}
fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v)
fieldParse [] [] = return $ Right Nothing
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
fieldView theId name attrs val isReq = liftWidgetT [whamlet|
fieldView theId name attrs val isReq = liftWidget [whamlet|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|]
fieldEnctype = UrlEncoded
@ -1007,7 +1009,7 @@ fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site
, PersistQueryRead backend
, HasCryptoUUID (Key a) (HandlerT site IO)
, HasCryptoUUID (Key a) (HandlerFor site)
, RenderMessage site msg
, YesodPersistBackend site ~ backend
, PersistRecordBackend a backend
@ -1015,7 +1017,7 @@ optionsPersistCryptoId :: forall site backend a msg.
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Entity a))
-> HandlerFor site (OptionList (Entity a))
optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender
pairs <- runDB $ selectList filts ords
@ -1032,7 +1034,7 @@ examOccurrenceField :: ( MonadHandler m
=> ExamId
-> Field m ExamOccurrenceId
examOccurrenceField eid
= hoistField liftHandlerT . selectField . (fmap $ fmap entityKey)
= hoistField liftHandler . selectField . (fmap $ fmap entityKey)
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
@ -1068,7 +1070,7 @@ userMatriculationField = Field{..}
fieldParse ts _ = runExceptT . fmap Just $ do
let ts' = concatMap (Text.splitOn ",") ts
forM ts' $ \matr -> do
dbRes <- liftHandlerT . runDB . E.select . E.from $ \user -> do
dbRes <- liftHandler . runDB . E.select . E.from $ \user -> do
E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr)
return user
case dbRes of
@ -1102,7 +1104,7 @@ multiUserField onlySuggested suggestions = Field{..}
rEmails <- case lookupExpr of
Nothing -> return []
Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
dbRes <- liftHandlerT . runDB . E.select $ do
dbRes <- liftHandler . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserId E.==. E.val uid
return $ user E.^. UserEmail
@ -1119,7 +1121,7 @@ multiUserField onlySuggested suggestions = Field{..}
|]
whenIsJust suggestions $ \suggestions' -> do
suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandler . runDB . E.select $ do
user <- suggestions'
return $ user E.^. UserEmail
[whamlet|
@ -1135,14 +1137,14 @@ multiUserField onlySuggested suggestions = Field{..}
fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
Nothing -> return $ Left email
Just lookupExpr' -> do
dbRes <- liftHandlerT . runDB . E.select $ do
dbRes <- liftHandler . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserEmail E.==. E.val email
return $ user E.^. UserId
case dbRes of
[] -> return $ Left email
[E.Value uid] -> return $ Right uid
_other -> fail "Ambiguous e-mail addr"
_other -> throwE $ SomeMessage ("Ambiguous e-mail addr" :: Text)
examResultField :: forall m res.
( MonadHandler m
@ -1183,11 +1185,11 @@ examGradeField :: forall m.
, HandlerSite m ~ UniWorX
)
=> Field m ExamGrade
examGradeField = hoistField liftHandlerT $ selectField optionsFinite
examGradeField = hoistField liftHandler $ selectField optionsFinite
examPassedField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamPassed
examPassedField = hoistField liftHandlerT $ selectField optionsFinite
examPassedField = hoistField liftHandler $ selectField optionsFinite

26
src/Handler/Utils/Form/MassInput.hs
View File

@ -1,5 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Handler.Utils.Form.MassInput
( MassInput(..), MassInputLayout
@ -271,7 +271,7 @@ massInput :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
, MonadThrow handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
@ -414,7 +414,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
MsgRenderer mr <- getMsgRenderer
whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do
whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandler $ do
PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
ur <- getUrlRenderParams
@ -459,7 +459,7 @@ listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/mas
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
massInputList :: forall handler cellResult ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, PathPiece ident
)
=> Field handler cellResult
@ -488,7 +488,7 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m
massInputListA :: forall handler cellResult ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, PathPiece ident
)
=> Field handler cellResult
@ -505,7 +505,7 @@ massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired
-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
massInputAccum :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
@ -544,7 +544,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
massInputAccumA :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
@ -562,7 +562,7 @@ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq
massInputAccumW :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
@ -582,7 +582,7 @@ massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq
-- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added
massInputAccumEdit :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
@ -621,7 +621,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
massInputAccumEditA :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
@ -639,7 +639,7 @@ massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings
massInputAccumEditW :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, MonadThrow handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
@ -660,7 +660,7 @@ massInputA :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
, MonadThrow handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
@ -674,7 +674,7 @@ massInputW :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
, MonadThrow handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX

3
src/Handler/Utils/Form/Occurrences.hs
View File

@ -31,9 +31,10 @@ nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id
{-# ANN occurrencesAForm ("HLint: ignore Use const" :: String) #-}
occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences
occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
Just cRoute <- getCurrentRoute
cRoute <- fromMaybe (error "occurrencesAForm called from 404-handler") <$> getCurrentRoute
let
scheduled :: AForm Handler (Set OccurrenceSchedule)

73
src/Handler/Utils/Invitations.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Utils.Invitations
( -- * Procedure
@ -38,7 +39,7 @@ import qualified Data.Aeson as JSON
import Data.Proxy (Proxy(..))
import Data.Typeable
import Database.Persist.Sql (SqlBackendCanWrite, SqlBackendCanRead)
import Database.Persist.Sql (SqlBackendCanWrite)
class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
@ -169,11 +170,13 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju
sinkInvitations :: forall junction m backend.
( IsInvitableJunction junction
, MonadHandler m, SqlBackendCanWrite backend
, MonadHandler m
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
, HasPersistBackend backend
, HandlerSite m ~ UniWorX
)
=> InvitationConfig junction
-> Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
-> ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
-- | Register invitations in the database and send them by email
--
-- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
@ -181,9 +184,10 @@ sinkInvitations :: forall junction m backend.
-- (because the token-data may have changed)
sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
where
determineExists :: Conduit (Invitation' junction)
(ReaderT backend (WriterT (Set QueuedJobId) m))
(Invitation' junction)
determineExists :: ConduitT (Invitation' junction)
(Invitation' junction)
(ReaderT backend (WriterT (Set QueuedJobId) m))
()
determineExists
| is _Just (ephemeralInvitation @junction)
= C.map id
@ -203,10 +207,10 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
decode invData
= case fromJSON invData of
JSON.Success dbData -> return dbData
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do
sinkInvitations' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
sinkInvitations' = transPipe (hoist (hoist liftHandler) . withReaderT persistBackend) $ do
C.mapM_ $ \(jInvitee, fid, dat) -> do
app <- getYesod
let mr = renderMessage app $ NonEmpty.toList appLanguages
@ -214,15 +218,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
fEnt <- Entity fid <$> get404 fid
jInviter <- liftHandlerT requireAuthId
route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat
jInviter <- liftHandler requireAuthId
route <- mapReaderT liftHandler $ invitationRoute fEnt dat
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
jwt <- encodeToken token
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat)
jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation
{ invitationEmail = jInvitee
@ -237,7 +241,10 @@ sinkInvitationsF :: forall junction mono m backend.
( IsInvitableJunction junction
, MonoFoldable mono
, Element mono ~ Invitation' junction
, MonadHandler m, SqlBackendCanWrite backend
, MonadHandler m
, MonadThrow m
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
, HasPersistBackend backend
, HandlerSite m ~ UniWorX
)
=> InvitationConfig junction
@ -248,7 +255,10 @@ sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
sinkInvitation :: forall junction m backend.
( IsInvitableJunction junction
, MonadHandler m, SqlBackendCanWrite backend
, MonadHandler m
, MonadThrow m
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
, HasPersistBackend backend
, HandlerSite m ~ UniWorX
)
=> InvitationConfig junction
@ -260,23 +270,29 @@ sinkInvitation cfg = sinkInvitationsF cfg . Identity
sourceInvitations :: forall junction m backend.
( IsInvitableJunction junction
, MonadResource m, SqlBackendCanRead backend
, MonadResource m
, MonadThrow m
, PersistRecordBackend Invitation backend
, HasPersistBackend backend
)
=> Key (InvitationFor junction)
-> Source (ReaderT backend m) (UserEmail, InvitationDBData junction)
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
where
decode (Entity _ (Invitation{invitationEmail, invitationData}))
= case fromJSON invitationData of
JSON.Success dbData -> return (invitationEmail, dbData)
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
sourceInvitationsF :: forall junction map m backend.
( IsInvitableJunction junction
, IsMap map
, ContainerKey map ~ UserEmail
, MapValue map ~ InvitationDBData junction
, MonadResource m, SqlBackendCanRead backend
, MonadResource m
, MonadThrow m
, PersistRecordBackend Invitation backend
, HasPersistBackend backend
)
=> Key (InvitationFor junction)
-> ReaderT backend m map
@ -291,15 +307,17 @@ sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (
-- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId
deleteInvitations :: forall junction m backend.
( IsInvitableJunction junction
, MonadIO m, SqlBackendCanWrite backend
, MonadIO m
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
)
=> Key (InvitationFor junction)
-> Sink UserEmail (ReaderT backend m) ()
-> ConduitT UserEmail Void (ReaderT backend m) ()
deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k
deleteInvitationsF :: forall junction m mono backend.
( IsInvitableJunction junction
, MonadIO m, SqlBackendCanWrite backend
, MonadIO m
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
, MonoFoldable mono
, Element mono ~ UserEmail
)
@ -312,7 +330,8 @@ deleteInvitationsF invitationFor (otoList -> emailList)
deleteInvitation :: forall junction m backend.
( IsInvitableJunction junction
, MonadIO m, SqlBackendCanWrite backend
, MonadIO m
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
)
=> Key (InvitationFor junction)
-> UserEmail
@ -344,10 +363,10 @@ invitationR' :: forall junction m.
=> InvitationConfig junction
-> m Html
-- | Generic handler for incoming invitations
invitationR' InvitationConfig{..} = liftHandlerT $ do
invitationR' InvitationConfig{..} = liftHandler $ do
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
invitee <- requireAuthId
Just cRoute <- getCurrentRoute
cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k)
@ -356,7 +375,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
case fromJSON invitationData of
JSON.Success dbData -> return dbData
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
JSON.Error str -> throwM . PersistMarshalError $ "Could not decode invitationData: " <> pack str
Just (cloneIso -> _DBData) -> return $ view _DBData ()
let
iData :: InvitationData junction

20
src/Handler/Utils/Mail.hs
View File

@ -19,11 +19,10 @@ import Control.Monad.Trans.State (StateT)
addRecipientsDB :: ( MonadMail m
, MonadHandler m
, HandlerSite m ~ UniWorX
) => [Filter User] -> m ()
-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
where
addRecipient (Entity _ User{userEmail, userDisplayName}) = do
let addr = Address (Just userDisplayName) $ CI.original userEmail
@ -34,8 +33,8 @@ userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $
userMailT :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadBaseControl IO m
, MonadLogger m
, MonadThrow m
, MonadUnliftIO m
) => UserId -> MailT m a -> m a
userMailT uid mAct = do
user@User
@ -43,7 +42,7 @@ userMailT uid mAct = do
, userDateTimeFormat
, userDateFormat
, userTimeFormat
} <- liftHandlerT . runDB $ getJust uid
} <- liftHandler . runDB $ getJust uid
let
ctx = MailContext
{ mcLanguages = userMailLanguages
@ -57,14 +56,13 @@ userMailT uid mAct = do
mAct
addFileDB :: ( MonadMail m
, MonadHandler m
, HandlerSite m ~ UniWorX
) => FileId -> m MailObjectId
addFileDB fId = do
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
addPart $ do
) => FileId -> m (Maybe MailObjectId)
addFileDB fId = runMaybeT $ do
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId
lift . addPart $ do
_partType .= decodeUtf8 (mimeLookup fileName)
_partEncoding .= Base64
_partFilename .= Just fileName
_partContent .= LBS.fromStrict fileContent
setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId

10
src/Handler/Utils/Rating.hs
View File

@ -133,7 +133,7 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
parseRating :: MonadThrow m => File -> m Rating'
parseRating File{ fileContent = Just input, .. } = do
inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input
let
(headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
(reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
@ -143,20 +143,20 @@ parseRating File{ fileContent = Just input, .. } = do
rating = "Bewertung:"
comment' <- case commentLines of
(_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
_ -> throw RatingMissingSeparator
_ -> throwM RatingMissingSeparator
let
ratingComment
| Text.null comment' = Nothing
| otherwise = Just comment'
ratingLine' <- case ratingLines' of
[l] -> return l
_ -> throw RatingMultiple
_ -> throwM RatingMultiple
let
(_, ratingLine) = Text.breakOnEnd rating ratingLine'
ratingStr = Text.unpack $ Text.strip ratingLine
ratingPoints <- case () of
_ | null ratingStr -> return Nothing
| otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr
| otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr
return Rating'{ ratingTime = Just fileModified, .. }
parseRating _ = throwM RatingFileIsDirectory
@ -166,7 +166,7 @@ type SubmissionContent = Either File (SubmissionId, Rating')
extractRatings :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
) => Conduit File m SubmissionContent
) => ConduitT File SubmissionContent m ()
extractRatings = Conduit.mapM $ \f@File{..} -> do
msId <- isRatingFile fileTitle
case () of

8
src/Handler/Utils/Sheet.hs
View File

@ -16,13 +16,11 @@ sheetFileTypeDates Sheet{..} = \case
SheetMarking -> Nothing
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, E.SqlSelect b a
, Typeable a, MonadHandler m, IsPersistBackend backend
, PersistQueryRead backend, PersistUniqueRead backend
fetchSheetAux :: ( E.SqlSelect b a
, Typeable a, MonadHandler m
)
=> (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> SqlReadT m a
fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn)
in cachedBy cachId $ do

35
src/Handler/Utils/Submission.hs
View File

@ -252,7 +252,7 @@ planSubmissions sid restriction = do
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) ()
submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
@ -285,7 +285,7 @@ submissionMultiArchive (Set.toList -> ids) = do
setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip)
(<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do
let
fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File
fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> ConduitT () File (YesodDB UniWorX) ()
fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do
cID <- encrypt submissionID
@ -301,7 +301,7 @@ submissionMultiArchive (Set.toList -> ids) = do
| otherwise = submissionDirectory
fileEntitySource = do
submissionFileSource submissionID =$= Conduit.map entityVal
submissionFileSource submissionID .| Conduit.map entityVal
yieldM (ratingFile cID rating)
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
@ -316,9 +316,9 @@ submissionMultiArchive (Set.toList -> ids) = do
, fileContent = Nothing
}
fileEntitySource =$= mapC withinDirectory
fileEntitySource .| mapC withinDirectory
mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
mapM_ fileEntitySource' ratedSubmissions .| produceZip def .| Conduit.map toFlushBuilder
@ -331,9 +331,12 @@ data SubmissionSinkState = SubmissionSinkState
, sinkFilenames :: Set FilePath
} deriving (Show, Eq, Generic, Typeable)
instance Semigroup SubmissionSinkState where
(<>) = mappenddefault
instance Monoid SubmissionSinkState where
mempty = memptydefault
mappend = mappenddefault
mappend = (<>)
filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
@ -351,15 +354,13 @@ filterSubmission = do
extractRatings :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
) => ConduitM File SubmissionContent m (Set FilePath)
extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
extractRatingsMsg :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
) => Conduit File m SubmissionContent
) => ConduitT File SubmissionContent m ()
extractRatingsMsg = do
ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
@ -385,7 +386,7 @@ msgSubmissionErrors = flip catches
sinkSubmission :: UserId
-> Either SheetId SubmissionId
-> Bool -- ^ Is this a correction
-> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId
-- ^ Replace the currently saved files for the given submission (either
-- corrected files or original ones, depending on arguments) with the supplied
-- 'SubmissionContent'.
@ -420,7 +421,7 @@ sinkSubmission userId mExists isUpdate = do
where
tellSt = modify . mappend
guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent
guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m ()
guardFileTitles SubmissionMode{..}
| Just UploadAny{..} <- submissionModeUser
, not isUpdate
@ -435,7 +436,7 @@ sinkSubmission userId mExists isUpdate = do
| otherwise = Conduit.map id
sinkSubmission' :: SubmissionId
-> Sink SubmissionContent (YesodJobDB UniWorX) ()
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
Left file@(File{..}) -> do
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@ -628,7 +629,7 @@ sinkSubmission userId mExists isUpdate = do
sinkMultiSubmission :: UserId
-> Bool {-^ Are these corrections -}
-> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId)
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) (Set SubmissionId)
-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
--
@ -666,7 +667,7 @@ sinkMultiSubmission userId isUpdate = do
v@(Right (sId, _)) -> do
cID <- encrypt sId
$logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]
lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ])
(Left f@File{..}) -> do
let
acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
@ -678,7 +679,7 @@ sinkMultiSubmission userId isUpdate = do
sId <- decrypt (cID :: CryptoFileNameSubmission)
Just sId <$ get404 sId
| otherwise = return Nothing
msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
msId <- lift (lift (tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ])
return (msId, fp)
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
case msId of
@ -687,8 +688,8 @@ sinkMultiSubmission userId isUpdate = do
Just sId -> do
$logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
cID <- encrypt sId
handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
lift . feed sId $ Left f{ fileTitle = fileTitle' }
lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
feed sId $ Left f{ fileTitle = fileTitle' }
when (not $ null ignoredFiles) $ do
mr <- (toHtml .) <$> getMessageRender
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)

93
src/Handler/Utils/Table.hs
View File

@ -1,100 +1,7 @@
module Handler.Utils.Table
( module Handler.Utils.Table
) where
-- General Utilities for Tables
import Import
import Control.Monad.Except
import Text.Blaze as B
import Colonnade
import Yesod.Colonnade as Yesod
import Data.List ((!!))
import Data.Either
import Handler.Utils.Table.Pagination as Handler.Utils.Table
import Handler.Utils.Table.Columns as Handler.Utils.Table
import Handler.Utils.Table.Cells as Handler.Utils.Table
-- Table design
{-# DEPRECATED tableDefault, tableSortable "Use dbTable" #-}
tableDefault :: Attribute
tableDefault = customAttribute "class" "table table-striped table-hover"
tableSortable :: Attribute
tableSortable = customAttribute "class" "js-sortable"
-- Colonnade Tools
{-# DEPRECATED numberColonnade, pairColonnade "Use dbTable" #-}
numberColonnade :: (IsString c) => Colonnade Headed Int c
numberColonnade = headed "Nr" (fromString.show)
pairColonnade :: (Functor h) => Colonnade h a c -> Colonnade h b c -> Colonnade h (a,b) c
pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
-- Table Modification
{-# DEPRECATED encodeHeadedWidgetTableNumbered, headedRowSelector "Use dbTable" #-}
encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
encodeHeadedWidgetTableNumbered attrs colo tdata =
encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
where
numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
numberCol = headed "Nr" (fromString.show.fst)
headedRowSelector :: ( PathPiece b
, Eq b
)
=> (a -> Handler b)
-> (b -> Handler c)
-> Attribute
-> Colonnade Headed a (Cell UniWorX)
-> [a]
-> MForm Handler (FormResult [c], Widget)
headedRowSelector toExternal fromExternal attrs colonnade tdata = do
externalIds <- mapM (lift . toExternal) tdata
let
checkbox extId = Field{..}
where
fieldEnctype = UrlEncoded
fieldParse [] _ = return $ Right Nothing
fieldParse optlist _ = runExceptT $ do
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
case () of
_ | extId `elem` extIds
-> Just <$> lift (fromExternal extId)
| otherwise
-> return Nothing
fieldView theId name attributes val _ =
-- TODO: move this to a *.hamlet file
[whamlet|
<label style="display: block">
<input ##{theId} type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|]
selectionIdent <- newFormIdent
(selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \ident -> mopt (checkbox ident) ("" { fsName = Just selectionIdent }) Nothing
let
selColonnade :: Colonnade Headed Int (Cell UniWorX)
selColonnade = headed "Markiert" $ Yesod.cell . fvInput . (selectionBoxes !!)
collectResult :: [FormResult a] -> FormResult [a]
collectResult [] = FormSuccess []
collectResult (FormFailure errs : _) = FormFailure errs
collectResult (FormMissing:rs) = collectResult rs
collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
return ( catMaybes <$> collectResult selectionResults
, encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
)

62
src/Handler/Utils/Table/Cells.hs
View File

@ -1,8 +1,6 @@
module Handler.Utils.Table.Cells where
import Import
import qualified Control.Monad.Trans.RWS.Lazy
import Import hiding (link)
import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
@ -28,37 +26,17 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
-- Some basic cells are defined in Handler.Utils.Table.Pagination
-- such as: i18nCell, cellTooltip, anchorCell for links, etc.
----------------
-- Cell transformation
-- | Add cell attributes
addCellAttrs :: [(Text, Text)]
-> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
(Maybe (Env, FileEnv), UniWorX, [Lang])
Enctype
Ints
(HandlerT UniWorX IO))
x
-> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
(Maybe (Env, FileEnv), UniWorX, [Lang])
Enctype
Ints
(HandlerT UniWorX IO))
x
addCellAttrs newAttrs fcell = fcell { formCellAttrs = newAttrs <> formCellAttrs fcell } -- Isn't there already a lens for that?
----------------
-- Special cells
-- | Display a breakable space
spacerCell :: (IsDBTable m a) => DBCell m a
spacerCell :: IsDBTable m a => DBCell m a
spacerCell = cell [whamlet|&emsp;|]
tellCell :: (Monoid a, IsDBTable m a) => a -> DBCell m a -> DBCell m a
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
tellCell = flip mappend . writerCell . tell
cellTell :: (Monoid a, IsDBTable m a) => DBCell m a -> a -> DBCell m a
cellTell :: IsDBTable m a => DBCell m a -> a -> DBCell m a
cellTell = flip tellCell
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
@ -67,7 +45,7 @@ indicatorCell = writerCell . tell $ Any True
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
writerCell act = mempty & cellContents %~ (<* act)
maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a
maybeCell :: IsDBTable m a => Maybe a -> (a -> DBCell m a) -> DBCell m a
maybeCell = flip foldMap
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
@ -81,12 +59,12 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
sqlCell act = mempty & cellContents .~ lift act
-- | Highlight table cells with warning: Is not yet implemented in frontend.
markCell :: (IsDBTable m a) => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
markCell :: IsDBTable m a => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
markCell status condition normal x
| condition x = normal x & over cellAttrs (insertAttr "class" $ statusToUrgencyClass status)
| condition x = normal x & addCellClass (statusToUrgencyClass status)
| otherwise = normal x
ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
ifCell :: (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
ifCell decision cTrue cFalse x
| decision x = cTrue x
| otherwise = cFalse x
@ -105,22 +83,22 @@ msgCell = textCell . toMessage
iconCell :: IsDBTable m a => Icon -> DBCell m a
iconCell = cell . toWidget . icon
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text)
iconSpacerCell :: (IsDBTable m a) => DBCell m a
iconSpacerCell :: IsDBTable m a => DBCell m a
iconSpacerCell = mempty & addIconFixedWidth
-- | Maybe display a tickmark/checkmark icon
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell :: IsDBTable m a => Bool -> DBCell m a
tickmarkCell = cell . toWidget . hasTickmark
-- | Maybe display an icon for tainted rows
isBadCell :: (IsDBTable m a) => Bool -> DBCell m a
isBadCell :: IsDBTable m a => Bool -> DBCell m a
isBadCell = cell . toWidget . isBad
-- | Maybe display a exclamation icon
isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
isNewCell :: IsDBTable m a => Bool -> DBCell m a
isNewCell = cell . toWidget . isNew
-- | Maybe display comment icon linking a given URL or show nothing at all
@ -129,11 +107,11 @@ commentCell Nothing = mempty
commentCell (Just link) = anchorCell link $ hasComment True
-- | whether something is visible or hidden
isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
isVisibleCell :: IsDBTable m a => Bool -> DBCell m a
isVisibleCell True = cell . toWidget $ isVisible True
isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
where
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
-- | for simple file downloads
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
@ -171,7 +149,7 @@ dateTimeCellVisible watershed t
| otherwise = cell timeStampWgt
where
timeStampWgt = formatTimeW SelFormatDateTime t
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
userCell displayName surname = cell $ nameWidget displayName surname
@ -218,13 +196,13 @@ cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _s
maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
maybeDateTimeCell = maybe mempty dateTimeCell
numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a
numCell :: (IsDBTable m a, ToMessage b) => b -> DBCell m a
numCell = textCell . toMessage
propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a
propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
int64Cell :: IsDBTable m a => Int64-> DBCell m a
int64Cell = numCell
termCell :: IsDBTable m a => TermId -> DBCell m a
@ -269,7 +247,7 @@ sheetCell crse shn =
let tid = crse ^. _1
ssh = crse ^. _2
csh = crse ^. _3
link= CSheetR tid ssh csh shn SShowR
link = CSheetR tid ssh csh shn SShowR
in anchorCell link $ toWgt shn
submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a

8
src/Handler/Utils/Table/Columns.hs
View File

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Utils.Table.Columns where
import Import
import Import hiding (link)
-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
@ -323,7 +325,7 @@ colApplicationId :: OpticColonnade CourseApplicationId
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
where
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication)
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
@ -813,7 +815,7 @@ anchorColonnadeM :: forall h r' m a url.
, IsDBTable m a
, HandlerSite m ~ UniWorX
)
=> (r' -> WidgetT UniWorX IO url)
=> (r' -> WidgetFor UniWorX url)
-> Colonnade h r' (DBCell m a)
-> Colonnade h r' (DBCell m a)
anchorColonnadeM mkUrl = imapColonnade anchorColonnade'

171
src/Handler/Utils/Table/Pagination.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
module Handler.Utils.Table.Pagination
( module Handler.Utils.Table.Pagination.Types
, dbFilterKey
@ -17,6 +19,7 @@ module Handler.Utils.Table.Pagination
, singletonFilter
, DBParams(..)
, cellAttrs, cellContents
, addCellClass
, PagesizeLimit(..)
, PaginationSettings(..), PaginationInput(..), piIsUnset
, PSValidator(..)
@ -50,6 +53,9 @@ import Utils
import Utils.Lens
import Import hiding (pi)
import qualified Yesod.Form.Functions as Yesod
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
@ -521,7 +527,7 @@ data DBTCsvEncode r' k' csv = forall exportData.
) => DBTCsvEncode
{ dbtCsvExportForm :: AForm (YesodDB UniWorX) exportData
, dbtCsvHeader :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
, dbtCsvDoEncode :: exportData -> Conduit (k', r') (YesodDB UniWorX) csv
, dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) ()
, dbtCsvName :: FilePath
, dbtCsvNoExportData :: Maybe (AnIso' exportData ())
}
@ -535,10 +541,10 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
, Exception csvException
) => DBTCsvDecode
{ dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> Source (YesodDB UniWorX) csvAction
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
, dbtCsvClassifyAction :: csvAction -> csvActionClass
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
, dbtCsvExecuteActions :: Sink csvAction (YesodDB UniWorX) route
, dbtCsvExecuteActions :: ConduitT csvAction Void (YesodDB UniWorX) route
, dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
, dbtCsvRenderActionClass :: csvActionClass -> Widget
, dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
@ -548,7 +554,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
( ToSortable h, Functor h
, E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
, PathPiece i, Eq i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
, E.From t
) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a
, dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
@ -622,14 +628,17 @@ cellAttrs = dbCell . _1
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2
instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = ()
addCellClass :: (IsDBTable m x, PathPiece t) => t -> DBCell m x -> DBCell m x
addCellClass = over cellAttrs . Yesod.addClass . toPathPiece
data DBCell (HandlerT UniWorX IO) x = WidgetCell
instance Monoid' x => IsDBTable (HandlerFor UniWorX) x where
data DBParams (HandlerFor UniWorX) x = DBParamsWidget
type DBResult (HandlerFor UniWorX) x = (x, Widget)
-- type DBResult' (WidgetFor UniWorX) () = ()
data DBCell (HandlerFor UniWorX) x = WidgetCell
{ wgtCellAttrs :: [(Text, Text)]
, wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
, wgtCellContents :: WriterT x (HandlerFor UniWorX) Widget
}
dbCell = iso
@ -639,25 +648,25 @@ instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
runDBTable _ _ _ = liftHandlerT
runDBTable _ _ _ = liftHandler
instance Monoid' x => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
instance Monoid' x => Sem.Semigroup (DBCell (HandlerFor UniWorX) x) where
(WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')
instance Monoid' x => Monoid (DBCell (HandlerT UniWorX IO) x) where
instance Monoid' x => Monoid (DBCell (HandlerFor UniWorX) x) where
mempty = WidgetCell mempty $ return mempty
mappend = (<>)
instance Default (DBParams (HandlerT UniWorX IO) x) where
instance Default (DBParams (HandlerFor UniWorX) x) where
def = DBParamsWidget
instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerFor UniWorX)) x where
data DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBParamsDB
type DBResult (ReaderT SqlBackend (HandlerFor UniWorX)) x = (x, Widget)
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
data DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBCell
{ dbCellAttrs :: [(Text, Text)]
, dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
, dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerFor UniWorX)) Widget
}
dbCell = iso
@ -666,17 +675,17 @@ instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x whe
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable _ _ _ = mapReaderT liftHandlerT
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerFor UniWorX) ((), Widget) -> m (Widget)
runDBTable _ _ _ = mapReaderT liftHandler
instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
(DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')
instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
mempty = DBCell mempty $ return mempty
mappend = (<>)
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Default (DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
def = DBParamsDB
data DBParamsFormIdent where
@ -692,29 +701,29 @@ unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toP
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. DBParamsForm
{ dbParamsFormMethod :: StdMethod
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
, dbParamsFormAttrs :: [(Text, Text)]
, dbParamsFormSubmit :: FormSubmitType
, dbParamsFormAdditional :: Form a
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerFor UniWorX) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
, dbParamsFormResult :: Lens' x (FormResult a)
, dbParamsFormIdent :: DBParamsFormIdent
}
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = (x, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a) = (FormResult a, Enctype)
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. FormCell
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. FormCell
{ formCellAttrs :: [(Text, Text)]
, formCellContents :: WriterT x (MForm (HandlerT UniWorX IO)) (FormResult a, Widget)
, formCellContents :: WriterT x (MForm (HandlerFor UniWorX)) (FormResult a, Widget)
, formCellLens :: Lens' x (FormResult a)
}
-- dbCell :: Iso'
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) x)
-- ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
-- (DBCell (RWST ... ... ... (HandlerFor UniWorX)) x)
-- ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerFor UniWorX)) Widget)
dbCell = iso
(\FormCell{..} -> (formCellAttrs, formCellContents >>= uncurry ($>) . over _1 (tell . (flip $ set formCellLens) mempty)))
(\(attrs, mkWidget) -> FormCell attrs ((pure (), ) <$> mkWidget) $ lens (\_ -> pure ()) (\s _ -> s))
@ -723,7 +732,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerFor UniWorX)) x -> PaginationInput -> [k'] -> (MForm (HandlerFor UniWorX)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
= fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
. dbParamsFormEvaluate
@ -741,19 +750,19 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
adjResult _ = FormFailure $ pure reasonTxt
return $ over (_1 . dbParamsFormResult) adjResult result
instance Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
def = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \_ -> return (pure (), mempty)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s)
, dbParamsFormIdent = def
}
dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerFor UniWorX)) x -> DBParams (MForm (HandlerFor UniWorX)) x -> (Html -> MForm (HandlerFor UniWorX) (x, Widget)) -> (Html -> MForm (HandlerFor UniWorX) (x, Widget))
dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
((res, fWidget), enctype) <- listen form
@ -788,10 +797,10 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
(FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
mappend = (<>)
@ -846,7 +855,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass ("select--pagesize" :: Text)) (Just referencePagesize)
return (filterRes', pagesizeRes')
let
@ -870,8 +879,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
mapM_ (addMessageI Warning) errs
Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
getParams <- liftHandler $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
@ -974,14 +983,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
hdr <- dbtCsvHeader $ Just exportData
let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName
setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName
sendResponse <=< liftHandlerT . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
DBCsvImport{..}
| Just DBTCsvEncode{..} <- dbtCsvEncode
, Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
, ..
} :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
let existing = Map.fromList $ zip currentKeys rows
sourceDiff :: Source (StateT (Map k' csv) (YesodDB UniWorX)) (DBCsvDiff r' csv k')
sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) (YesodDB UniWorX)) ()
sourceDiff = do
let
toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
@ -1010,7 +1019,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
importCsv = do
let
dbtCsvComputeActions' :: Sink (DBCsvDiff r' csv k') (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
dbtCsvComputeActions' = do
let innerAct = awaitForever $ \x
-> let doHandle
@ -1026,7 +1035,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
addMessageI Info MsgCsvImportUnnecessary
redirect $ tblLink id
liftHandlerT . (>>= sendResponse) $
liftHandler . (>>= sendResponse) $
siteLayoutMsg MsgCsvImportConfirmationHeading $ do
setTitleI MsgCsvImportConfirmationHeading
@ -1042,14 +1051,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget
csvActionCheckBox vAttrs act = do
let
sJsonField :: Field (HandlerT UniWorX IO) csvAction
sJsonField :: Field (HandlerFor UniWorX) csvAction
sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
[whamlet|
$newline never
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
|]
fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
(csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandlerT . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
(csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings
{ formMethod = POST
, formAction = Just $ tblLink id
@ -1065,7 +1074,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
catches importCsv
[ Catch.Handler $ \case
(DBCsvDuplicateKey{..} :: DBCsvException k')
-> liftHandlerT $ sendResponseStatus badRequest400 =<< do
-> liftHandler $ sendResponseStatus badRequest400 =<< do
mr <- getMessageRender
let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
@ -1079,7 +1088,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
^{offendingCsv}
|]
(DBCsvException{..} :: DBCsvException k')
-> liftHandlerT $ sendResponseStatus badRequest400 =<< do
-> liftHandler $ sendResponseStatus badRequest400 =<< do
mr <- getMessageRender
let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ]
@ -1107,7 +1116,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
. setParam (wIdent "page") Nothing
. setParam (wIdent "pagination") Nothing
table' :: HandlerSite m ~ UniWorX => WriterT x m Widget
table' :: WriterT x m Widget
table' = let
columnCount :: Int64
columnCount = olength64 $ getColonnade dbtColonnade
@ -1191,7 +1200,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
tbl <- liftHandlerT $ widgetToPageContent tbl'
tbl <- liftHandler $ widgetToPageContent tbl'
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
setParams :: Text -> [Text] -> QueryText -> QueryText
@ -1200,26 +1209,27 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key = setParams key . maybeToList
dbTableWidget :: Monoid' x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-> DB (DBResult (HandlerT UniWorX IO) x)
dbTableWidget :: Monoid x
=> PSValidator (HandlerFor UniWorX) x
-> DBTable (HandlerFor UniWorX) x
-> DB (DBResult (HandlerFor UniWorX) x)
dbTableWidget = dbTable
dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
dbTableWidget' :: PSValidator (HandlerFor UniWorX) ()
-> DBTable (HandlerFor UniWorX) ()
-> DB Widget
dbTableWidget' = fmap (fmap snd) . dbTable
widgetColonnade :: (Headedness h, Monoid' x)
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id
formColonnade :: (Headedness h, Monoid' a)
=> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id
dbColonnade :: (Headedness h, Monoid' x)
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade :: Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
dbColonnade = id
pagesizeOptions :: PagesizeLimit -- ^ Current/previous value
@ -1280,17 +1290,17 @@ anchorCell' :: ( IsDBTable m a
-> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
-- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell = linkEitherCellM . return
linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a
linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => WidgetFor UniWorX url -> (wgt, wgt') -> DBCell m a
linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)
linkEitherCellM' :: forall m url wgt wgt' a x.
@ -1298,16 +1308,15 @@ linkEitherCellM' :: forall m url wgt wgt' a x.
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
, HandlerSite m ~ UniWorX
)
=> WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
=> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
x <- xM
let route = x2route x
widget, widgetUnauth :: WidgetT UniWorX IO ()
widget, widgetUnauth :: Widget
widget = toWidget $ x2widgetAuth x
widgetUnauth = toWidget $ x2widgetUnauth x
authResult <- liftHandlerT $ isAuthorized (urlRoute route) False
authResult <- liftHandler $ isAuthorized (urlRoute route) False
linkUrl <- toTextUrl route
case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
@ -1333,17 +1342,17 @@ instance Ord i => Monoid (DBFormResult i a r) where
mempty = DBFormResult Map.empty
mappend = (<>)
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult :: forall r i a. (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall x r i a. (Ord i, Monoid x)
formCell :: forall x r i a. Monoid x
=> Lens' x (FormResult (DBFormResult i a (DBRow r))) -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
-> (DBRow r -> MForm (HandlerT UniWorX IO) i) -- ^ generate row identfifiers for use in form result
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) x)
-> (DBRow r -> MForm (HandlerFor UniWorX) i) -- ^ generate row identfifiers for use in form result
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerFor UniWorX) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerFor UniWorX)) x)
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
{ formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
, formCellContents = do -- MForm (HandlerFor UniWorX) (FormResult (Map i (Endo a)), Widget)
i <- lift $ genIndex input
hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
let
@ -1363,11 +1372,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid' x)
dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
-> (DBRow r -> MForm (HandlerFor UniWorX) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty) $ formCell resLens genIndex genForm
where

3
src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs
View File

@ -57,8 +57,7 @@ instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 C c a) where
-- | Instance to ensure that you cannot derive DefaultOrdered for
-- constructors without selectors.
instance CsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a ())
=> GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
instance GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
where
gCsvColumnsExplanations _ _ =
error "You cannot derive CsvColumnsExplanations for constructors without selectors."

1
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -18,6 +18,7 @@ import Data.CaseInsensitive (CI)
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
deriving (Show, Read, Generic)

24
src/Handler/Utils/Tokens.hs
View File

@ -17,7 +17,7 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
]
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandlerT $ do
requireBearerToken = liftHandler $ do
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
@ -25,18 +25,24 @@ requireBearerToken = liftHandlerT $ do
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
return token
maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
requireCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
requireCurrentTokenRestrictions = runMaybeT $ do
token <- requireBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ token ^? _tokenRestrictionIx route
maybeCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
maybeCurrentTokenRestrictions = runMaybeT $ do
token <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute

94
src/Handler/Utils/Zip.hs
View File

@ -30,6 +30,15 @@ import Data.List (dropWhileEnd)
import qualified Data.Map as Map
import qualified Data.Conduit.List as C
import Data.Encoding ( decodeStrictByteStringExplicit
, encodeStrictByteStringExplicit
)
import Data.Encoding.CP437
import qualified Data.Char as Char
typeZip :: ContentType
typeZip = "application/zip"
@ -45,30 +54,33 @@ instance Default ZipInfo where
}
consumeZip :: ( MonadBase b m
, PrimMonad b
consumeZip :: forall b m.
( MonadThrow b
, MonadThrow m
) => ConduitM ByteString File m ZipInfo
consumeZip = unZipStream `fuseUpstream` consumeZip'
, MonadBase b m
, PrimMonad b
)
=> ConduitT ByteString File m ZipInfo
consumeZip = transPipe liftBase unZipStream `fuseUpstream` consumeZip'
where
consumeZip' :: ( MonadThrow m
) => Conduit (Either ZipEntry ByteString) m File
consumeZip' :: ConduitT (Either ZipEntry ByteString) File m ()
consumeZip' = do
input <- await
case input of
Nothing -> return ()
Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Right _) -> throwM $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Left ZipEntry{..}) -> do
contentChunks <- toConsumer accContents
zipEntryName' <- decodeZipEntryName zipEntryName
let
fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName
fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName'
fileModified = localTimeToUTC utc zipEntryTime
fileContent
| hasTrailingPathSeparator zipEntryName = Nothing
| hasTrailingPathSeparator zipEntryName' = Nothing
| otherwise = Just $ mconcat contentChunks
yield File{..}
consumeZip'
accContents :: Monad m => Sink (Either a b) m [b]
accContents :: ConduitT (Either a b') Void m [b']
accContents = do
input <- await
case input of
@ -76,12 +88,15 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
Just (Left x) -> [] <$ leftover (Left x)
_ -> return []
produceZip :: ( MonadBase b m
, PrimMonad b
, MonadThrow m
) => ZipInfo
-> Conduit File m ByteString
produceZip info = mapC toZipData =$= void (zipStream zipOptions)
produceZip :: forall b m.
( MonadThrow b
, MonadThrow m
, MonadBase b m
, PrimMonad b
)
=> ZipInfo
-> ConduitT File ByteString m ()
produceZip info = C.map toZipData .| transPipe liftBase (void $ zipStream zipOptions)
where
zipOptions = ZipOptions
{ zipOpt64 = True
@ -89,35 +104,60 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
, zipOptInfo = info
}
toZipData :: Monad m => File -> (ZipEntry, ZipData m)
toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
toZipData :: File -> (ZipEntry, ZipData b)
toZipData f@File{..} =
let zData = maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent
zEntry = (toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }
in (zEntry, zData)
toZipEntry :: File -> ZipEntry
toZipEntry File{..} = ZipEntry
{ zipEntryName = bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
, zipEntryTime = utcToLocalTime utc fileModified
}
toZipEntry File{..} = ZipEntry{..}
where
isDir = isNothing fileContent
zipEntryName = encodeZipEntryName . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise $ makeValid fileTitle
zipEntryTime = utcToLocalTime utc fileModified
zipEntrySize = Nothing
zipEntryExternalAttributes = Nothing
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT File File m ()
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m ()
sourceFiles fInfo
| ((==) `on` simpleContentType) mimeType typeZip = do
$logInfoS "sourceFiles" "Unpacking ZIP"
fileSource fInfo =$= void consumeZip
fileSource fInfo .| void consumeZip
| otherwise = do
$logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|]
yieldM $ acceptFile fInfo
where
mimeType = mimeLookup $ fileName fInfo
acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
acceptFile :: MonadResource m => FileInfo -> m File
acceptFile fInfo = do
let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
fileModified <- liftIO getCurrentTime
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
fileContent <- fmap Just . runConduit $ fileSource fInfo .| foldC
return File{..}
decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath
-- ^ Extract the filename from a 'ZipEntry' doing decoding along the way.
--
-- Throws 'Data.Encoding.Exception.DecodingException's.
decodeZipEntryName = \case
Left t -> return $ unpack t
Right cp437 -> either throwM return $ decodeStrictByteStringExplicit CP437 cp437
encodeZipEntryName :: FilePath -> Either Text ByteString
-- ^ Encode a filename for use in a 'ZipEntry', encodes as
-- 'Data.Encoding.UTF8.UTF8' iff the given path contains non-ascii characters.
--
-- Does not do any normalisation (in particular this function does not ensure
-- that the 'FilePath' does not start with a slash).
encodeZipEntryName path = fromMaybe (Left $ pack path) $ do
guard $ all Char.isAscii path
either (const mzero) (return . Right) $ encodeStrictByteStringExplicit CP437 path

13
src/Import/NoModel.hs
View File

@ -12,11 +12,15 @@ import ClassyPrelude.Yesod as Import
, Proxy
, foldlM
, static
, boolField, identifyForm
, boolField, identifyForm, addClass
, HasHttpManager(..)
, embed
, try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
, fail
)
import UnliftIO.Async.Utils as Import
import Model.Types.TH.JSON as Import
import Model.Types.TH.Wordlist as Import
@ -44,7 +48,7 @@ import Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe as Import
import Data.Universe.TH as Import
import Data.Pool as Import (Pool)
import UnliftIO.Pool as Import (Pool)
import Network.HaskellNet.SMTP as Import (SMTPConnection)
import Data.Data as Import (Data)
@ -80,6 +84,10 @@ import Control.Monad.Trans.Reader as Import
( reader, Reader, runReader, mapReader, withReader
, ReaderT(..), mapReaderT, withReaderT
)
import Control.Monad.Base as Import
import Control.Monad.Catch as Import hiding (Handler(..))
import Control.Monad.Trans.Control as Import hiding (embed)
import Control.Monad.Fail as Import
import Jose.Jwt as Import (Jwt)
@ -101,7 +109,6 @@ import Algebra.Lattice as Import hiding (meet, join)
import Data.Proxy as Import (Proxy(..))
import Language.Haskell.TH.Instances as Import ()
import Data.List.NonEmpty.Instances as Import ()
import Data.NonNull.Instances as Import ()
import Data.Monoid.Instances as Import ()
import Data.Maybe.Instances as Import ()

51
src/Jobs.hs
View File

@ -44,7 +44,7 @@ import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
import qualified Control.Monad.State.Class as State
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Cont (ContT(..), callCC)
import Control.Monad.Random.Lazy (evalRandTIO, mapRandT)
@ -55,6 +55,8 @@ import Data.Time.Zones
import Control.Concurrent.STM (retry)
import Control.Concurrent.STM.Delay
import UnliftIO.Concurrent (forkIO)
import Jobs.Handler.SendNotification
import Jobs.Handler.SendTestEmail
@ -82,7 +84,8 @@ instance Exception JobQueueException
handleJobs :: ( MonadResource m
, MonadLoggerIO m
, MonadLogger m
, MonadUnliftIO m
)
=> UniWorX -> m ()
-- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
@ -92,12 +95,11 @@ handleJobs :: ( MonadResource m
handleJobs foundation@UniWorX{..}
| foundation ^. _appJobWorkers == 0 = return ()
| otherwise = do
logger <- askLoggerIO
let runInIO = flip runLoggingT logger . runResourceT
UnliftIO{..} <- askUnliftIO
jobPoolManager <- allocateLinkedAsync . runInIO $ manageJobPool foundation
jobPoolManager <- allocateLinkedAsync . unliftIO $ manageJobPool foundation
jobCron <- allocateLinkedAsync . runInIO $ manageCrontab foundation
jobCron <- allocateLinkedAsync . unliftIO $ manageCrontab foundation
let jobWorkers = Map.empty
jobWorkerName = const $ error "Unknown worker"
@ -109,11 +111,9 @@ handleJobs foundation@UniWorX{..}
, ..
}
manageJobPool, manageCrontab :: forall m.
( MonadResource m
, MonadLogger m
)
=> UniWorX -> m ()
manageCrontab :: forall m.
MonadResource m
=> UniWorX -> m ()
manageCrontab foundation@UniWorX{..} = do
context <- atomically . fmap jobContext $ readTMVar appJobState
let awaitTermination = atomically $ do
@ -125,7 +125,12 @@ manageCrontab foundation@UniWorX{..} = do
writeJobCtlBlock JobCtlDetermineCrontab
evalRWST (forever execCrontab) context HashMap.empty
manageJobPool :: forall m.
( MonadResource m
, MonadLogger m
, MonadUnliftIO m
)
=> UniWorX -> m ()
manageJobPool foundation@UniWorX{..}
= flip runContT return . forever . join . atomically $ asum
[ spawnMissingWorkers
@ -163,7 +168,7 @@ manageJobPool foundation@UniWorX{..}
$logInfoS logIdent "Started"
runConduit $ streamChan .| handleJobs' workerId
$logInfoS logIdent "Stopped"
worker <- allocateLinkedAsync runWorker
worker <- lift . lift $ allocateLinkedAsync runWorker
tell . Endo $ \cSt -> cSt
{ jobWorkers = Map.insert worker chan $ jobWorkers cSt
@ -203,24 +208,24 @@ manageJobPool foundation@UniWorX{..}
$logInfoS "JobPoolManager" "Shutting down"
terminate ()
stopJobCtl :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
stopJobCtl :: MonadUnliftIO m => UniWorX -> m ()
-- ^ Stop all worker threads currently running
stopJobCtl UniWorX{appJobState} = do
didStop <- atomically $ do
jState <- tryReadTMVar appJobState
for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown ()
whenIsJust didStop $ \jSt' -> void . fork . atomically $ do
whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do
workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState
mapM_ (void . waitCatchSTM) $
[ jobPoolManager jSt'
, jobCron jSt'
] ++ workers
execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerT UniWorX IO) ()
execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = do
mapRWST (liftHandlerT . runDB . setSerializable) $ do
mapRWST (liftHandler . runDB . setSerializable) $ do
let
mergeLastExec (Entity _leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
@ -251,7 +256,7 @@ execCrontab = do
-- now <- liftIO getCurrentTime
-- $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
let doJob = mapRWST (liftHandlerT . runDBJobs . setSerializable) $ do
let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
newCrontab <- lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
@ -305,7 +310,7 @@ execCrontab = do
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil :: (Eq a, MonadUnliftIO m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
@ -328,7 +333,7 @@ execCrontab = do
mkLogIdent :: JobWorkerId -> Text
mkLogIdent wId = "Job-Executor " <> showWorkerId wId
handleJobs' :: JobWorkerId -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) ()
handleJobs' wNum = C.mapM_ $ \jctl -> do
$logDebugS logIdent $ tshow jctl
res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
@ -348,7 +353,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
handleCmd JobCtlTest = return ()
handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (lift . writeJobCtl . JobCtlPerform)
handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod)
handleCmd (JobCtlQueue job) = lift $ queueJob' job
handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
content <- case fromJSON queuedJobContent of
@ -379,7 +384,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
]
delete jId
handleCmd JobCtlDetermineCrontab = do
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
newCTab <- liftHandler . runDB $ setSerializable determineCrontab'
-- logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . void . flip swapTVar newCTab =<< asks jobCrontab
@ -454,5 +459,5 @@ determineCrontab' :: DB (Crontab JobCtl)
determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
performJob :: Job -> HandlerT UniWorX IO ()
performJob :: Job -> HandlerFor UniWorX ()
performJob = $(dispatchTH ''Job)

2
src/Jobs/Handler/HelpRequest.hs
View File

@ -19,7 +19,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
supportAddress <- view _appMailSupport
supportAddress <- getsYesod $ view _appMailSupport
userInfo <- bitraverse return (runDB . getEntity) jSender
let senderAddress = either
id

10
src/Jobs/Handler/SendNotification/Allocation.hs
View File

@ -21,7 +21,7 @@ import qualified Database.Esqueleto.Utils as E
dispatchNotificationAllocationStaffRegister :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT jRecipient $ do
Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
Allocation{..} <- liftHandler . runDB $ getJust nAllocation
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectAllocationStaffRegister allocationName
@ -32,7 +32,7 @@ dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT j
dispatchNotificationAllocationRegister :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecipient $ do
Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
Allocation{..} <- liftHandler . runDB $ getJust nAllocation
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectAllocationRegister allocationName
@ -43,7 +43,7 @@ dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecip
dispatchNotificationAllocationAllocation :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationAllocation nAllocation jRecipient = do
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
(Allocation{..}, courses) <- runDB $ do
allocation <- getJust nAllocation
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
@ -75,7 +75,7 @@ dispatchNotificationAllocationAllocation nAllocation jRecipient = do
dispatchNotificationAllocationUnratedApplications :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
(Allocation{..}, courses) <- runDB $ do
allocation <- getJust nAllocation
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
@ -117,7 +117,7 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
dispatchNotificationAllocationOutdatedRatings :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
(Allocation{..}, courses) <- runDB $ do
allocation <- getJust nAllocation
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId

2
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -14,7 +14,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}, nbrSubs) <- runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet

2
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs
View File

@ -11,7 +11,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}, nbrSubs) <- runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet

6
src/Jobs/Handler/SendNotification/ExamActive.hs
View File

@ -16,7 +16,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Handler ()
dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)
@ -37,7 +37,7 @@ dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipie
dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Handler ()
dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)
@ -58,7 +58,7 @@ dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jR
dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Handler ()
dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)

4
src/Jobs/Handler/SendNotification/ExamOffice.hs
View File

@ -18,7 +18,7 @@ import qualified Data.Set as Set
dispatchNotificationExamOfficeExamResults :: ExamId -> UserId -> Handler ()
dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)
@ -43,7 +43,7 @@ dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do
let exams = Set.fromList $ map (examResultExam . entityVal) entitiesExamResults
forM_ exams $ \nExam -> userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)

2
src/Jobs/Handler/SendNotification/ExamResult.hs
View File

@ -14,7 +14,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationExamResult :: ExamId -> UserId -> Handler ()
dispatchNotificationExamResult nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)

2
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -14,7 +14,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationSheetActive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}) <- liftHandler . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)

6
src/Jobs/Handler/SendNotification/SheetInactive.hs
View File

@ -17,7 +17,7 @@ import qualified Database.Esqueleto as E
dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}) <- liftHandler . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
@ -38,11 +38,11 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}, nrSubs, nrSubmitters) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}, nrSubs, nrSubmitters) <- liftHandler . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nrSubs <- count [SubmissionSheet ==. nSheet]
(E.Value nrSubmitters:_) <- E.select . E.from $ \(subUser `E.InnerJoin` submission) -> do
nrSubmitters <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(subUser `E.InnerJoin` submission) -> do
E.on $ subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.where_ $ submission E.^. SubmissionSheet E.==. E.val nSheet
-- E.distinctOn [E.don (subUser E.^. SubmissionUserUser)] -- Not necessary due to UniqueSubmisionUser

2
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandler . runDB $ do
submission@Submission{submissionRatingBy} <- getJust nSubmission
sheet <- belongsToJust submissionSheet submission
course <- belongsToJust sheetCourse sheet

2
src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs
View File

@ -16,7 +16,7 @@ import Text.Hamlet
dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler ()
dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do
User{..} <- liftHandlerT . runDB $ getJust nUser
User{..} <- liftHandler . runDB $ getJust nUser
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailSubjectUserAuthModeUpdate

2
src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
View File

@ -17,7 +17,7 @@ import Text.Hamlet
dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Handler ()
dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMailT jRecipient $ do
(User{..}, functions) <- liftHandlerT . runDB $ do
(User{..}, functions) <- liftHandler . runDB $ do
user <- getJust nUser
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. nUser] []
return (user, functions)

2
src/Jobs/Handler/SendNotification/Utils.hs
View File

@ -14,7 +14,7 @@ ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n
ihamletSomeMessage f trans = f $ trans . SomeMessage
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandlerT $ do
mkEditNotifications uid = liftHandler $ do
cID <- encrypt uid
jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let

2
src/Jobs/Handler/SendPasswordReset.hs
View File

@ -17,7 +17,7 @@ dispatchJobSendPasswordReset :: UserId
-> Handler ()
dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
cID <- encrypt jRecipient
User{..} <- liftHandlerT . runDB $ getJust jRecipient
User{..} <- liftHandler . runDB $ getJust jRecipient
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailSubjectPasswordReset

4
src/Jobs/Handler/SendTestEmail.hs
View File

@ -17,11 +17,11 @@ dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
nDT <- formatTimeMail SelFormatDateTime now
nD <- formatTimeMail SelFormatDate now
nT <- formatTimeMail SelFormatTime now
addPart $ \(MsgRenderer mr) -> ([text|
addPart $ \(MsgRenderer mr) -> [text|
#{mr MsgMailTestContent}
#{mr MsgMailTestDateTime}
* #{nDT}
* #{nD}
* #{nT}
|] :: TextUrl (Route UniWorX))
|] :: TextUrl (Route UniWorX)

2
src/Jobs/Handler/SetLogSettings.hs
View File

@ -7,6 +7,6 @@ import Import
dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler ()
dispatchJobSetLogSettings jInstance jLogSettings = do
instanceId <- getsYesod appInstanceID
unless (instanceId == jInstance) $ fail "Incorrect instance"
unless (instanceId == jInstance) . liftIO $ fail "Incorrect instance"
lSettings <- getsYesod appLogSettings
atomically $ writeTVar lSettings jLogSettings

4
src/Jobs/Handler/SynchroniseLdap.hs
View File

@ -23,10 +23,10 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
= runDBJobs . runConduit $
readUsers .| filterIteration .| sinkDBJobs
where
readUsers :: Source (YesodJobDB UniWorX) UserId
readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
readUsers = selectKeys [] []
filterIteration :: Conduit UserId (YesodJobDB UniWorX) Job
filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
let
userIteration, currentIteration :: Integer

6
src/Jobs/HealthReport.hs
View File

@ -24,11 +24,11 @@ import Auth.LDAP
import qualified Data.CaseInsensitive as CI
import qualified Network.HaskellNet.SMTP as SMTP
import Data.Pool (withResource)
import UnliftIO.Pool (withResource)
import Jobs.Queue
import Control.Concurrent.Async.Lifted.Safe (forConcurrently)
import UnliftIO.Concurrent (myThreadId)
generateHealthReport :: HealthCheck -> Handler HealthReport
@ -151,7 +151,7 @@ dispatchHealthCheckActiveJobExecutors = HealthActiveJobExecutors <$> do
| configuredNumber == 0 -> return Nothing
Nothing -> return $ Just 0
Just JobState{jobWorkers, jobWorkerName} -> do
tid <- liftIO myThreadId
tid <- myThreadId
let workers' = Map.fromSet jobWorkerName (Map.keysSet jobWorkers)
workers = Map.filterWithKey (\a _ -> asyncThreadId a /= tid) workers'
$logDebugS "HealthCheckActiveJobExecutors" . tshow . map showWorkerId $ Map.elems workers'

16
src/Jobs/Queue.hs
View File

@ -28,6 +28,8 @@ import qualified Data.Conduit.List as C
import Data.Semigroup ((<>))
import UnliftIO.Concurrent (myThreadId)
data JobQueueException = JobQueuePoolEmpty
| JobQueueWorkerNotFound
@ -55,7 +57,7 @@ writeJobCtl :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m (
-- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others
writeJobCtl cmd = do
names <- fmap jobWorkerNames $ asks appJobState >>= atomically . readTMVar
tid <- liftIO myThreadId
tid <- myThreadId
let target = evalRand ?? mkStdGen (hash tid `hashWithSalt` cmd) $ uniform names
writeJobCtl' target cmd
@ -97,32 +99,32 @@ queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
-- ^ Queue a job for later execution
--
-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe False
queueJob = liftHandler . runDB . setSerializable . queueJobUnsafe False
queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
queueJob' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
queueJob' job = do
app <- getYesod
queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform
-- | Slightly modified Version of `YesodDB` for `runDBJobs`
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerFor site))
queueDBJob, queueDBJobCron :: Job -> YesodJobDB UniWorX ()
-- | Queue a job as part of a database transaction and execute it after the transaction succeeds
queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . Set.singleton
queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . Set.singleton
sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) ()
-- | Queue many jobs as part of a database transaction and execute them after the transaction passes
sinkDBJobs = C.mapM_ queueDBJob
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
runDBJobs :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
--
-- Jobs get immediately executed if the transaction succeeds
runDBJobs act = do
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
(ret, jIds) <- liftHandler . runDB $ mapReaderT runWriterT act
app <- getYesod
forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform
return ret

2
src/Jobs/Types.hs
View File

@ -152,7 +152,7 @@ prioritiseJob _ = JobPrioBatch
newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue JobPriority JobCtl }
deriving (Eq, Ord, Read, Show)
deriving newtype (Monoid, NFData)
deriving newtype (Semigroup, Monoid, NFData)
makePrisms ''JobQueue

Some files were not shown because too many files have changed in this diff Show More