diff --git a/README.md b/README.md index f61775faa..685041baa 100644 --- a/README.md +++ b/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. diff --git a/nixpkgs.nix b/nixpkgs.nix index f21a81350..783ede000 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,6 +4,6 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "19.03"; - sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; + rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf"; + sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm"; }) diff --git a/package-lock.json b/package-lock.json index 785fdc8b6..67c13819f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -7702,9 +7702,9 @@ "dev": true }, "handlebars": { - "version": "4.1.2", - "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz", - "integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==", + "version": "4.3.1", + "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz", + "integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==", "dev": true, "requires": { "neo-async": "^2.6.0", @@ -15623,9 +15623,9 @@ "dev": true }, "uglify-js": { - "version": "3.5.15", - "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz", - "integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==", + "version": "3.6.0", + "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz", + "integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==", "dev": true, "optional": true, "requires": { diff --git a/package.json b/package.json index a598d4013..14784856d 100644 --- a/package.json +++ b/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", diff --git a/package.yaml b/package.yaml index 067fce361..f7445cd95 100644 --- a/package.yaml +++ b/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 - # See: https://ghc.haskell.org/trac/ghc/ticket/12130 - - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - # version 1.0 had a bug in reexporting Handler, causing trouble - - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 - - foreign-store - - yesod >=1.4.3 && <1.5 - - yesod-core >=1.4.30 && <1.5 - - yesod-auth >=1.4.0 && <1.5 - - yesod-static >=1.4.0.3 && <1.6 - - yesod-form >=1.4.0 && <1.5 - - classy-prelude >=0.10.2 - - classy-prelude-conduit >=0.10.2 - - bytestring >=0.9 && <0.11 + - base >=4.9.1.0 && <5 + - yesod >=1.6 && <1.7 + - yesod-core >=1.6 && <1.7 + - yesod-auth >=1.6 && <1.7 + - yesod-static >=1.6 && <1.7 + - yesod-form >=1.6 && <1.7 + - classy-prelude >=1.5 && <1.6 + - classy-prelude-conduit >=1.5 && <1.6 + - classy-prelude-yesod >=1.5 && <1.6 + - bytestring >=0.10 && <0.11 - text >=0.11 && <2.0 - - persistent >=2.7.2 && <2.8 - - persistent-postgresql >=2.1.1 && <2.8 - - persistent-template >=2.0 && <2.8 + - persistent >=2.9 && <2.10 + - persistent-postgresql >=2.9 && <2.10 + - persistent-template >=2.5 && <2.9 + - persistent-qq >=2.9 && <2.10 - template-haskell - shakespeare >=2.0 && <2.1 - hjsmin >=0.1 && <0.3 - monad-control >=0.3 && <1.1 - wai-extra >=3.0 && <3.1 - - yaml >=0.8 && <0.9 - - http-conduit >=2.1 && <2.3 + - yaml >=0.11 && <0.12 + - http-conduit >=2.3 && <2.4 - directory >=1.1 && <1.4 - warp >=3.0 && <3.3 - data-default - - aeson >=0.6 && <1.3 + - aeson >=1.4 && <1.5 - conduit >=1.0 && <2.0 - conduit-combinators - monad-logger >=0.3 && <0.4 - fast-logger >=2.2 && <2.5 - wai-logger >=2.2 && <2.4 + - foreign-store - file-embed - safe - unordered-containers @@ -52,11 +50,12 @@ dependencies: - http-api-data - profunctors - colonnade >=1.1.1 - - yesod-colonnade >=1.1.0 - blaze-markup - zip-stream + - encoding - filepath - transformers + - transformers-base - wl-pprint-text - uuid-types - path-pieces @@ -100,8 +99,10 @@ dependencies: - th-abstraction - HaskellNet - HaskellNet-SSL - - network - - resource-pool + - network >=3 + - network-bsd + - unliftio + - unliftio-pool - mime-mail - hashable - aeson-pretty @@ -116,7 +117,6 @@ dependencies: - pkcs7 - memcached-binary - directory-tree - - lifted-base - lattices - hsass - semigroupoids @@ -126,7 +126,6 @@ dependencies: - mono-traversable - lens-aeson - systemd - - lifted-async - streaming-commons - hourglass - unix @@ -138,6 +137,7 @@ dependencies: - pqueue - deepseq - multiset + - retry other-extensions: - GeneralizedNewtypeDeriving @@ -183,6 +183,7 @@ default-extensions: - DeriveLift - DeriveFunctor - DerivingStrategies + - DerivingVia - DataKinds - BinaryLiterals - PolyKinds @@ -190,9 +191,12 @@ default-extensions: - TypeApplications - RecursiveDo - TypeFamilyDependencies + - QuantifiedConstraints ghc-options: - -Wall + - -Wmissing-home-modules + - -Wredundant-constraints - -fno-warn-type-defaults - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures diff --git a/shell.nix b/shell.nix index d65bb65a3..1a285b264 100644 --- a/shell.nix +++ b/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} ''; }; diff --git a/src/Application.hs b/src/Application.hs index 7d5fa3c39..ab50d34e6 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Audit.hs b/src/Audit.hs index 06d3d8767..0b7890b8c 100644 --- a/src/Audit.hs +++ b/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{..} diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 53a10acde..4bfc09d01 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -dummyForm :: ( RenderMessage site FormMessage - , RenderMessage site DummyMessage - , YesodPersist site - , SqlBackendCanRead (YesodPersistBackend site) - , Button site ButtonSubmit - ) => AForm (HandlerT site IO) (CI Text) +dummyForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) DummyMessage + , YesodPersist (HandlerSite m) + , SqlBackendCanRead (YesodPersistBackend (HandlerSite m)) + , Button (HandlerSite m) ButtonSubmit + , MonadHandler m + ) => AForm m (CI Text) dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing where - userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent] + userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent]) toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent) -dummyLogin :: ( YesodAuth site +dummyLogin :: forall site. + ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , RenderMessage site FormMessage , RenderMessage site AFormMessage , RenderMessage site DummyMessage , Button site ButtonSubmit ) => AuthPlugin site dummyLogin = AuthPlugin{..} where + apName :: Text apName = "dummy" - -- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do - lift . forM_ errs $ addMessage Error . toHtml - redirect LoginR + forM_ errs $ addMessage Error . toHtml + redirect $ tp LoginR FormMissing -> do - lift $ addMessageI Warning MsgDummyNoFormData - redirect LoginR + addMessageI Warning MsgDummyNoFormData + redirect $ tp LoginR FormSuccess ident -> - lift . setCredsRedirect $ Creds "dummy" (CI.original ident) [] + setCredsRedirect $ Creds "dummy" (CI.original ident) [] apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm let loginForm = wrapForm login FormSettings diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 320ab6e27..1ba6af9e7 100644 --- a/src/Auth/LDAP.hs +++ b/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 - , RenderMessage site CampusMessage - , Button site ButtonSubmit - ) => WForm (HandlerT site IO) (FormResult CampusLogin) +campusForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) CampusMessage + , MonadHandler m + ) => WForm m (FormResult CampusLogin) campusForm = do MsgRenderer mr <- getMsgRenderer @@ -133,24 +133,26 @@ apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth site - , RenderMessage site FormMessage , RenderMessage site CampusMessage , RenderMessage site AFormMessage , Button site ButtonSubmit ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where + apName :: Text apName = apLdap - apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect LoginR - FormMissing -> redirect LoginR + redirect $ tp LoginR + FormMissing -> redirect $ tp LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do - ldapResult <- withLdap pool $ \ldap -> do + ldapResult <- withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of @@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} $logErrorS "LDAP" $ "Error during login: " <> tshow err loginErrorMessageI LoginR Msg.AuthError Right (Right (userDN, credsIdent)) -> - lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] Right (Left searchResults) -> do $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults loginErrorMessageI LoginR Msg.AuthError apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm let loginForm = wrapForm login FormSettings diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index d6f5bf4e8..b2194bf90 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -hashForm :: ( RenderMessage site FormMessage - , RenderMessage site PWHashMessage - , Button site ButtonSubmit - ) => AForm (HandlerT site IO) HashLogin +hashForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) PWHashMessage + , MonadHandler m + ) => AForm m HashLogin hashForm = HashLogin <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing -hashLogin :: ( YesodAuth site +hashLogin :: forall site. + ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , RenderMessage site FormMessage + , PersistRecordBackend User (YesodPersistBackend site) , RenderMessage site PWHashMessage , RenderMessage site AFormMessage , Button site ButtonSubmit ) => PWHashAlgorithm -> AuthPlugin site hashLogin pwHashAlgo = AuthPlugin{..} where + apName :: Text apName = "PWHash" - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect LoginR - FormMissing -> redirect LoginR + redirect $ tp LoginR + FormMissing -> redirect $ tp LoginR FormSuccess HashLogin{..} -> do - user <- lift . runDB . getBy $ UniqueAuthentication hashIdent + user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent case user of Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent }) | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic. - lift . setCredsRedirect $ Creds apName userIdent [] + setCredsRedirect $ Creds apName userIdent [] other -> do $logDebugS "PWHash" $ tshow other loginErrorMessageI LoginR Msg.InvalidLogin - -- apDispatch "GET" [] = do - -- authData <- lookupBasicAuth - -- pwdata <- liftIO $ Yaml.decodeFileEither fp - - -- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] - - -- case pwdata of - -- Left err -> $logDebugS "Auth" $ tshow err - -- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" - - -- case (authData, pwdata) of - -- (Nothing, _) -> do - -- notAuthenticated - -- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') - -- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] - -- <- [ pwe | pwe@PWEntry{..} <- pwdata' - -- , let User{..} = pwUser - -- , userIdent == usr - -- , userPlugin == apName - -- ] - -- , verifyPassword pw pwHash - -- -> lift $ do - -- runDB . void $ insertUnique pwUser - -- setCredsRedirect $ Creds apName userIdent [] - -- _ -> permissionDenied "Invalid auth" apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm let loginForm = wrapForm login FormSettings diff --git a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs deleted file mode 100644 index 27dc86127..000000000 --- a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs +++ /dev/null @@ -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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9263ca308..0f1296887 100644 --- a/src/CryptoID.hs +++ b/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 diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 937fb2c46..f218308f5 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/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 ( diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index 0867f60b5..b48c0df70 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/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 diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs deleted file mode 100644 index f151b6c18..000000000 --- a/src/Data/List/NonEmpty/Instances.hs +++ /dev/null @@ -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|] diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a71b0b811..2cdfc69d2 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 - , E.SqlString s1 +isInfixOf :: ( E.SqlString s1 , E.SqlString s2 ) - => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool) + => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool) isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%) -hasInfix :: ( E.Esqueleto query expr backend - , E.SqlString s1 +hasInfix :: ( E.SqlString s1 , E.SqlString s2 ) - => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) + => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) hasInfix = flip isInfixOf and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) diff --git a/src/Foundation.hs b/src/Foundation.hs index 58438298a..a9d2d1df0 100644 --- a/src/Foundation.hs +++ b/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 - [E.Value ok] <- lift . E.select . return . E.exists $ E.from f - whenExceptT ok Authorized + let + authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () + authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID -- participant is currently registered $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do @@ -1395,42 +1392,42 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf return result -evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor mAuthId route isWrite = do dnf <- either throwM return $ routeAuthTags route fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite -evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessForDB = evalAccessFor -evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess route isWrite = do - mAuthId <- liftHandlerT maybeAuthId + mAuthId <- liftHandler maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite result <$ tellSessionJson SessionInactiveAuthTags deactivated -evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessDB = evalAccess -- | Check whether the current user is authorized by `evalAccess` for the given route -- Convenience function for a commonly used code fragment -hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite -- | Check whether the current user is authorized by `evalAccess` to read from the given route -- Convenience function for a commonly used code fragment -hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasReadAccessTo = flip hasAccessTo False -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route -- Convenience function for a commonly used code fragment -hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo = flip hasAccessTo True -- | Conditional redirect that hides the URL if the user is not authorized for the route -redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a +redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do -- must hide URL if not authorized access <- evalAccess url False @@ -1439,7 +1436,7 @@ redirectAccess url = do _ -> permissionDeniedI MsgUnauthorizedRedirect -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) +evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => TermId -> SchoolId -> CourseShorthand -> m AuthResult evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False @@ -1481,7 +1478,7 @@ instance Yesod UniWorX where $logDebugS "updateFavourites" "Updating favourites" now <- liftIO $ getCurrentTime - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid @@ -1533,7 +1530,7 @@ instance Yesod UniWorX where encrypted :: ToJSON a => a -> Widget -> Widget encrypted plaintextJson plaintext = do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- view _appEncryptErrors + shouldEncrypt <- getsYesod $ view _appEncryptErrors if | shouldEncrypt , not canDecrypt -> do @@ -1596,14 +1593,13 @@ instance Yesod UniWorX where . decodeUtf8 . Base64.encode . (convert :: Digest (SHAKE256 144) -> ByteString) - . runIdentity - $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash + . runConduitPure + $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash fileUpload _site _length = FileUploadMemory lbsBackEnd -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog _ _ _ = error "Must use shouldLogIO" shouldLogIO app _source level = do LogSettings{..} <- readTVarIO $ appLogSettings app return $ logAll || level >= logMinimumLevel @@ -1626,7 +1622,7 @@ siteLayout = siteLayout' . Just siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` -> Widget -> Handler Html siteLayout' headingOverride widget = do - AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings + AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings isModal <- hasCustomHeader HeaderIsModal @@ -1747,7 +1743,7 @@ siteLayout' headingOverride widget = do applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () -applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage +applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do cID <- encrypt smId @@ -2548,7 +2544,7 @@ pageActions (CourseR tid ssh csh SheetListR) = case muid of Nothing -> return False (Just uid) -> do - [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -2744,7 +2740,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard $ null submissions return True @@ -2756,7 +2752,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard . not $ null submissions return True @@ -2966,7 +2962,7 @@ pageActions (CorrectionsR) = , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let @@ -3005,7 +3001,7 @@ pageActions (CorrectionsGradeR) = , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let @@ -3024,7 +3020,7 @@ pageActions _ = [] i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () -i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg +i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg -- | only used in defaultLayout; better use siteLayout instead! pageHeading :: Route UniWorX -> Maybe Widget @@ -3131,7 +3127,7 @@ pageHeading _ = Nothing -routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] +routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)] routeNormalizers = [ normalizeRender , ncSchool @@ -3142,7 +3138,7 @@ routeNormalizers = ] where normalizeRender route = route <$ do - YesodRequest{..} <- liftHandlerT getRequest + YesodRequest{..} <- liftHandler getRequest let original = (W.pathInfo reqWaiRequest, reqGetParams) rendered = renderRoute route if @@ -3338,10 +3334,10 @@ upsertCampusUser ldapData Creds{..} = do . UUID.fromByteString . fromStrict . (convert :: Digest (SHAKE128 128) -> ByteString) - . runIdentity - $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash + . runConduitPure + $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash - [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate -> + candidatesRecorded <- E.selectExists . E.from $ \candidate -> E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence unless candidatesRecorded $ do @@ -3419,14 +3415,14 @@ instance YesodAuth UniWorX where loginHandler = do toParent <- getRouteToParent - lift . defaultLayout $ do + liftHandler . defaultLayout $ do plugins <- getsYesod authPlugins $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) setTitleI MsgLoginTitle $(widgetFile "login") - authenticate Creds{..} = runDB $ do + authenticate Creds{..} = liftHandler . runDB $ do now <- liftIO getCurrentTime let @@ -3495,7 +3491,7 @@ instance YesodAuth UniWorX where , dummyLogin <$ guard appAuthDummyLogin ] - authHttpManager = Yesod.getHttpManager + authHttpManager = getsYesod appHttpManager onLogin = addMessageI Success Auth.NowLoggedIn diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1427533d3..a992d9eb9 100644 --- a/src/Handler/Admin.hs +++ b/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) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index bc19f3dc2..d9e48239a 100644 --- a/src/Handler/Allocation/Application.hs +++ b/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 diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 016db93a0..d64bd13e7 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.Allocation.List ( getAllocationListR ) where diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 0029581b7..3d366d129 100644 --- a/src/Handler/Allocation/Show.hs +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2074fd3b4..4d2c37aba 100644 --- a/src/Handler/Corrections.hs +++ b/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)) - => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime)) +lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit)) + => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime)) lastEditQuery submission = E.sub_select $ E.from $ \edit -> do E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return $ E.max_ $ edit E.^. SubmissionEditTime @@ -216,7 +216,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id +colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) @@ -238,7 +238,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d ) in (submission, sheet, crse, corrector, lastEditQuery submission) ) - dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData + dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) @@ -398,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent +correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do - Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler + currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) { drAbort = SomeRoute currentRoute @@ -416,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAdditional = \frag -> do (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _1 , dbParamsFormIdent = def } @@ -466,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do ] addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num auditAllSubEdit sIds - (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do + selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) @@ -537,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do where authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign sId = do - [(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <- + (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=< E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -547,7 +547,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do let route = CSubmissionR tid ssh csh shn cID SubAssignR (== Authorized) <$> evalAccessDB route True -type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) +type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData) downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload @@ -560,7 +560,7 @@ deleteAction = ( CorrDelete assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector , wFormToAForm $ do - correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do + correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -573,7 +573,7 @@ assignAction selId = ( CorrSetCorrector correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey - cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing + cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) @@ -740,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do } formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId now <- liftIO getCurrentTime if @@ -1013,7 +1013,7 @@ postCorrectionsGradeR = do , colCommentField ] -- Continue here psValidator = def - & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) + & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do cID <- encrypt subId diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 31ec53e47..b6d3b77a5 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/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 diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index d01699a2a..312ff9d02 100644 --- a/src/Handler/Course/Application/List.hs +++ b/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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 6347b1d38..fcb45369e 100644 --- a/src/Handler/Course/Edit.hs +++ b/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 - (lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do + uid <- liftHandler requireAuthId + (lecturerSchools, adminSchools) <- liftHandler . runDB $ do lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools @@ -116,7 +116,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB termsField <- case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin - (Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course + (Just cform) | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course _courseOld@Course{..} <- runDB $ get404 cid mayEditTerm <- isAuthorized TermEditR True mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True @@ -128,7 +128,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge btn = Just $ \csrf -> do (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing - addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk + addRes' <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk let addRes'' = case (,) <$> addRes <*> addRes' of FormSuccess (CI.mk -> email, mLid) -> let new = maybe (Left email) Right mLid @@ -143,7 +143,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType) - User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid + User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do @@ -153,7 +153,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool @@ -194,7 +194,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB (newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) _allIOtherCases -> do - mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] + mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) @@ -202,7 +202,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB let allocationForm :: AForm Handler (Maybe AllocationCourseForm) allocationForm = wFormToAForm $ do - availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do + availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid -> @@ -226,7 +226,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1 mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId) - mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do + mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do cID <- encrypt aId :: Handler CryptoUUIDAllocation return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID @@ -295,7 +295,7 @@ validateCourse = do CourseForm{..} <- State.get now <- liftIO getCurrentTime - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust @@ -517,7 +517,7 @@ courseEditHandler miButtonAction mbCourseForm = do tell $ Set.singleton fId lift $ void . insertUnique $ CourseAppInstructionFile cid fId - keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs @@ -534,7 +534,7 @@ courseEditHandler miButtonAction mbCourseForm = do , formEncoding = formEnctype } -upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () +upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime Course{..} <- getJust cid diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 696ba927b..753bd7c10 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/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 - getKeyBy404 $ TermSchoolCourseShort tid csh ssh + cRoute <- getCurrentRoute + case cRoute of + Just (CourseR tid csh ssh CLecInviteR) -> + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + _other -> error "lecturerInvitationConfig called from unsupported route" invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of + invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 650047327..7e815fba2 100644 --- a/src/Handler/Course/List.hs +++ b/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) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index a54af6349..e2962ac0b 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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 - getKeyBy404 $ TermSchoolCourseShort tid csh ssh + cRoute <- getCurrentRoute + case cRoute of + Just (CourseR tid csh ssh CInviteR) -> + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + _other -> + error "participantInvitationConfig called from unsupported route" invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do @@ -98,9 +102,12 @@ data AddRecipientsResult = AddRecipientsResult , aurSuccess :: [UserEmail] } deriving (Read, Show, Generic, Typeable) +instance Semigroup AddRecipientsResult where + (<>) = mappenddefault + instance Monoid AddRecipientsResult where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index d134e31d1..abef977ae 100644 --- a/src/Handler/Course/Register.hs +++ b/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 () diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 085cc048a..cdab9b549 100644 --- a/src/Handler/Course/Show.hs +++ b/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 - E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - in return $ E.val tutorialCapacity' E.-. numParticipants - return . toWidget . tshow $ max 0 freeCapacity + freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) + . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + in return $ E.val tutorialCapacity' E.-. numParticipants + return . toWidget $ tshow freeCapacity , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True isRegistered <- case mbAid of @@ -137,7 +138,7 @@ getCShowR tid ssh csh = do Just uid -> existsBy $ UniqueTutorialParticipant tutId uid if | mayRegister -> do - (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm tutRegisterForm def { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR , formEncoding = tutRegisterEnctype @@ -198,7 +199,7 @@ getCShowR tid ssh csh = do -- Just uid -> existsBy $ UniqueExamRegistration eId uid -- if -- | mayRegister -> do - -- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + -- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered -- return $ wrapForm examRegisterForm def -- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR -- , formEncoding = examRegisterEnctype diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 7e8cc7cfd..bd222d966 100644 --- a/src/Handler/Course/User.hs +++ b/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 diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 7b12d45d0..df0169438 100644 --- a/src/Handler/Course/Users.hs +++ b/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 } diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 7aafb58e2..23203d2f2 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/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 diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index 738c2a3fb..8314a8ca1 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/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 - fetchExamId tid csh ssh examn + cRoute <- getCurrentRoute + case cRoute of + Just (CExamR tid csh ssh examn ECInviteR) -> + fetchExamId tid csh ssh examn + _other -> + error "examCorrectorInvitationConfig called from unsupported route" invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionExamCorrector, ()) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index c0b1c87a1..be151fdda 100644 --- a/src/Handler/Exam/Form.hs +++ b/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 - uid <- liftHandlerT requireAuthId + currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) @@ -140,7 +140,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do miCell' (Left email) = $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId + User{..} <- liftHandler . runDB $ get404 userId $(widgetFile "widgets/massinput/examCorrectors/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () @@ -150,7 +150,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) examOccurrenceForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag @@ -192,7 +192,7 @@ examOccurrenceForm prev = wFormToAForm $ do examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) examPartsForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 5810d3516..ff707cf04 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/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 - fetchExamId tid csh ssh examn + cRoute <- getCurrentRoute + case cRoute of + Just (CExamR tid csh ssh examn EInviteR) -> + fetchExamId tid csh ssh examn + _other -> + error "examRegistrationInvitationConfig called from unsupported route" invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Just $ Just invDBExamRegistrationDeadline itAddAuth | not invDBExamRegistrationCourseRegister @@ -81,8 +85,8 @@ examRegistrationInvitationConfig = InvitationConfig{..} itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized - invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do - isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse + invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do + isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse now <- liftIO getCurrentTime case (isRegistered, invDBExamRegistrationCourseRegister) of diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index d741948da..27c55a9b4 100644 --- a/src/Handler/Exam/Show.hs +++ b/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|

$if isRegistered diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 3c9d0944f..496bff9d8 100644 --- a/src/Handler/Exam/Users.hs +++ b/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} diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs index 73ed6e0ba..2db5ecf76 100644 --- a/src/Handler/ExamOffice/Course.hs +++ b/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) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 61b6a778d..87f5bbf10 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/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 @@ -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 } diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index a5794e701..9fd949692 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.ExamOffice.Exams ( getEOExamsR ) where diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs index 2df3860c2..58f7bc57a 100644 --- a/src/Handler/ExamOffice/Fields.hs +++ b/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 ] diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 1ff543437..123238812 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/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' diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index dad7ef747..7cb8aa83b 100644 --- a/src/Handler/Health.hs +++ b/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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4d48043f2..0382fab4a 100644 --- a/src/Handler/Home.hs +++ b/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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 85c7ca08d..c9d1e2677 100644 --- a/src/Handler/Material.hs +++ b/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 - [matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints +fetchMaterial tid ssh csh mnm = + maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints \(course `E.InnerJoin` material) -> do E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid @@ -86,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. material E.^. MaterialName E.==. E.val mnm return material - return matEnt getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -245,7 +244,7 @@ postMEditR tid ssh csh mnm = do E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) return $ file E.^. FileId - return (matEnt, (Left . E.unValue) <$> fileIds) + return (matEnt, Left . E.unValue <$> fileIds) -- let cid = materialCourse let template = Just MaterialForm { mfName = materialName @@ -308,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do when saveOk $ redirect -- redirect must happen outside of runDB $ CourseR tid ssh csh (MaterialR mfName MShowR) - insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () + insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB () insertMaterialFile' mid fs = do oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid return $ file E.^. FileId let oldFileIds = setFromList $ map E.unValue oldFileIdVals - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e6999d947..13a0e9c81 100644 --- a/src/Handler/Profile.hs +++ b/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 diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 1f665fb15..fa0ef7fe1 100644 --- a/src/Handler/School.hs +++ b/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 [] [] diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 784afcff1..06d200c2a 100644 --- a/src/Handler/Sheet.hs +++ b/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)) - , sfHintF :: Maybe (Source Handler (Either FileId File)) - , sfSolutionF :: Maybe (Source Handler (Either FileId File)) - , sfMarkingF :: Maybe (Source Handler (Either FileId File)) + , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ()) , sfType :: SheetType , sfGrouping :: SheetGroup , sfSubmissionMode :: SubmissionMode @@ -93,7 +90,7 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm msId template = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty - (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId + (Just sId) -> liftHandler $ runDB $ getFtIdMap sId mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm @@ -637,20 +634,20 @@ postSDelR tid ssh csh shn = do insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () insertSheetFile sid ftype finfo = do - runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert + runConduit $ sourceFiles finfo .| C.mapM_ finsert where finsert file = do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step -insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX () +insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX () insertSheetFile' sid ftype fs = do oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype return (file E.^. FileId) - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId @@ -694,8 +691,8 @@ defaultLoads shid = do correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) correctorForm shid = wFormToAForm $ do - Just currentRoute <- liftHandlerT getCurrentRoute - userId <- liftHandlerT requireAuthId + currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute + userId <- liftHandler requireAuthId MsgRenderer mr <- getMsgRenderer let @@ -703,9 +700,9 @@ correctorForm shid = wFormToAForm $ do currentLoads = Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid) - (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads + (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads - isWrite <- liftHandlerT $ isWriteRequest currentRoute + isWrite <- liftHandler $ isWriteRequest currentRoute let applyDefaultLoads = Map.null currentLoads' && not isWrite @@ -766,7 +763,7 @@ correctorForm shid = wFormToAForm $ do identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do - User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid + User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid return $ nameEmailWidget userEmail userDisplayName userSurname return (res, $(widgetFile "sheetCorrectors/cell")) @@ -894,15 +891,19 @@ correctorInvitationConfig = InvitationConfig{..} Course{..} <- get404 sheetCourse return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR invitationResolveFor _ = do - Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute - fetchSheetId tid csh ssh shn + cRoute <- getCurrentRoute + case cRoute of + Just (CSheetR tid csh ssh shn SCorrInviteR) -> + fetchSheetId tid csh ssh shn + _other -> + error "correctorInvitationConfig called from unsupported route" invitationSubject (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 03fdbe079..d3482dc22 100644 --- a/src/Handler/Submission.hs +++ b/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 - subId <- decrypt cID - bool notFound (return subId) =<< existsKey subId + cRoute <- getCurrentRoute + case cRoute of + Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do + subId <- decrypt cID + bool notFound (return subId) =<< existsKey subId + _other -> + error "submissionUserInvitationConfig called from unsupported route" invitationSubject (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse @@ -103,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..} invitationTokenConfig (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR) let itExpiresAt = Nothing itStartsAt = Nothing @@ -121,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..} return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR -makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId)) +makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode <*> wFormToAForm submittorsForm @@ -129,7 +133,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do - User{..} <- liftHandlerT . runDB $ getJust uid + User{..} <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/submissionUsers/cellKnown") miLayout :: ListLength @@ -191,7 +195,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty] | otherwise -> FormSuccess $ Set.fromList submittors' | otherwise = do - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId mRoute <- getCurrentRoute let @@ -275,7 +279,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe submissionHelper tid ssh csh shn mcid = do uid <- requireAuthId msmid <- traverse decrypt mcid - Just actionUrl <- getCurrentRoute + actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn @@ -478,7 +482,7 @@ submissionHelper tid ssh csh shn mcid = do Nothing -> return () -- Maybe construct a table to display uploaded archive files - let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) + let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) colonnadeFiles cid = mconcat [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 5198338bc..c6a3c2214 100644 --- a/src/Handler/SystemMessage.hs +++ b/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) - & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast + let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) + <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast case tableRes of FormMissing -> return () diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 85b81efb9..26c349c83 100644 --- a/src/Handler/Term.hs +++ b/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 diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 0aa65b045..94a00e645 100644 --- a/src/Handler/Tutorial.hs +++ b/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 - fetchTutorialId tid csh ssh tutn + cRoute <- getCurrentRoute + case cRoute of + Just (CTutorialR tid csh ssh tutn TInviteR) -> + fetchTutorialId tid csh ssh tutn + _other -> + error "tutorInvitationConfig called from unsupported route" invitationSubject (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionTutor, ()) @@ -289,8 +294,8 @@ data TutorialForm = TutorialForm tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm tutorialForm cid template html = do MsgRenderer mr <- getMsgRenderer - Just cRoute <- getCurrentRoute - uid <- liftHandlerT requireAuthId + cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId let tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) @@ -314,7 +319,7 @@ tutorialForm cid template html = do miCell' (Left email) = $(widgetFile "tutorial/tutorMassInput/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId + User{..} <- liftHandler . runDB $ get404 userId $(widgetFile "tutorial/tutorMassInput/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () @@ -338,7 +343,7 @@ tutorialForm cid template html = do ) (tfDeregisterUntil <$> template) <*> tutorForm where - tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text)) + tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 55f9260da..af6339dbc 100644 --- a/src/Handler/Users.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 18a94bb9f..40eaadcba 100644 --- a/src/Handler/Utils.hs +++ b/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} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 2e2ef88c8..933730346 100644 --- a/src/Handler/Utils/Communication.hs +++ b/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 diff --git a/src/Handler/Utils/ContentDisposition.hs b/src/Handler/Utils/ContentDisposition.hs index b353d1bb3..3fa5d579a 100644 --- a/src/Handler/Utils/ContentDisposition.hs +++ b/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 diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index a8e0d7201..89e4f1f70 100644 --- a/src/Handler/Utils/Csv.hs +++ b/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 - -> HandlerT site IO TypedContent + -> ConduitT () csv (HandlerFor site) () + -> HandlerFor site TypedContent respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk respondDefaultOrderedCsv :: forall csv site. ( ToNamedRecord csv , DefaultOrdered csv ) - => Source (HandlerT site IO) csv - -> HandlerT site IO TypedContent + => ConduitT () csv (HandlerFor site) () + -> HandlerFor site TypedContent respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) respondCsvDB :: ( ToNamedRecord csv , YesodPersistRunner site ) => Header - -> Source (YesodDB site) csv - -> HandlerT site IO TypedContent + -> ConduitT () csv (YesodDB site) () + -> HandlerFor site TypedContent respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk respondDefaultOrderedCsvDB :: forall csv site. @@ -159,16 +159,17 @@ respondDefaultOrderedCsvDB :: forall csv site. , DefaultOrdered csv , YesodPersistRunner site ) - => Source (YesodDB site) csv - -> HandlerT site IO TypedContent + => ConduitT () csv (YesodDB site) () + -> HandlerFor site TypedContent respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv , MonadResource m , MonadLogger m + , MonadThrow m ) => FileInfo - -> Source m csv + -> ConduitT () csv m () fileSourceCsv = (.| decodeCsv) . fileSource @@ -178,7 +179,7 @@ data CsvRendered = CsvRendered } deriving (Eq, Read, Show, Generic, Typeable) instance ToWidget UniWorX CsvRendered where - toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered") + toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered") where csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row | columnKey <- Vector.toList csvRenderedHeader @@ -190,7 +191,6 @@ instance ToWidget UniWorX CsvRendered where toCsvRendered :: forall mono. ( ToNamedRecord (Element mono) - , DefaultOrdered (Element mono) , MonoFoldable mono ) => Header diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index 83b299a94..b6f82ced0 100644 --- a/src/Handler/Utils/Database.hs +++ b/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 - => expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@ - -> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms) - -> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms)) +studyFeaturesQuery + :: E.SqlExpr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@ + -> E.SqlExpr (Entity StudyFeatures) `E.InnerJoin` E.SqlExpr (Entity StudyDegree) `E.InnerJoin` E.SqlExpr (Entity StudyTerms) + -> E.SqlQuery (E.SqlExpr (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms)) studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do E.on $ terms E.^. StudyTermsId E.==. features E.^. StudyFeaturesField E.on $ degree E.^. StudyDegreeId E.==. features E.^. StudyFeaturesDegree diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 159ad7779..cf337d3d1 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/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 diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 65c312fe0..6c5e6a0f2 100644 --- a/src/Handler/Utils/Delete.hs +++ b/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 - , drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting + , drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion + , drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting , drCaption , drSuccessMessage :: SomeMessage UniWorX , drAbort @@ -98,7 +98,7 @@ getDeleteR DeleteRoute{..} = do (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString - Just targetRoute <- getCurrentRoute + targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute let deleteForm = wrapForm deleteFormWdgt def { formAction = Just $ SomeRoute targetRoute , formEncoding = deleteFormEnctype diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ff88d91af..6556d1db7 100644 --- a/src/Handler/Utils/Form.hs +++ b/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) - => Map action (AForm (HandlerT UniWorX IO) a) +multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action) + => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> AForm Handler a multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty -multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) +multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> WForm Handler (FormResult a) multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction -multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) +multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) + => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) @@ -279,7 +279,7 @@ routeField :: ( Monad m routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField -- | Variant that simply removes leading and trailing white space -htmlField' :: Field (HandlerT UniWorX IO) Html +htmlField' :: Field Handler Html htmlField' = htmlField { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis } @@ -444,9 +444,11 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile)) specificFileForm = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute' <- getCurrentRoute let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag + miButtonAction frag = do + currentRoute <- currentRoute' + return . SomeRoute $ currentRoute :#: frag miIdent <- ("specific-files--" <>) <$> newIdent postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles) where @@ -647,7 +649,7 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp | otherwise = return . Left $ MsgUnknownPseudonymWord (CI.original w) -specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File) +specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ()) specificFileField UploadSpecificFile{..} = Field{..} where fieldEnctype = Multipart @@ -665,7 +667,7 @@ specificFileField UploadSpecificFile{..} = Field{..} zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions - -> Field Handler (Source Handler File) + -> Field Handler (ConduitT () File Handler ()) zipFileField doUnpack permittedExtensions = Field{..} where fieldEnctype = Multipart @@ -684,7 +686,7 @@ zipFileField doUnpack permittedExtensions = Field{..} fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` - -> UploadMode -> AForm Handler (Maybe (Source Handler File)) + -> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ())) fileUploadForm isReq mkFs = \case NoUpload -> pure Nothing @@ -693,21 +695,21 @@ fileUploadForm isReq mkFs = \case UploadSpecific{..} -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) where - specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File)) + specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ())) specificFileForm spec@UploadSpecificFile{..} = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing - mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File) + mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ()) mergeFileSources (catMaybes -> sources) = case sources of [] -> Nothing fs -> Just $ sequence_ fs -multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField` - -> Field Handler (Source Handler (Either FileId File)) +multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField` + -> Field Handler (ConduitT () (Either FileId File) Handler ()) multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference - -> Field Handler (Source Handler (Either FileId File)) + -> Field Handler (ConduitT () (Either FileId File) Handler ()) multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart @@ -723,7 +725,7 @@ multiFileField permittedFiles' = Field{..} .| C.filter (`elem` pVals) .| C.map Left let - handleFile :: FileInfo -> Source Handler File + handleFile :: FileInfo -> ConduitT () File Handler () handleFile | doUnpack = sourceFiles | otherwise = yieldM . acceptFile @@ -887,7 +889,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel langField :: Bool -- ^ Only allow values from `appLanguages` - -> Field (HandlerT UniWorX IO) Lang + -> Field Handler Lang langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts where langCheck (T.splitOn "-" -> lParts) = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts @@ -910,7 +912,7 @@ jsonField hide = Field{..} fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v) fieldParse [] [] = return $ Right Nothing fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired - fieldView theId name attrs val isReq = liftWidgetT [whamlet| + fieldView theId name attrs val isReq = liftWidget [whamlet| |] 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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 87dcc7a85..a0ba3dfb4 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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 diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index ced9c3c0b..1486ff192 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/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) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index b1618fc99..c7ea02cb3 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/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) - (ReaderT backend (WriterT (Set QueuedJobId) m)) - (Invitation' junction) + determineExists :: ConduitT (Invitation' junction) + (Invitation' junction) + (ReaderT backend (WriterT (Set QueuedJobId) m)) + () determineExists | is _Just (ephemeralInvitation @junction) = C.map id @@ -203,10 +207,10 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' decode invData = case fromJSON invData of JSON.Success dbData -> return dbData - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str - sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) () - sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do + sinkInvitations' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) () + sinkInvitations' = transPipe (hoist (hoist liftHandler) . withReaderT persistBackend) $ do C.mapM_ $ \(jInvitee, fid, dat) -> do app <- getYesod let mr = renderMessage app $ NonEmpty.toList appLanguages @@ -214,15 +218,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' fEnt <- Entity fid <$> get404 fid - jInviter <- liftHandlerT requireAuthId - route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat - InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat + jInviter <- liftHandler requireAuthId + route <- mapReaderT liftHandler $ invitationRoute fEnt dat + InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) jwt <- encodeToken token jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) - jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat - jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat) + jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat + jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat) when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation { invitationEmail = jInvitee @@ -237,7 +241,10 @@ sinkInvitationsF :: forall junction mono m backend. ( IsInvitableJunction junction , MonoFoldable mono , Element mono ~ Invitation' junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , MonadThrow m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction @@ -248,7 +255,10 @@ sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg sinkInvitation :: forall junction m backend. ( IsInvitableJunction junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , MonadThrow m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction @@ -260,23 +270,29 @@ sinkInvitation cfg = sinkInvitationsF cfg . Identity sourceInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadResource m, SqlBackendCanRead backend + , MonadResource m + , MonadThrow m + , PersistRecordBackend Invitation backend + , HasPersistBackend backend ) => Key (InvitationFor junction) - -> Source (ReaderT backend m) (UserEmail, InvitationDBData junction) + -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) () sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode where decode (Entity _ (Invitation{invitationEmail, invitationData})) = case fromJSON invitationData of JSON.Success dbData -> return (invitationEmail, dbData) - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str sourceInvitationsF :: forall junction map m backend. ( IsInvitableJunction junction , IsMap map , ContainerKey map ~ UserEmail , MapValue map ~ InvitationDBData junction - , MonadResource m, SqlBackendCanRead backend + , MonadResource m + , MonadThrow m + , PersistRecordBackend Invitation backend + , HasPersistBackend backend ) => Key (InvitationFor junction) -> ReaderT backend m map @@ -291,15 +307,17 @@ sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap ( -- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId deleteInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend ) => Key (InvitationFor junction) - -> Sink UserEmail (ReaderT backend m) () + -> ConduitT UserEmail Void (ReaderT backend m) () deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k deleteInvitationsF :: forall junction m mono backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend , MonoFoldable mono , Element mono ~ UserEmail ) @@ -312,7 +330,8 @@ deleteInvitationsF invitationFor (otoList -> emailList) deleteInvitation :: forall junction m backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend ) => Key (InvitationFor junction) -> UserEmail @@ -344,10 +363,10 @@ invitationR' :: forall junction m. => InvitationConfig junction -> m Html -- | Generic handler for incoming invitations -invitationR' InvitationConfig{..} = liftHandlerT $ do +invitationR' InvitationConfig{..} = liftHandler $ do InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction) invitee <- requireAuthId - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k) @@ -356,7 +375,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid) case fromJSON invitationData of JSON.Success dbData -> return dbData - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError $ "Could not decode invitationData: " <> pack str Just (cloneIso -> _DBData) -> return $ view _DBData () let iData :: InvitationData junction diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index e370676d5..726d7c975 100644 --- a/src/Handler/Utils/Mail.hs +++ b/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 - , MonadLogger m + , MonadThrow m + , MonadUnliftIO m ) => UserId -> MailT m a -> m a userMailT uid mAct = do user@User @@ -43,7 +42,7 @@ userMailT uid mAct = do , userDateTimeFormat , userDateFormat , userTimeFormat - } <- liftHandlerT . runDB $ getJust uid + } <- liftHandler . runDB $ getJust uid let ctx = MailContext { mcLanguages = userMailLanguages @@ -57,14 +56,13 @@ userMailT uid mAct = do mAct addFileDB :: ( MonadMail m - , MonadHandler m , HandlerSite m ~ UniWorX - ) => FileId -> m MailObjectId -addFileDB fId = do - File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId - addPart $ do + ) => FileId -> m (Maybe MailObjectId) +addFileDB fId = runMaybeT $ do + File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId + lift . addPart $ do _partType .= decodeUtf8 (mimeLookup fileName) _partEncoding .= Base64 _partFilename .= Just fileName _partContent .= LBS.fromStrict fileContent - setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId + setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index ecc5af873..2292ccfed 100644 --- a/src/Handler/Utils/Rating.hs +++ b/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 diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index b3161ac89..58a873228 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -16,13 +16,11 @@ sheetFileTypeDates Sheet{..} = \case SheetMarking -> Nothing -fetchSheetAux :: ( BaseBackend backend ~ SqlBackend - , E.SqlSelect b a - , Typeable a, MonadHandler m, IsPersistBackend backend - , PersistQueryRead backend, PersistUniqueRead backend +fetchSheetAux :: ( E.SqlSelect b a + , Typeable a, MonadHandler m ) => (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b) - -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a + -> TermId -> SchoolId -> CourseShorthand -> SheetName -> SqlReadT m a fetchSheetAux prj tid ssh csh shn = let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn) in cachedBy cachId $ do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index bafc69e84..383e7fe4e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 - ) => Conduit File m SubmissionContent + ) => ConduitT File SubmissionContent m () extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath) @@ -385,7 +386,7 @@ msgSubmissionErrors = flip catches sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied -- 'SubmissionContent'. @@ -420,7 +421,7 @@ sinkSubmission userId mExists isUpdate = do where tellSt = modify . mappend - guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent + guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m () guardFileTitles SubmissionMode{..} | Just UploadAny{..} <- submissionModeUser , not isUpdate @@ -435,7 +436,7 @@ sinkSubmission userId mExists isUpdate = do | otherwise = Conduit.map id sinkSubmission' :: SubmissionId - -> Sink SubmissionContent (YesodJobDB UniWorX) () + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) () sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -628,7 +629,7 @@ sinkSubmission userId mExists isUpdate = do sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} - -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) (Set SubmissionId) -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- @@ -666,7 +667,7 @@ sinkMultiSubmission userId isUpdate = do v@(Right (sId, _)) -> do cID <- encrypt sId $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID - lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ] + lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]) (Left f@File{..}) -> do let acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath]) @@ -678,7 +679,7 @@ sinkMultiSubmission userId isUpdate = do sId <- decrypt (cID :: CryptoFileNameSubmission) Just sId <$ get404 sId | otherwise = return Nothing - msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] + msId <- lift (lift (tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]) return (msId, fp) (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle case msId of @@ -687,8 +688,8 @@ sinkMultiSubmission userId isUpdate = do Just sId -> do $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle') cID <- encrypt sId - handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ - lift . feed sId $ Left f{ fileTitle = fileTitle' } + lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ + feed sId $ Left f{ fileTitle = fileTitle' } when (not $ null ignoredFiles) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 2e204b2cc..bf4ca6f13 100644 --- a/src/Handler/Utils/Table.hs +++ b/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| -

^{widget} diff --git a/test/Database.hs b/test/Database.hs index 312dcbbe0..140f0e490 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -7,7 +7,7 @@ module Database import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) -import Data.Pool (destroyAllResources) +import UnliftIO.Pool (destroyAllResources) import Database.Persist.Postgresql import Control.Monad.Logger @@ -25,6 +25,8 @@ import Control.Monad.Random.Class (MonadRandom(..)) import qualified Data.Set as Set +import Database.Persist.Sql.Raw.QQ + data DBAction = DBClear | DBTruncate @@ -48,7 +50,7 @@ main = do DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do - rawExecute "drop owned by current_user;" [] + [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () DBTruncate -> db $ do foundation <- getYesod liftIO . destroyAllResources $ appConnPool foundation diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index eaa471881..667edad18 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -19,7 +19,7 @@ spec = describe "Zip file handling" $ do it "has compatible encoding/decoding to/from zip files" . property $ do zipFiles <- listOf $ scale (`div` 2) arbitrary return . property $ do - zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume + zipFiles' <- runConduit $ Conduit.sourceList zipFiles .| produceZip def .| void consumeZip .| Conduit.consume forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do let acceptableFilenameChanges = makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid diff --git a/test/Test/QuickCheck/Classes/JSON.hs b/test/Test/QuickCheck/Classes/JSON.hs index 78d586ec3..5d323bbcb 100644 --- a/test/Test/QuickCheck/Classes/JSON.hs +++ b/test/Test/QuickCheck/Classes/JSON.hs @@ -24,7 +24,7 @@ jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey" ) ] where - partialIsomorphism :: forall a'. (Arbitrary a', FromJSONKey a', ToJSONKey a', Eq a', Show a') => a' -> Property + partialIsomorphism :: forall a'. (FromJSONKey a', ToJSONKey a', Eq a') => a' -> Property partialIsomorphism a = case (toJSONKey, fromJSONKey) of (ToJSONKeyText toVal _, FromJSONKeyCoerce _) -> property $ unsafeCoerce (toVal a) == a diff --git a/test/TestImport.hs b/test/TestImport.hs index 61b96ab43..d14c8ae07 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -4,7 +4,13 @@ module TestImport ) where import Application (makeFoundation, makeLogWare, shutdownApp) -import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc) +import ClassyPrelude as X + hiding ( delete, deleteBy + , Handler, Index + , (<.>), (<|) + , index, uncons, unsnoc, cons, snoc + , try, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_ + ) import Database.Persist as X hiding (get) import Database.Persist.Sql as X (SqlPersistM) import Database.Persist.Sql (runSqlPersistMPool) @@ -42,7 +48,9 @@ import Net.IP as X (IP) import Database (truncateDb) import Database as X (fillDb) -import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) +import Control.Monad.Catch as X hiding (Handler(..)) + +import Control.Monad.Trans.Resource (runResourceT) import Settings @@ -84,7 +92,7 @@ withApp = around $ \act -> runResourceT $ do -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. -wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () +wipeDB :: MonadUnliftIO m => UniWorX -> m () wipeDB app = runDBWithApp app Database.truncateDb -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag