Merge branch 'master' into 205-klausuren

README.md

@@ -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.

nixpkgs.nix

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

package-lock.json

@@ -7702,9 +7702,9 @@
       "dev": true
     },
     "handlebars": {
-      "version": "4.1.2",
+      "version": "4.3.1",
-      "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz",
+      "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz",
-      "integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==",
+      "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",
+      "version": "3.6.0",
-      "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz",
+      "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz",
-      "integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==",
+      "integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==",
       "dev": true,
       "optional": true,
       "requires": {

package.json

@@ -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",

package.yaml

@@ -2,40 +2,38 @@ name:    uniworx
 version: 6.11.1
 
 dependencies:
-  # Due to a bug in GHC 8.0.1, we block its usage
+  - base >=4.9.1.0 && <5
-  # See: https://ghc.haskell.org/trac/ghc/ticket/12130
+  - yesod >=1.6 && <1.7
-  - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+  - yesod-core >=1.6 && <1.7
-  # version 1.0 had a bug in reexporting Handler, causing trouble
+  - yesod-auth >=1.6 && <1.7
-  - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
+  - yesod-static >=1.6 && <1.7
-  - foreign-store
+  - yesod-form >=1.6 && <1.7
-  - yesod >=1.4.3 && <1.5
+  - classy-prelude >=1.5 && <1.6
-  - yesod-core >=1.4.30 && <1.5
+  - classy-prelude-conduit >=1.5 && <1.6
-  - yesod-auth >=1.4.0 && <1.5
+  - classy-prelude-yesod >=1.5 && <1.6
-  - yesod-static >=1.4.0.3 && <1.6
+  - bytestring >=0.10 && <0.11
-  - yesod-form >=1.4.0 && <1.5
-  - classy-prelude >=0.10.2
-  - classy-prelude-conduit >=0.10.2
-  - bytestring >=0.9 && <0.11
   - text >=0.11 && <2.0
-  - persistent >=2.7.2 && <2.8
+  - persistent >=2.9 && <2.10
-  - persistent-postgresql >=2.1.1 && <2.8
+  - persistent-postgresql >=2.9 && <2.10
-  - persistent-template >=2.0 && <2.8
+  - 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
+  - yaml >=0.11 && <0.12
-  - http-conduit >=2.1 && <2.3
+  - 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
+  - network >=3
-  - resource-pool
+  - 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

shell.nix

@@ -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}
     '';
   };

src/Application.hs

@@ -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

src/Audit.hs

@@ -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{..}

src/Auth/Dummy.hs

@@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
-dummyForm :: ( RenderMessage site FormMessage
+dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
-             , RenderMessage site DummyMessage
+             , RenderMessage (HandlerSite m) DummyMessage
-             , YesodPersist site
+             , YesodPersist (HandlerSite m)
-             , SqlBackendCanRead (YesodPersistBackend site)
+             , SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
-             , Button site ButtonSubmit
+             , Button (HandlerSite m) ButtonSubmit
-             ) => AForm (HandlerT site IO) (CI Text)
+             , 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
+    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
-      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
+    apDispatch "POST" [] = liftSubHandler $ do
+      ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm
+      tp <- getRouteToParent
       case loginRes of
         FormFailure errs -> do
-          lift . forM_ errs $ addMessage Error . toHtml
+          forM_ errs $ addMessage Error . toHtml
-          redirect LoginR
+          redirect $ tp LoginR
         FormMissing -> do
-          lift $ addMessageI Warning MsgDummyNoFormData
+          addMessageI Warning MsgDummyNoFormData
-          redirect LoginR
+          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

src/Auth/LDAP.hs

@@ -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
+campusForm :: ( RenderMessage (HandlerSite m) FormMessage
-              , RenderMessage site CampusMessage
+              , RenderMessage (HandlerSite m) CampusMessage
-              , Button site ButtonSubmit
+              , MonadHandler m
-              ) => WForm (HandlerT site IO) (FormResult CampusLogin)
+              ) => 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
+    apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
-      ((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm
+    apDispatch "POST" [] = liftSubHandler $ do
+      ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
+      tp <- getRouteToParent
       case loginRes of
         FormFailure errs -> do
           forM_ errs $ addMessage Error . toHtml
-          redirect LoginR
+          redirect $ tp LoginR
-        FormMissing -> redirect 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

src/Auth/PWHash.hs

@@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
-hashForm :: ( RenderMessage site FormMessage
+hashForm :: ( RenderMessage (HandlerSite m) FormMessage
-            , RenderMessage site PWHashMessage
+            , RenderMessage (HandlerSite m) PWHashMessage
-            , Button site ButtonSubmit
+            , MonadHandler m
-            ) => AForm (HandlerT site IO) HashLogin
+            ) => 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
+          redirect $ tp LoginR
-        FormMissing -> redirect 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

src/Control/Concurrent/Async/Lifted/Safe/Utils.hs

@@ -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

src/CryptoID.hs

@@ -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
 

src/Data/CaseInsensitive/Instances.hs

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

src/Data/CryptoID/Instances.hs

@@ -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

src/Data/List/NonEmpty/Instances.hs

@@ -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|]

src/Database/Esqueleto/Utils.hs

@@ -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
+isInfixOf :: ( E.SqlString s1
-             , 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
+hasInfix :: ( E.SqlString s1
-            , 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)

src/Foundation.hs

@@ -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
+    let
-          [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
+      authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
-          whenExceptT ok Authorized
+      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
+                 . runConduitPure
-                 $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
+                 $ 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
+      . runConduitPure
-      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
+      $ 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
 

src/Handler/Admin.hs

@@ -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)

src/Handler/Allocation/Application.hs

@@ -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

src/Handler/Allocation/List.hs

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

src/Handler/Allocation/Show.hs

@@ -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

src/Handler/Corrections.hs

@@ -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))
+lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
-  => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime))
+  => 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

src/Handler/Course/Application/Files.hs

@@ -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

src/Handler/Course/Application/List.hs

@@ -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

src/Handler/Course/Edit.hs

@@ -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
+    uid <- liftHandler requireAuthId
-    (lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do
+    (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

src/Handler/Course/LecturerInvite.hs

@@ -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
+      cRoute <- getCurrentRoute
-      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+      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

src/Handler/Course/List.hs

@@ -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)

src/Handler/Course/ParticipantInvite.hs

@@ -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
+      cRoute <- getCurrentRoute
-      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+      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

src/Handler/Course/Register.hs

@@ -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 ()

src/Handler/Course/Show.hs

@@ -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
+                freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
-                                                           E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
+                  . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
-                                                           return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
+                                     E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
-                                                      in return $ E.val tutorialCapacity' E.-. numParticipants
+                                     return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
-                return . toWidget . tshow $ max 0 freeCapacity
+                                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

src/Handler/Course/User.hs

@@ -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
 

src/Handler/Course/Users.hs

@@ -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
           }

src/Handler/Exam/AddUser.hs

@@ -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

src/Handler/Exam/CorrectorInvite.hs

@@ -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
+      cRoute <- getCurrentRoute
-      fetchExamId tid csh ssh examn
+      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, ())

src/Handler/Exam/Form.hs

@@ -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
+  currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
-  uid <- liftHandlerT requireAuthId
+  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

src/Handler/Exam/RegistrationInvite.hs

@@ -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
+      cRoute <- getCurrentRoute
-      fetchExamId tid csh ssh examn
+      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
+    invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
-      isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
+      isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
       now <- liftIO getCurrentTime
 
       case (isRegistered, invDBExamRegistrationCourseRegister) of

src/Handler/Exam/Show.hs

@@ -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

src/Handler/Exam/Users.hs

@@ -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}

src/Handler/ExamOffice/Course.hs

@@ -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)

src/Handler/ExamOffice/Exam.hs

@@ -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
             }

src/Handler/ExamOffice/Exams.hs

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

src/Handler/ExamOffice/Fields.hs

@@ -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 ]

src/Handler/ExamOffice/Users.hs

@@ -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'

src/Handler/Health.hs

@@ -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

src/Handler/Home.hs

@@ -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

src/Handler/Material.hs

@@ -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
+fetchMaterial tid ssh csh mnm =
-  [matEnt] <- E.select . E.from  $ -- uniqueness guaranteed by DB constraints
+  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

src/Handler/Profile.hs

@@ -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

src/Handler/School.hs

@@ -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 [] []
 

src/Handler/Sheet.hs

@@ -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))
+      , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
-      , sfHintF        :: Maybe (Source Handler (Either FileId File))
-      , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
-      , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
       , 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
+  currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
-  userId <- liftHandlerT requireAuthId
+  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
+      cRoute <- getCurrentRoute
-      fetchSheetId tid csh ssh shn
+      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, ())

src/Handler/Submission.hs

@@ -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
+      cRoute <- getCurrentRoute
-      subId <- decrypt cID
+      case cRoute of
-      bool notFound (return subId) =<< existsKey subId
+        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)

src/Handler/SystemMessage.hs

@@ -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)
+  let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
-                           & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
+                           <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
 
   case tableRes of
     FormMissing -> return ()

src/Handler/Term.hs

@@ -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

src/Handler/Tutorial.hs

@@ -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
+      cRoute <- getCurrentRoute
-      fetchTutorialId tid csh ssh tutn
+      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
+  cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
-  uid <- liftHandlerT requireAuthId
+  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

src/Handler/Users.hs

@@ -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

src/Handler/Utils.hs

@@ -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}

src/Handler/Utils/Communication.hs

@@ -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
 

src/Handler/Utils/ContentDisposition.hs

@@ -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

src/Handler/Utils/Csv.hs

@@ -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
+           -> ConduitT () csv (HandlerFor site) ()
-           -> HandlerT site IO TypedContent
+           -> 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
+                         => ConduitT () csv (HandlerFor site) ()
-                         -> HandlerT site IO TypedContent
+                         -> HandlerFor site TypedContent
 respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv)
 
 respondCsvDB :: ( ToNamedRecord csv
                 , YesodPersistRunner site
                 )
              => Header
-             -> Source (YesodDB site) csv
+             -> ConduitT () csv (YesodDB site) ()
-             -> HandlerT site IO TypedContent
+             -> 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
+                           => ConduitT () csv (YesodDB site) ()
-                           -> HandlerT site IO TypedContent
+                           -> 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

src/Handler/Utils/Database.hs

@@ -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
+studyFeaturesQuery
-  => expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
+  :: E.SqlExpr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@
-  -> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms)
+  -> E.SqlExpr (Entity StudyFeatures) `E.InnerJoin` E.SqlExpr (Entity StudyDegree) `E.InnerJoin` E.SqlExpr (Entity StudyTerms)
-  -> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (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

src/Handler/Utils/DateTime.hs

@@ -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

src/Handler/Utils/Delete.hs

@@ -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
+  , drRenderRecord :: info -> DB 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
+  , 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

src/Handler/Utils/Form.hs

@@ -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)
+multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
-             => Map action (AForm (HandlerT UniWorX IO) a)
+             => 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)
+multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
-             => Map action (AForm (HandlerT UniWorX IO) a)
+             => 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`
+multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField`
-                -> Field Handler (Source Handler (Either FileId File))
+                -> 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

src/Handler/Utils/Form/MassInput.hs

@@ -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

src/Handler/Utils/Form/Occurrences.hs

@@ -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)

src/Handler/Utils/Invitations.hs

@@ -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)
+    determineExists :: ConduitT (Invitation' junction)
-                               (ReaderT backend (WriterT (Set QueuedJobId) m))
+                                (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' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
-    sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do
+    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
+        jInviter <- liftHandler requireAuthId
-        route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
+        route <- mapReaderT liftHandler $ invitationRoute fEnt dat
-        InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig 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
+        jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
-        jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation 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

src/Handler/Utils/Mail.hs

@@ -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
+             , MonadThrow m
-             , MonadLogger 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
+             ) => FileId -> m (Maybe MailObjectId)
-addFileDB fId = do
+addFileDB fId = runMaybeT $ do
-  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
+  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId
-  addPart $ do
+  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

src/Handler/Utils/Rating.hs

@@ -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

src/Handler/Utils/Sheet.hs

@@ -16,13 +16,11 @@ sheetFileTypeDates Sheet{..} = \case
   SheetMarking  -> Nothing
 
 
-fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
+fetchSheetAux ::  ( E.SqlSelect b a
-                  , E.SqlSelect b a
+                  , Typeable a, MonadHandler m
-                  , Typeable a, MonadHandler m, IsPersistBackend backend
-                  , PersistQueryRead backend, PersistUniqueRead backend
                   )
   =>  (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

src/Handler/Utils/Submission.hs

@@ -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
+                     ) => ConduitT File SubmissionContent m ()
-                     ) => Conduit File m SubmissionContent
 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 . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
-            lift . feed sId $ Left f{ fileTitle = fileTitle' }
+            feed sId $ Left f{ fileTitle = fileTitle' }
   when (not $ null ignoredFiles) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)

src/Handler/Utils/Table.hs

@@ -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)
-         )
-
-

src/Handler/Utils/Table/Cells.hs

@@ -1,8 +1,6 @@
 module Handler.Utils.Table.Cells where
 
-import Import
+import Import hiding (link)
-
-import qualified Control.Monad.Trans.RWS.Lazy
 
 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 :: IsDBTable m a => DBCell m a -> DBCell m a
-addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
+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

src/Handler/Utils/Table/Columns.hs

@@ -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'

src/Handler/Utils/Table/Pagination.hs

@@ -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
+addCellClass :: (IsDBTable m x, PathPiece t) => t -> DBCell m x -> DBCell m x
-  data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
+addCellClass = over cellAttrs . Yesod.addClass . toPathPiece
-  type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-  -- type DBResult' (WidgetT UniWorX IO) () = ()
 
-  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
+instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerFor UniWorX)) x where
-  data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
+  data DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBParamsDB
-  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
+  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 :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerFor UniWorX) ((), Widget) -> m (Widget)
-  runDBTable _ _ _ = mapReaderT liftHandlerT
+  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
+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 (HandlerT UniWorX IO)) x = forall a. DBParamsForm
+  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 (HandlerFor UniWorX)) 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)) (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)
+  --             (DBCell (RWST ... ... ... (HandlerFor UniWorX)) x)
-  --             ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
+  --             ([(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
+  currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
-  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  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
+dbTableWidget :: Monoid x
-    -> DB (DBResult (HandlerT UniWorX IO) 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)
+widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-                => Colonnade h r (DBCell (HandlerT UniWorX IO) x)
+                -> Colonnade h r (DBCell (HandlerFor UniWorX) x)
-                -> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
 widgetColonnade = id
 
-formColonnade :: (Headedness h, Monoid' 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 (HandlerT UniWorX IO)) (FormResult a))
+              -> 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 (HandlerT UniWorX IO)) (FormResult a))
 formColonnade = id
 
-dbColonnade :: (Headedness h, Monoid' x)
+dbColonnade :: Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
-            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
+            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
-            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) 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 -> MForm (HandlerFor UniWorX) 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 -> (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 (HandlerT UniWorX IO)) x)
+         -> (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)
+         -> (DBRow r -> MForm (HandlerFor UniWorX) i)
-         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
+         -> 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

src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs

@@ -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 ())
+instance GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
-      => GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
    where
      gCsvColumnsExplanations _ _ =
         error "You cannot derive CsvColumnsExplanations for constructors without selectors."

src/Handler/Utils/Table/Pagination/Types.hs

@@ -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)

src/Handler/Utils/Tokens.hs

@@ -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
+requireCurrentTokenRestrictions :: ( MonadHandler m
-                                                                  , HandlerSite m ~ UniWorX
+                                   , HandlerSite m ~ UniWorX
-                                                                  , MonadCatch m
+                                   , FromJSON a
-                                                                  , MonadLogger m
+                                   , ToJSON a
-                                                                  , FromJSON a
+                                   )
-                                                                  , ToJSON a
+                                => m (Maybe 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

src/Handler/Utils/Zip.hs

@@ -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
+consumeZip :: forall b m.
-              , PrimMonad b
+              ( MonadThrow b
               , MonadThrow m
-              ) => ConduitM ByteString File m ZipInfo
+              , MonadBase b m
-consumeZip = unZipStream `fuseUpstream` consumeZip'
+              , PrimMonad b
+              )
+           => ConduitT ByteString File m ZipInfo
+consumeZip = transPipe liftBase unZipStream `fuseUpstream` consumeZip'
   where
-    consumeZip' :: ( MonadThrow m
+    consumeZip' :: ConduitT (Either ZipEntry ByteString) File m ()
-                   ) => Conduit (Either ZipEntry ByteString) m File
     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
+produceZip :: forall b m.
-              , PrimMonad b
+            ( MonadThrow b
-              , MonadThrow m
+            , MonadThrow m
-              ) => ZipInfo
+            , MonadBase b m
-              -> Conduit File m ByteString
+            , PrimMonad b
-produceZip info = mapC toZipData =$= void (zipStream zipOptions)
+            )
+           => 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 :: File -> (ZipEntry, ZipData b)
-    toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
+    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
+    toZipEntry File{..} = ZipEntry{..}
-      { zipEntryName = bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
-      , zipEntryTime = utcToLocalTime utc fileModified
-      }
       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

src/Import/NoModel.hs

@@ -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 ()

src/Jobs.hs

@@ -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
+      UnliftIO{..} <- askUnliftIO
-      let runInIO = flip runLoggingT logger . runResourceT
 
-      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.
+manageCrontab :: forall m.
-                                ( MonadResource m
+                 MonadResource m
-                                , MonadLogger m
+              => UniWorX -> 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)

src/Jobs/Handler/HelpRequest.hs

@@ -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

src/Jobs/Handler/SendNotification/Allocation.hs

@@ -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

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -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

src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs

@@ -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

src/Jobs/Handler/SendNotification/ExamActive.hs

@@ -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)

src/Jobs/Handler/SendNotification/ExamOffice.hs

@@ -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)

src/Jobs/Handler/SendNotification/ExamResult.hs

@@ -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)

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -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)

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -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

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -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

src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs

@@ -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
 

src/Jobs/Handler/SendNotification/UserRightsUpdate.hs

@@ -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)

src/Jobs/Handler/SendNotification/Utils.hs

@@ -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

src/Jobs/Handler/SendPasswordReset.hs

@@ -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

src/Jobs/Handler/SendTestEmail.hs

@@ -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)

src/Jobs/Handler/SetLogSettings.hs

@@ -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

src/Jobs/Handler/SynchroniseLdap.hs

@@ -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

src/Jobs/HealthReport.hs

@@ -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'

src/Jobs/Queue.hs

@@ -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

src/Jobs/Types.hs

@@ -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