diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 8b60430d0..27205f38c 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -43,6 +43,16 @@ "panel": "dedicated", "showReuseMessage": false } + }, + { + "type": "npm", + "script": "yesod:lint", + "problemMatcher": [] + }, + { + "type": "npm", + "script": "yesod:start", + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index 049692e5b..edd971e64 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -30,9 +30,14 @@ session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728" -health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller -health-check-http: "_env:HEALTHCHECK_HTTP:true" +health-check-interval: + matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600" + http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600" + ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" + smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600" + widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600" health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" +health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)? log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/frontend/src/utils/form/navigate-away-prompt.js b/frontend/src/utils/form/navigate-away-prompt.js index 151da8e5b..ac9e6db49 100644 --- a/frontend/src/utils/form/navigate-away-prompt.js +++ b/frontend/src/utils/form/navigate-away-prompt.js @@ -3,6 +3,7 @@ import { AUTO_SUBMIT_BUTTON_UTIL_SELECTOR } from "./auto-submit-button"; import { AUTO_SUBMIT_INPUT_UTIL_SELECTOR } from "./auto-submit-input"; const NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS = 'navigate-away-prompt--initialized'; +const NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT = '[uw-no-navigate-away-prompt]'; @Utility({ selector: 'form', @@ -30,6 +31,10 @@ export class NavigateAwayPrompt { return false; } + if (this._element.matches(NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT)) { + return false; + } + window.addEventListener('beforeunload', this._beforeUnloadHandler); this._element.addEventListener('submit', () => { diff --git a/frontend/src/utils/form/navigate-away-prompt.md b/frontend/src/utils/form/navigate-away-prompt.md index 627429023..3e6bff29a 100644 --- a/frontend/src/utils/form/navigate-away-prompt.md +++ b/frontend/src/utils/form/navigate-away-prompt.md @@ -6,6 +6,7 @@ This utility asks the user if (s)he really wants to navigate away from a page co ## Attribute: (none) (automatically setup on all form tags that dont automatically submit, see AutoSubmitButtonUtil) +(Does not setup on forms that have uw-no-navigate-away-prompt) ## Example usage: (any page with a form) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d7a6a484b..8513fc2db 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -239,7 +239,6 @@ MaterialVisibleFrom: Sichtbar für Teilnehmer ab MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren MaterialVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Benutzer verwirren könnte. MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar! -MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}! MaterialFiles: Dateien MaterialHeading materialName@MaterialName: Material "#{materialName}" MaterialListHeading: Materialien diff --git a/package.yaml b/package.yaml index 417b74e26..b9561aa88 100644 --- a/package.yaml +++ b/package.yaml @@ -126,6 +126,7 @@ dependencies: - streaming-commons - hourglass - unix + - stm-delay other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index b39657de7..ab612883c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -19,7 +19,7 @@ module Application import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) -import Import +import Import hiding (cancel) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, @@ -36,6 +36,8 @@ import System.Log.FastLogger ( defaultBufSize, newStderrLoggerSet , toLogStr, rmLoggerSet ) +import Handler.Utils (runAppLoggingT) + import qualified Data.Map.Strict as Map import Foreign.Store @@ -75,17 +77,22 @@ import System.Exit import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd -import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) +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 Control.Monad.Trans.State (execStateT) - import Network (socketPort) import qualified Network.Socket as Socket (close) +import Control.Concurrent.STM.Delay +import Control.Monad.STM (retry) + +import qualified Data.Set as Set + +import Data.Semigroup (Max(..), Min(..)) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -152,7 +159,7 @@ makeFoundation appSettings'@AppSettings{..} = do appJobCtl <- liftIO $ newTVarIO Map.empty appCronThread <- liftIO newEmptyTMVarIO - appHealthReport <- liftIO $ newTVarIO Nothing + appHealthReport <- liftIO $ newTVarIO Set.empty -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a @@ -217,13 +224,6 @@ makeFoundation appSettings'@AppSettings{..} = do $logDebugS "setup" "Done" return foundation -runAppLoggingT :: UniWorX -> LoggingT m a -> m a -runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc - where - logFunc loc src lvl str = do - f <- messageLoggerSource app <$> readTVarIO loggerTVar - f loc src lvl str - clusterSetting :: forall key m p. ( MonadIO m , ClusterSetting key @@ -333,7 +333,12 @@ warpSettings foundation = defaultSettings if | foundation ^. _appHealthCheckDelayNotify -> void . fork $ do - atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd) + let activeChecks = Set.fromList universeF + & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) + atomically $ do + results <- readTVar $ foundation ^. _appHealthReport + guard $ activeChecks == Set.map (classifyHealthReport . snd) results + guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results notifyReady | otherwise -> notifyReady @@ -354,19 +359,8 @@ warpSettings foundation = defaultSettings getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings -getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv -getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv - -adjustSettings :: MonadIO m => AppSettings -> m AppSettings -adjustSettings = execStateT $ do - watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC" - watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID" - myProcessID <- liftIO getProcessID - case watchdogMicroSec of - Just wInterval - | maybe True (== myProcessID) watchdogProcess - -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2) - _other -> return () +getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppSettings = liftIO $ loadYamlSettingsArgs [configSettingsYmlValue] useEnv -- | main function for use by yesod devel develMain :: IO () @@ -417,7 +411,47 @@ appMain = runResourceT $ do case didStore of Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart" Nothing -> forM_ sockets $ liftIO . Socket.close - liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal + liftIO $ throwTo mainThreadId ExitSuccess + + watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC" + watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID" + myProcessID <- liftIO getProcessID + case watchdogMicroSec of + Just wInterval + | maybe True (== myProcessID) watchdogProcess + -> let notifyWatchdog :: IO () + notifyWatchdog = runAppLoggingT foundation $ go Nothing + where + go pStatus = do + d <- liftIO . newDelay . floor $ wInterval % 2 + + status <- atomically $ asum + [ Nothing <$ waitDelay d + , Just <$> do + results <- readTVar $ foundation ^. _appHealthReport + case fromNullable results of + Nothing -> retry + Just rs -> do + let status = ofoldMap1 (Max *** Min . healthReportStatus) rs + guard $ pStatus /= Just status + return status + ] + + case status of + Just (_, Min status') -> do + $logInfoS "NotifyStatus" $ toPathPiece status' + liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status' + Nothing -> return () + + case status of + Just (_, Min HealthSuccess) -> do + $logInfoS "NotifyWatchdog" "Notify" + liftIO $ void Systemd.notifyWatchdog + _other -> return () + + go status + in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel + _other -> return () let runWarp socket = runSettingsSocket (warpSettings foundation) socket app case sockets of diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 2edb89350..5987caa4f 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -57,7 +57,7 @@ dummyLogin = AuthPlugin{..} { formMethod = POST , formAction = Just . SomeRoute . toMaster $ PluginR "dummy" [] , formEncoding = loginEnctype - , formAttrs = [] + , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit , formAnchor = Just "login--dummy" :: Maybe Text } diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e4c5aee74..9ea9d02e5 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -117,7 +117,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} { formMethod = POST , formAction = Just . SomeRoute . toMaster $ PluginR "LDAP" [] , formEncoding = loginEnctype - , formAttrs = [] + , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit , formAnchor = Just "login--campus" :: Maybe Text } diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index cc50b9415..a4eb42057 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -93,7 +93,7 @@ hashLogin pwHashAlgo = AuthPlugin{..} { formMethod = POST , formAction = Just . SomeRoute . toMaster $ PluginR "PWHash" [] , formEncoding = loginEnctype - , formAttrs = [] + , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit , formAnchor = Just "login--hash" :: Maybe Text } diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 4914bac78..59b925060 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module CryptoID diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index c3f1e4322..85f73dc03 100644 --- a/src/CryptoID/TH.hs +++ b/src/CryptoID/TH.hs @@ -11,6 +11,11 @@ import Data.Binary.SerializationLength import Data.CaseInsensitive (CI) import System.FilePath (FilePath) +import Data.Binary (Binary) +import qualified Data.Binary as Binary + +import Database.Persist.Sql + decCryptoIDs :: [Name] -> DecsQ decCryptoIDs = fmap concat . mapM decCryptoID @@ -21,6 +26,11 @@ decCryptoIDs = fmap concat . mapM decCryptoID instance HasFixedSerializationLength $(t) where type SerializationLength $(t) = SerializationLength Int64 + instance {-# OVERLAPPING #-} Binary $(t) where + put = Binary.put . fromSqlKey + putList = Binary.putList . map fromSqlKey + get = toSqlKey <$> Binary.get + type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns) |] diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs index 66ff1df61..4e87d05a9 100644 --- a/src/Data/Aeson/Types/Instances.hs +++ b/src/Data/Aeson/Types/Instances.hs @@ -14,9 +14,13 @@ import Data.Binary (Binary) import Data.HashMap.Strict.Instances () import Data.Vector.Instances () +import Model.Types.TH.JSON (derivePersistFieldJSON) + instance MonadThrow Parser where throwM = fail . show - instance Binary Value + + +derivePersistFieldJSON ''Value diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 3986e3cc7..b6b69fa02 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -26,6 +26,9 @@ import qualified Database.Esqueleto as E import Web.HttpApiData +import Data.Binary (Binary) +import qualified Data.Binary as Binary + instance PersistField (CI Text) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText @@ -92,5 +95,9 @@ instance FromHttpApiData (CI Text) where instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece - toPathMultiPiece = toPathMultiPiece . CI.foldedCase + toPathMultiPiece = toPathMultiPiece . CI.original +instance (CI.FoldCase s, Binary s) => Binary (CI s) where + get = CI.mk <$> Binary.get + put = Binary.put . CI.original + putList = Binary.putList . map CI.original diff --git a/src/Data/Time/Calendar/Instances.hs b/src/Data/Time/Calendar/Instances.hs new file mode 100644 index 000000000..395f455f8 --- /dev/null +++ b/src/Data/Time/Calendar/Instances.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.Calendar.Instances + ( + ) where + +import ClassyPrelude +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +deriving newtype instance Hashable Day + +instance Binary Day where + get = ModifiedJulianDay <$> Binary.get + put = Binary.put . toModifiedJulianDay + diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 1783ac465..b9721ab7d 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -11,14 +11,17 @@ import Data.Time.Clock import Data.Binary (Binary) import qualified Data.Binary as Binary +import Data.Time.Calendar.Instances () + + +instance Hashable DiffTime where + hashWithSalt s = hashWithSalt s . toRational + deriving instance Generic UTCTime +instance Hashable UTCTime -instance Binary Day where - get = ModifiedJulianDay <$> Binary.get - put = Binary.put . toModifiedJulianDay - instance Binary DiffTime where get = fromRational <$> Binary.get put = Binary.put . toRational diff --git a/src/Data/Time/Format/Instances.hs b/src/Data/Time/Format/Instances.hs new file mode 100644 index 000000000..dd2d68144 --- /dev/null +++ b/src/Data/Time/Format/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fno-warn-orphans #-} + +module Data.Time.Format.Instances + ( + ) where + +import qualified Language.Haskell.TH.Syntax as TH + +import Data.Time.Format + +import Data.Time.LocalTime.Instances () + + +deriving instance TH.Lift TimeLocale diff --git a/src/Data/Time/LocalTime/Instances.hs b/src/Data/Time/LocalTime/Instances.hs new file mode 100644 index 000000000..39c0d70f0 --- /dev/null +++ b/src/Data/Time/LocalTime/Instances.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.LocalTime.Instances + ( + ) where + +import ClassyPrelude + +import Data.Time.LocalTime + +import Data.Binary (Binary) + +import qualified Language.Haskell.TH.Syntax as TH + + +deriving instance Generic TimeOfDay +deriving instance Typeable TimeOfDay + +instance Hashable TimeOfDay +instance Binary TimeOfDay + + +deriving instance TH.Lift TimeZone diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs new file mode 100644 index 000000000..8a00de5e3 --- /dev/null +++ b/src/Data/UUID/Instances.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.UUID.Instances + () where + +import ClassyPrelude +import Data.UUID (UUID) +import qualified Data.UUID as UUID + +import Database.Persist.Sql +import Web.PathPieces + + +instance PathPiece UUID where + fromPathPiece = UUID.fromString . unpack + toPathPiece = pack . UUID.toString + +instance PersistField UUID where + toPersistValue = PersistDbSpecific . UUID.toASCIIBytes + + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" diff --git a/src/Data/Universe/Instances/Reverse/MonoTraversable.hs b/src/Data/Universe/Instances/Reverse/MonoTraversable.hs new file mode 100644 index 000000000..aaa50ca73 --- /dev/null +++ b/src/Data/Universe/Instances/Reverse/MonoTraversable.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Universe.Instances.Reverse.MonoTraversable + ( + ) where + +import Data.Universe +import Data.MonoTraversable + +import Data.Universe.Instances.Reverse + + +type instance Element (a -> b) = b + +instance Finite a => MonoFoldable (a -> b) +instance (Ord a, Finite a) => MonoTraversable (a -> b) + diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs new file mode 100644 index 000000000..23209a44b --- /dev/null +++ b/src/Database/Persist/Class/Instances.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.Class.Instances + ( + ) where + +import ClassyPrelude + +import Database.Persist.Class +import Database.Persist.Types.Instances () + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +instance PersistEntity record => Hashable (Key record) where + hashWithSalt s = hashWithSalt s . toPersistValue + +instance PersistEntity record => Binary (Key record) where + put = Binary.put . toPersistValue + putList = Binary.putList . map toPersistValue + get = either (fail . unpack) return . fromPersistValue =<< Binary.get diff --git a/src/Database/Persist/Sql/Instances.hs b/src/Database/Persist/Sql/Instances.hs deleted file mode 100644 index 2d0044164..000000000 --- a/src/Database/Persist/Sql/Instances.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Database.Persist.Sql.Instances - ( - ) where - -import ClassyPrelude.Yesod - -import Data.Binary (Binary) -import qualified Data.Binary as B - -import Database.Persist.Sql - - -instance Binary (BackendKey SqlWriteBackend) where - put = B.put . unSqlWriteBackendKey - putList = B.putList . map unSqlWriteBackendKey - get = SqlWriteBackendKey <$> B.get -instance Binary (BackendKey SqlReadBackend) where - put = B.put . unSqlReadBackendKey - putList = B.putList . map unSqlReadBackendKey - get = SqlReadBackendKey <$> B.get -instance Binary (BackendKey SqlBackend) where - put = B.put . unSqlBackendKey - putList = B.putList . map unSqlBackendKey - get = SqlBackendKey <$> B.get - - -instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where - put = B.put . fromSqlKey - putList = B.putList . map fromSqlKey - get = toSqlKey <$> B.get diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index db5957d54..eb02f5a22 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Types.Instances @@ -6,7 +5,18 @@ module Database.Persist.Types.Instances ) where import ClassyPrelude + import Database.Persist.Types -instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where - s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal +import Data.Time.Calendar.Instances () +import Data.Time.LocalTime.Instances () +import Data.Time.Clock.Instances () + +import Data.Binary (Binary) + + +deriving instance Generic PersistValue +deriving instance Typeable PersistValue + +instance Hashable PersistValue +instance Binary PersistValue diff --git a/src/Foundation.hs b/src/Foundation.hs index f88913801..6b5c9f508 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -46,7 +46,7 @@ import Data.Map (Map, (!?)) import qualified Data.Map as Map import qualified Data.HashSet as HashSet -import Data.List (nubBy, (!!)) +import Data.List (nubBy, (!!), findIndex) import Data.Monoid (Any(..)) @@ -130,7 +130,7 @@ data UniWorX = UniWorX , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key , appJSONWebKeySet :: Jose.JwkSet - , appHealthReport :: TVar (Maybe (UTCTime, HealthReport)) + , appHealthReport :: TVar (Set (UTCTime, HealthReport)) } makeLenses_ ''UniWorX @@ -493,7 +493,7 @@ askTokenUnsafe = $cachedHere $ do throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult -validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token' +validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token' where validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do @@ -524,7 +524,7 @@ tagAccessPredicate :: AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of -- Courses: access only to school admins - CourseR tid ssh csh _ -> exceptT return return $ do + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool @@ -536,7 +536,7 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) return Authorized -- other routes: access to any admin is granted here - _other -> exceptT return return $ do + _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) @@ -566,7 +566,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do return $ Unauthorized "Route under development" #endif tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse @@ -578,13 +578,13 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) return Authorized -- lecturer for any school will do - _ -> exceptT return return $ do + _ -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] return Authorized tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + resList <- $cachedHereBinary (mAuthId) . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId @@ -593,17 +593,17 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret resMap :: Map CourseId (Set SheetId) resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of - CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy return Authorized - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ cid `Set.member` Map.keysSet resMap return Authorized @@ -612,7 +612,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret return Authorized tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId E.where_ $ tutor E.^. TutorUser E.==. E.val authId @@ -622,12 +622,12 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do @@ -636,10 +636,10 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do now <- liftIO getCurrentTime - course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn registered <- case mAuthId of - Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid + Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid Nothing -> return False if @@ -654,8 +654,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of -> mzero CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime let visible = NTop sheetVisibleFrom <= NTop (Just cTime) @@ -684,8 +684,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm cTime <- liftIO getCurrentTime let visible = NTop materialVisibleFrom <= NTop (Just cTime) guard visible @@ -693,9 +693,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime - mbc <- getBy $ TermSchoolCourseShort tid ssh csh + mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh registered <- case (mbc,mAuthId) of - (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) + (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ isJust <$> (getBy $ UniqueParticipant uid cid) _ -> return False case mbc of (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) @@ -709,7 +709,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID - SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId + SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime && NTop systemMessageTo >= cTime @@ -719,7 +719,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid @@ -732,7 +732,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId @@ -745,7 +745,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout return Authorized CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId @@ -763,14 +763,14 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of whenExceptT ok Authorized participant <- decrypt cID -- participant is currently registered - authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant has at least one submission - authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -779,7 +779,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is member of a submissionGroup - authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant @@ -787,7 +787,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a sheet corrector - authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant @@ -795,7 +795,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user - authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant @@ -803,7 +803,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course - authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutor E.^. TutorUser E.==. E.val participant @@ -811,7 +811,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is lecturer for this course - authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid @@ -821,26 +821,26 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of r -> $unsupportedAuthPredicate AuthParticipant r tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn - registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn + registered <- $cachedHereBinary tutId . lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] guard $ NTop tutorialCapacity > NTop (Just registered) return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] + Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + registered <- $cachedHereBinary cid . lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn case (tutorialRegGroup, mAuthId) of (Nothing, _) -> return Authorized (_, Nothing) -> return AuthenticationRequired (Just rGroup, Just uid) -> do - [E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) @@ -850,9 +850,9 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ ((<= 0) :: Int -> Bool) . $cachedHereBinary cid . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return E.countRows @@ -860,26 +860,26 @@ tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate AuthMaterials r tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do + CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate AuthOwner r tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do + CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized r -> $unsupportedAuthPredicate AuthRated r tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do + CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn guard $ is _Just submissionModeUser @@ -887,8 +887,8 @@ tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of r -> $unsupportedAuthPredicate AuthUserSubmissions r tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r @@ -909,7 +909,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID - SystemMessage{..} <- MaybeT $ get smId + SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId let isAuthenticated = isJust mAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized @@ -918,6 +918,21 @@ tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorize tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) +authTagSpecificity :: AuthTag -> AuthTag -> Ordering +-- ^ Heuristic for which `AuthTag`s to evaluate first +authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem + where + eqClasses :: [[AuthTag]] + -- ^ Constructors of `AuthTag` ordered (increasing) by execution order + eqClasses = + [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide + , [ AuthRead, AuthWrite, AuthToken ] -- Request wide + , [ AuthAdmin ] -- Site wide + , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide + , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide + , [ AuthOwner, AuthRated ] -- Submission wide + ] + defaultAuthDNF :: AuthDNF defaultAuthDNF = PredDNF $ Set.fromList [ impureNonNull . Set.singleton $ PLVariable AuthAdmin @@ -945,16 +960,19 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult -- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite +evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite = do mr <- getMsgRenderer let + authVarSpecificity = authTagSpecificity `on` plVar + authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF' + authTagIsInactive = not . authTagIsActive evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult - evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite + evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite where - evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do + evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index ca358a335..aef00e033 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -35,7 +35,9 @@ import Data.Monoid (All(..)) -- import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.Conduit.List as C +import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Language (From) -- import qualified Database.Esqueleto.Internal.Sql as E @@ -77,6 +79,18 @@ lastEditQuery submission = E.sub_select $ E.from $ \edit -> do E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return $ E.max_ $ edit E.^. SubmissionEditTime +queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course) +queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) + +querySheet :: CorrectionTableExpr -> E.SqlExpr (Entity Sheet) +querySheet = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) + +querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission) +querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) + +queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryCorrector = $(sqlLOJproj 2 2) + -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -325,6 +339,35 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d Just True -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime Just False-> E.isNothing $ submission E.^. SubmissionRatingTime ) + , ( "corrector-name-email" -- corrector filter does not work for text-filtering + , FilterColumn $ E.anyFilter + [ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname) + , E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName) + , E.mkContainsFilter $ queryCorrector >>> (E.?. UserEmail) + ] + ) + , ( "user-name-email" + , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter + [ E.mkContainsFilter (E.^. UserSurname) + , E.mkContainsFilter (E.^. UserDisplayName) + , E.mkContainsFilter (E.^. UserEmail) + ] + ) + , ( "user-matriclenumber" + , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ (\f -> f user $ Set.singleton needle) $ + E.mkContainsFilter (E.^. UserMatrikelnummer) + ) + -- , ( "pseudonym" + -- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do + -- E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet + -- E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB. + -- ) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI } @@ -442,7 +485,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do [whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|] (Right $(widgetFile "messages/submissionsAssignNotFound")) addMessageWidget Error errorModal - + handle assignExceptions . runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do @@ -583,8 +626,16 @@ postCCorrectionsR tid ssh csh = do , colCorrector , colAssigned ] -- Continue here - psValidator = def - correctionsR whereClause colonnade Nothing psValidator $ Map.fromList + filterUI = Just $ \mPrev -> mconcat + [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) + , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) + , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) + -- "pseudonym" TODO DB only stores Word24 + , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) + ] + psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway + correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction @@ -607,8 +658,15 @@ postSSubsR tid ssh csh shn = do , colCorrector , colAssigned ] - psValidator = def - correctionsR whereClause colonnade Nothing psValidator $ Map.fromList + filterUI = Just $ \mPrev -> mconcat + [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) + , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) + , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) + -- "pseudonym" TODO DB only stores Word24 + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) + ] + psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway + correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 872ab3410..046c16aff 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -9,55 +9,71 @@ import Utils.Lens import qualified Data.UUID as UUID +import Data.Semigroup (Min(..), Max(..)) + +import qualified Data.Set as Set + +import Control.Concurrent.STM.Delay + getHealthR :: Handler TypedContent getHealthR = do - healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport - let - handleMissing = do - interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval - reportStore <- getsYesod appHealthReport - waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just) - case waitResult of - Left () -> fail "System is not generating HealthReports" - Right _ -> redirect HealthR - (lastUpdated, healthReport) <- maybe handleMissing return healthReport' + reportStore <- getsYesod appHealthReport + healthReports' <- liftIO $ readTVarIO reportStore interval <- getsYesod $ view _appHealthCheckInterval - instanceId <- getsYesod appInstanceID - setWeakEtagHashable (instanceId, lastUpdated) - expiresAt $ interval `addUTCTime` lastUpdated - setLastModified lastUpdated - - let status - | HealthSuccess <- classifyHealthReport healthReport - = ok200 - | otherwise - = internalServerError500 - sendResponseStatus status <=< selectRep $ do - provideRep . siteLayoutMsg MsgHealthReport $ do - setTitleI MsgHealthReport - let HealthReport{..} = healthReport - [whamlet| - $newline never -
-
_{MsgHealthMatchingClusterConfig} -
#{boolSymbol healthMatchingClusterConfig} - $maybe httpReachable <- healthHTTPReachable -
_{MsgHealthHTTPReachable} -
#{boolSymbol httpReachable} - $maybe ldapAdmins <- healthLDAPAdmins -
_{MsgHealthLDAPAdmins} -
#{textPercent ldapAdmins} - $maybe smtpConnect <- healthSMTPConnect -
_{MsgHealthSMTPConnect} -
#{boolSymbol smtpConnect} - $maybe widgetMemcached <- healthWidgetMemcached -
_{MsgHealthWidgetMemcached} -
#{boolSymbol widgetMemcached} - |] - provideJson healthReport - provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport + case fromNullable healthReports' of + Nothing -> do + let Min (NTop minInterval) = ofoldMap1 (Min . NTop) $ impureNonNull interval + delay <- for minInterval $ \minInterval' -> liftIO . newDelay . round $ toRational minInterval' * 1e6 + 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" + Right _ -> redirect HealthR + Just healthReports -> do + let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports + reportNextUpdate (lastCheck, classifyHealthReport -> kind) + = fromMaybe 0 (interval kind) `addUTCTime` lastCheck + Max nextUpdate = ofoldMap1 (Max . reportNextUpdate) healthReports + instanceId <- getsYesod appInstanceID + + setWeakEtagHashable (instanceId, lastUpdated) + expiresAt nextUpdate + setLastModified lastUpdated + + let status' + | HealthSuccess <- status + = ok200 + | otherwise + = internalServerError500 + sendResponseStatus status' <=< selectRep $ do + provideRep . siteLayoutMsg MsgHealthReport $ do + setTitleI MsgHealthReport + [whamlet| + $newline never +
+ $forall (_, report) <- healthReports' + $case report + $of HealthMatchingClusterConfig passed +
_{MsgHealthMatchingClusterConfig} +
#{boolSymbol passed} + $of HealthHTTPReachable (Just passed) +
_{MsgHealthHTTPReachable} +
#{boolSymbol passed} + $of HealthLDAPAdmins (Just found) +
_{MsgHealthLDAPAdmins} +
#{textPercent found} + $of HealthSMTPConnect (Just passed) +
_{MsgHealthSMTPConnect} +
#{boolSymbol passed} + $of HealthWidgetMemcached (Just passed) +
_{MsgHealthWidgetMemcached} +
#{boolSymbol passed} + $of _ + |] + provideJson healthReports + provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports getInstanceR :: Handler TypedContent getInstanceR = do diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 119fa5027..dbf6c8bad 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -222,12 +222,8 @@ getMShowR tid ssh csh mnm = do } return (matEnt,fileTable') - let matVisFro = materialVisibleFrom material - now <- liftIO getCurrentTime - materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material - materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro - when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $ - maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom + let matLastEdit = formatTimeW SelFormatDateTime $ materialLastEdit material + let matVisibleFromMB = visibleUTCTime SelFormatDateTime <$> materialVisibleFrom material let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index e1aea383f..8877dc8de 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -37,6 +37,8 @@ import System.FilePath.Posix (takeBaseName, takeFileName) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad.Logger + -- | Check whether the user's preference for files is inline-viewing or downloading downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool @@ -80,7 +82,7 @@ serveSomeFiles archiveName source = do results <- runDB . runConduit $ source .| peekN 2 $logDebugS "serveSomeFiles" . tshow $ length results - + case results of [] -> notFound [file] -> sendThisFile file @@ -91,9 +93,27 @@ serveSomeFiles archiveName source = do source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + +--------- +-- Simple utilities for consistent display +-- Please use these throughout, to ensure that users have a consistent experience + tidFromText :: Text -> Maybe TermId tidFromText = fmap TermKey . maybeRight . termFromText +-- | Display given UTCTime and maybe an invisible icon if it is in the future +-- +-- Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring) +visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget +visibleUTCTime dtf t = do + let timeStampWgt = formatTimeW dtf t + now <- liftIO getCurrentTime + if now >= t + then timeStampWgt + else $(widgetFile "widgets/date-time/yet-invisible") + + +-- | Simple link to a known route simpleLink :: Widget -> Route UniWorX -> Widget simpleLink lbl url = [whamlet|^{lbl}|] @@ -229,3 +249,12 @@ guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h => Route UniWorX -> a -> m (ReaderT SqlBackend h) a guardAuthorizedFor link val = val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False) + + +runAppLoggingT :: UniWorX -> LoggingT m a -> m a +runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc + where + logFunc loc src lvl str = do + f <- messageLoggerSource app <$> readTVarIO loggerTVar + f loc src lvl str + diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 042e90a52..7ee1f815a 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -20,9 +20,6 @@ import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Aeson.TH -import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..)) - data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGTutorialParticipants diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 12fdc847c..0b661e87e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -420,8 +420,8 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess in pure $ Map.singleton iStart fileRes return (addRes', formWidget') - miCell _ initFile initFile' nudge csrf = - sFileForm nudge (Just $ fromMaybe initFile initFile') csrf + miCell _ initFile _ nudge csrf = + sFileForm nudge (Just initFile) csrf miDelete = miDeleteList miAllowAdd _ _ _ = True miAddEmpty _ _ _ = Set.empty diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index e9121be5f..ae87527bf 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Handler.Utils.Form.MassInput @@ -9,6 +9,7 @@ module Handler.Utils.Form.MassInput , massInputA, massInputW , massInputList , massInputAccum, massInputAccumA, massInputAccumW + , massInputAccumEdit, massInputAccumEditA, massInputAccumEditW , ListLength(..), ListPosition(..), miDeleteList , EnumLiveliness(..), EnumPosition(..) , MapLiveliness(..) @@ -20,8 +21,6 @@ import Utils.Lens import Handler.Utils.Form.MassInput.Liveliness import Handler.Utils.Form.MassInput.TH -import Data.Aeson hiding (Result(..)) - import Algebra.Lattice hiding (join) import Text.Blaze (Markup) @@ -566,6 +565,83 @@ massInputAccumW :: forall handler cellData ident. massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev = mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty + +-- | 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 + , ToJSON cellData, FromJSON cellData + , PathPiece ident + ) + => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget))) + -> ((Text -> Text) -> cellData -> (Markup -> MForm handler (FormResult cellData, Widget))) + -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) + -> MassInputLayout ListLength cellData cellData + -> ident + -> FieldSettings UniWorX + -> Bool + -> Maybe [cellData] + -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX)) +massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf + = over (_1 . mapped) (map snd . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (\x -> (x, x)) <$> mPrev) csrf + where + miAdd :: ListPosition -> Natural + -> (Text -> Text) -> FieldView UniWorX + -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget)) + miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf' + + doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData)) + doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems + where + prevElems = Map.elems prevData + startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData + + miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text) + -> (Markup -> MForm handler (FormResult cellData, Widget)) + miCell _pos dat _mPrev nudge = miCell' nudge dat + + miDelete = miDeleteList + + miAllowAdd _ _ _ = True + + miAddEmpty _ _ _ = Set.empty + +massInputAccumEditA :: forall handler cellData ident. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , MonadLogger handler + , ToJSON cellData, FromJSON cellData + , PathPiece ident + ) + => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget))) + -> ((Text -> Text) -> cellData -> (Markup -> MForm handler (FormResult cellData, Widget))) + -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) + -> MassInputLayout ListLength cellData cellData + -> ident + -> FieldSettings UniWorX + -> Bool + -> Maybe [cellData] + -> AForm handler [cellData] +massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev + = formToAForm $ over _2 pure <$> massInputAccumEdit miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty + +massInputAccumEditW :: forall handler cellData ident. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , MonadLogger handler + , ToJSON cellData, FromJSON cellData + , PathPiece ident + ) + => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget))) + -> ((Text -> Text) -> cellData -> (Markup -> MForm handler (FormResult cellData, Widget))) + -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) + -> MassInputLayout ListLength cellData cellData + -> ident + -> FieldSettings UniWorX + -> Bool + -> Maybe [cellData] + -> WForm handler (FormResult [cellData]) +massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev + = mFormToWForm $ massInputAccumEdit miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty + massInputA :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index ba80dd1fe..510da890b 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -32,7 +32,6 @@ import qualified Data.HashSet as HashSet import Data.Aeson (fromJSON) import qualified Data.Aeson as JSON -import Data.Aeson.TH import Data.Proxy (Proxy(..)) import Data.Typeable diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index be6745a6a..7356e17b0 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -129,7 +129,7 @@ assignSubmissions sid restriction = do (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw guard $ sheetId == sid case restriction of - Just restriction' -> + Just restriction' -> guard $ subId `Set.member` restriction' Nothing -> guard $ is _Nothing submissionRatingBy @@ -146,7 +146,7 @@ assignSubmissions sid restriction = do => (Map SubmissionId a -> b) -> m b withSubmissionData f = f <$> (mappend <$> ask <*> State.get) - + -- | How many additional submission should the given corrector be assigned, if possible? calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet @@ -178,7 +178,7 @@ assignSubmissions sid restriction = do , fromMaybe 0 $ do guard $ corrState /= CorrectorExcused return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize - ] + ] | otherwise = assigned return $ negate extra @@ -257,6 +257,7 @@ submissionMultiArchive (Set.toList -> ids) = do execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) -> tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid) + setContentDisposition' $ Just "submissions.zip" (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 5ec84c9fe..620e6776b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -131,7 +131,9 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget --- | Show a date, and highlight date earlier than given watershed with an icon +-- | Show a date, and highlight date earlier than given watershed with an icon and cell class Warning +-- +-- Cannot use `Handler.Utils.visibleUTCTime`, since setting the UrgencyClass must be done outside the monad, hence the watershed argument. dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a dateTimeCellVisible watershed t | watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index c4e4d7081..09db6649d 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -151,7 +151,7 @@ fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo -> (d, FilterColumn t) fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)) --- | Searche all names, i.e. DisplayName, Surname, EMail +-- | Search all names, i.e. DisplayName, Surname, EMail fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 15a2952f5..52c1b3ec8 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fno-warn-orphans #-} - module Handler.Utils.Table.Pagination ( module Handler.Utils.Table.Pagination.Types , SortColumn(..), SortDirection(..) @@ -15,6 +13,7 @@ module Handler.Utils.Table.Pagination , PagesizeLimit(..) , PaginationSettings(..), PaginationInput(..), piIsUnset , PSValidator(..) + , defaultPagesize , defaultFilter, defaultSorting , restrictFilter, restrictSorting , ToSortable(..), Sortable(..) @@ -316,6 +315,13 @@ defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> inje Just _ -> id Nothing -> set (_2._psSorting) psSorting +defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x +defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' + where + injectDefault x = case x >>= piLimit of + Just _ -> id + Nothing -> set (_2._psLimit) psLimit + restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps where diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 975ae3925..0577f3915 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,107 +1,17 @@ module Import.NoFoundation ( module Import - , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons) +import Import.NoModel as Import import Model as Import -import Model.Types.JSON as Import import Model.Migration as Import import Model.Rating as Import import Model.Submission as Import import Model.Tokens as Import +import Utils.Tokens as Import +import Utils.Frontend.Modal as Import + import Settings as Import import Settings.StaticFiles as Import -import Yesod.Auth as Import -import Yesod.Core.Types as Import (loggerSet) -import Yesod.Default.Config2 as Import -import Utils as Import -import Utils.Frontend.Modal as Import -import Utils.Frontend.I18n as Import -import Utils.DB as Import -import Yesod.Core.Json as Import (provideJson) -import Yesod.Core.Types.Instances as Import (CachedMemoT(..)) - -import Language.Haskell.TH.Instances as Import () - -import Utils.Tokens as Import - - -import Data.Fixed as Import import CryptoID as Import -import Data.UUID as Import (UUID) - -import Text.Lucius as Import - -import Text.Shakespeare.Text as Import hiding (text, stext) - -import Data.Universe as Import -import Data.Universe.TH as Import -import Data.Pool as Import (Pool) -import Network.HaskellNet.SMTP as Import (SMTPConnection) - -import Mail as Import - -import Data.Data as Import (Data) -import Data.Typeable as Import (Typeable) -import GHC.Generics as Import (Generic) -import GHC.Exts as Import (IsList) - -import Data.Hashable as Import -import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) -import Data.List.NonEmpty.Instances as Import () -import Data.NonNull.Instances as Import () -import Data.Text.Encoding.Error as Import(UnicodeException(..)) -import Data.Semigroup as Import (Semigroup) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) -import Data.Monoid.Instances as Import () -import Data.Set.Instances as Import () -import Data.HashMap.Strict.Instances as Import () -import Data.HashSet.Instances as Import () -import Data.Vector.Instances as Import () -import Data.Time.Clock.Instances as Import () - -import Data.Binary as Import (Binary) - -import Control.Monad.Morph as Import (MFunctor(..)) - -import Control.Monad.Trans.Resource as Import (ReleaseKey) - -import Network.Mail.Mime.Instances as Import () -import Yesod.Core.Instances as Import () -import Data.Aeson.Types.Instances as Import () - -import Ldap.Client.Pool as Import - -import Database.Esqueleto.Instances as Import () -import Database.Persist.Sql.Instances as Import () -import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) -import Database.Persist.Types.Instances as Import () - -import Numeric.Natural.Instances as Import () -import System.Random as Import (Random) -import Control.Monad.Random.Class as Import (MonadRandom(..)) - -import Text.Blaze.Instances as Import () -import Jose.Jwt.Instances as Import () -import Jose.Jwt as Import (Jwt) -import Web.PathPieces.Instances as Import () - -import Data.Time.Calendar as Import -import Data.Time.Clock as Import -import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) -import Time.Types as Import (WeekDay(..)) - -import Time.Types.Instances as Import () - -import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) - -import Data.Ratio as Import ((%)) - -import Network.Mime as Import - - -import Control.Monad.Trans.RWS (RWST) - -type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs new file mode 100644 index 000000000..d2ba81705 --- /dev/null +++ b/src/Import/NoModel.hs @@ -0,0 +1,105 @@ +module Import.NoModel + ( module Import + , MForm + ) where + +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons) + +import Model.Types.TH.JSON as Import +import Model.Types.TH.Wordlist as Import + +import Mail as Import + +import Yesod.Auth as Import +import Yesod.Core.Types as Import (loggerSet) +import Yesod.Default.Config2 as Import +import Yesod.Core.Json as Import (provideJson) +import Yesod.Core.Types.Instances as Import + +import Utils as Import +import Utils.Frontend.I18n as Import +import Utils.DB as Import + +import Data.Fixed as Import + +import Data.UUID as Import (UUID) + +import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) + +import Text.Lucius as Import +import Text.Shakespeare.Text as Import hiding (text, stext) + +import Data.Universe as Import +import Data.Universe.TH as Import +import Data.Pool as Import (Pool) +import Network.HaskellNet.SMTP as Import (SMTPConnection) + +import Data.Data as Import (Data) +import Data.Typeable as Import (Typeable) +import GHC.Generics as Import (Generic) +import GHC.Exts as Import (IsList) +import Data.Ix as Import (Ix) + +import Data.Hashable as Import +import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) +import Data.Text.Encoding.Error as Import(UnicodeException(..)) +import Data.Semigroup as Import (Semigroup) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) +import Data.Binary as Import (Binary) + +import Numeric.Natural as Import (Natural) +import Data.Ratio as Import ((%)) + +import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey) + +import Ldap.Client.Pool as Import + +import System.Random as Import (Random(..)) +import Control.Monad.Random.Class as Import (MonadRandom(..)) + +import Control.Monad.Morph as Import (MFunctor(..)) +import Control.Monad.Trans.Resource as Import (ReleaseKey) + +import Jose.Jwt as Import (Jwt) + +import Data.Time.Calendar as Import +import Data.Time.Clock as Import +import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) +import Time.Types as Import (WeekDay(..)) + +import Network.Mime as Import + +import Data.Aeson.TH as Import +import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value) + +import Language.Haskell.TH.Instances as Import () +import Data.List.NonEmpty.Instances as Import () +import Data.NonNull.Instances as Import () +import Data.Monoid.Instances as Import () +import Data.Set.Instances as Import () +import Data.HashMap.Strict.Instances as Import () +import Data.HashSet.Instances as Import () +import Data.Vector.Instances as Import () +import Data.Time.Clock.Instances as Import () +import Data.Time.LocalTime.Instances as Import () +import Data.Time.Calendar.Instances as Import () +import Data.Time.Format.Instances as Import () +import Time.Types.Instances as Import () +import Network.Mail.Mime.Instances as Import () +import Yesod.Core.Instances as Import () +import Data.Aeson.Types.Instances as Import () +import Database.Esqueleto.Instances as Import () +import Numeric.Natural.Instances as Import () +import Text.Blaze.Instances as Import () +import Jose.Jwt.Instances as Import () +import Web.PathPieces.Instances as Import () +import Data.Universe.Instances.Reverse.MonoTraversable () +import Database.Persist.Class.Instances as Import () +import Database.Persist.Types.Instances as Import () +import Data.UUID.Instances as Import () +import System.FilePath.Instances as Import () + + +import Control.Monad.Trans.RWS (RWST) + +type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m diff --git a/src/Jobs.hs b/src/Jobs.hs index efbe126b6..867718bab 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -7,6 +7,7 @@ module Jobs import Import import Utils.Lens +import Handler.Utils import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) import Jobs.Types (JobCtl(JobCtlQueue)) @@ -32,6 +33,7 @@ import Control.Monad.Random (evalRand, mkStdGen, getRandomR) import Cron import qualified Data.HashMap.Strict as HashMap import Data.HashMap.Strict (HashMap) +import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty @@ -51,8 +53,6 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) -import qualified System.Systemd.Daemon as Systemd - import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -94,7 +94,7 @@ handleJobs foundation@UniWorX{..} = do logStart = $logDebugS ("Jobs #" <> tshow n) "Starting" logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping" removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId - doFork = flip forkFinally (\_ -> removeChan) . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n + doFork = flip forkFinally (\_ -> removeChan) . runAppLoggingT foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' foundation n (_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan) atomically . modifyTVar' appJobCtl $ Map.insert tId bChan @@ -102,7 +102,7 @@ handleJobs foundation@UniWorX{..} = do when (num > 0) $ do registeredCron <- liftIO newEmptyTMVarIO let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ - unsafeHandler foundation $ runReaderT execCrontab JobContext{..} + runReaderT (execCrontab foundation) JobContext{..} unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab) registeredCron' <- atomically $ do @@ -127,73 +127,75 @@ stopJobCtl UniWorX{appJobCtl, appCronThread} = do guard . none (`Map.member` wMap') $ Map.keysSet wMap -execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) () +execCrontab :: MonadIO m => UniWorX -> ReaderT JobContext m () -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have -- seen, wait for the time of the next job and fire it -execCrontab = evalStateT go HashMap.empty +execCrontab foundation = evalStateT go HashMap.empty where go = do - mapStateT (liftHandlerT . runDB . setSerializable) $ do - let - merge (Entity leId CronLastExec{..}) - | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob - = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) - | otherwise = lift $ delete leId - runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge + cont <- mapStateT (mapReaderT $ liftIO . unsafeHandler foundation) $ do + mapStateT (liftHandlerT . runDB . setSerializable) $ do + let + merge (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) + | otherwise = lift $ delete leId + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge - refT <- liftIO getCurrentTime - settings <- getsYesod appSettings' - currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do - crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab - case crontab' of - Nothing -> return Nothing - Just crontab -> Just <$> do - State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab - prevExec <- State.get - case earliestJob settings prevExec crontab refT of - Nothing -> liftBase retry - Just (_, MatchNone) -> liftBase retry - Just x -> return (crontab, x) + refT <- liftIO getCurrentTime + settings <- getsYesod appSettings' + currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do + crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab + case crontab' of + Nothing -> return Nothing + Just crontab -> Just <$> do + State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab + prevExec <- State.get + case earliestJob settings prevExec crontab refT of + Nothing -> liftBase retry + Just (_, MatchNone) -> liftBase retry + Just x -> return (crontab, x) - case currentState of - Nothing -> return () - Just (currentCrontab, (jobCtl, nextMatch)) -> do - let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do - newCrontab <- lift . lift . hoist lift $ determineCrontab' - if - | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab - -> do - now <- liftIO $ getCurrentTime - instanceID' <- getsYesod appInstanceID - State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl - case jobCtl of - JobCtlQueue job -> do - void . lift . lift $ upsertBy - (UniqueCronLastExec $ toJSON job) - CronLastExec - { cronLastExecJob = toJSON job - , cronLastExecTime = now - , cronLastExecInstance = instanceID' - } - [ CronLastExecTime =. now ] - lift . lift $ queueDBJob job - other -> writeJobCtl other - | otherwise - -> lift . mapReaderT (liftIO . atomically) $ - lift . void . flip swapTMVar newCrontab =<< asks jobCrontab + case currentState of + Nothing -> return False + Just (currentCrontab, (jobCtl, nextMatch)) -> do + let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do + newCrontab <- lift . lift . hoist lift $ determineCrontab' + if + | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab + -> do + now <- liftIO $ getCurrentTime + instanceID' <- getsYesod appInstanceID + State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl + case jobCtl of + JobCtlQueue job -> do + void . lift . lift $ upsertBy + (UniqueCronLastExec $ toJSON job) + CronLastExec + { cronLastExecJob = toJSON job + , cronLastExecTime = now + , cronLastExecInstance = instanceID' + } + [ CronLastExecTime =. now ] + lift . lift $ queueDBJob job + other -> writeJobCtl other + | otherwise + -> lift . mapReaderT (liftIO . atomically) $ + lift . void . flip swapTMVar newCrontab =<< asks jobCrontab - case nextMatch of - MatchAsap -> doJob - MatchNone -> return () - MatchAt nextTime -> do - JobContext{jobCrontab} <- ask - nextTime' <- applyJitter jobCtl nextTime - $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|] - logFunc <- askLoggerIO - whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime') - doJob + case nextMatch of + MatchAsap -> doJob + MatchNone -> return () + MatchAt nextTime -> do + JobContext{jobCrontab} <- ask + nextTime' <- applyJitter jobCtl nextTime + $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|] + logFunc <- askLoggerIO + whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime') + doJob - go + return True + when cont go where acc :: NominalDiffTime acc = 1e-3 @@ -245,12 +247,12 @@ execCrontab = evalStateT go HashMap.empty bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged -handleJobs' :: Natural -> Sink JobCtl (ReaderT JobContext Handler) () -handleJobs' wNum = C.mapM_ $ \jctl -> do +handleJobs' :: (MonadIO m, MonadLogger m, MonadCatch m) => UniWorX -> Natural -> Sink JobCtl (ReaderT JobContext m) () +handleJobs' foundation wNum = C.mapM_ $ \jctl -> do $logDebugS logIdent $ tshow jctl resVars <- mapReaderT (liftIO . atomically) $ HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm) - res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl + res <- fmap (either Just $ const Nothing) . try . (mapReaderT $ liftIO . unsafeHandler foundation) $ handleCmd jctl sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars) case res of Just err @@ -284,21 +286,19 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . void . flip swapTMVar newCTab =<< asks jobCrontab - handleCmd JobCtlGenerateHealthReport = do + handleCmd (JobCtlGenerateHealthReport kind) = do hrStorage <- getsYesod appHealthReport - newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport + newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind - $logInfoS "HealthReport" $ toPathPiece newStatus + $logInfoS (tshow kind) $ toPathPiece newStatus unless (newStatus == HealthSuccess) $ do - $logErrorS "HealthReport" $ tshow newReport + $logErrorS (tshow kind) $ tshow newReport liftIO $ do now <- getCurrentTime - atomically . writeTVar hrStorage $ Just (now, newReport) - - void . Systemd.notifyStatus . unpack $ toPathPiece newStatus - when (newStatus == HealthSuccess) $ - void Systemd.notifyWatchdog + let updateReports = Set.insert (now, newReport) + . Set.filter (((/=) `on` classifyHealthReport) newReport . snd) + atomically . modifyTVar' hrStorage $ force . updateReports jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index fac38ae52..aecca927e 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -43,14 +43,17 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } - tell $ HashMap.singleton - JobCtlGenerateHealthReport - Cron - { cronInitial = CronAsap - , cronRepeat = CronRepeatScheduled CronAsap - , cronRateLimit = appHealthCheckInterval - , cronNotAfter = Right CronNotScheduled - } + tell . flip foldMap universeF $ \kind -> + case appHealthCheckInterval kind of + Just int -> HashMap.singleton + (JobCtlGenerateHealthReport kind) + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = int + , cronNotAfter = Right CronNotScheduled + } + Nothing -> mempty let sheetJobs (Entity nSheet Sheet{..}) = do diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index a8f6a0ff4..45500a8bb 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -28,18 +28,13 @@ import qualified Network.HaskellNet.SMTP as SMTP import Data.Pool (withResource) -generateHealthReport :: Handler HealthReport -generateHealthReport - = runConcurrently $ HealthReport - <$> Concurrently matchingClusterConfig - <*> Concurrently httpReachable - <*> Concurrently ldapAdmins - <*> Concurrently smtpConnect - <*> Concurrently widgetMemcached +generateHealthReport :: HealthCheck -> Handler HealthReport +generateHealthReport = $(dispatchTH ''HealthCheck) -matchingClusterConfig :: Handler Bool +dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport -- ^ Can the cluster configuration be read from the database and does it match our configuration? -matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches +dispatchHealthCheckMatchingClusterConfig + = fmap HealthMatchingClusterConfig . runDB $ and <$> forM universeF clusterSettingMatches where clusterSettingMatches ClusterCryptoIDKey = do ourSetting <- getsYesod appCryptoIDKey @@ -74,11 +69,11 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches _other -> return Nothing -httpReachable :: Handler (Maybe Bool) -httpReachable = do +dispatchHealthCheckHTTPReachable :: Handler HealthReport +dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do staticAppRoot <- getsYesod $ view _appRoot doHTTP <- getsYesod $ view _appHealthCheckHTTP - for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do + for (staticAppRoot <* guard doHTTP) $ \_ -> do url <- getUrlRender <*> pure InstanceR baseRequest <- HTTP.parseRequest $ unpack url httpManager <- getsYesod appHttpManager @@ -88,8 +83,8 @@ httpReachable = do getsYesod $ (== clusterId) . appClusterID -ldapAdmins :: Handler (Maybe Rational) -ldapAdmins = do +dispatchHealthCheckLDAPAdmins :: Handler HealthReport +dispatchHealthCheckLDAPAdmins = HealthLDAPAdmins <$> do ldapPool' <- getsYesod appLdapPool ldapConf' <- getsYesod $ view _appLdapConf ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do @@ -109,8 +104,8 @@ ldapAdmins = do _other -> return Nothing -smtpConnect :: Handler (Maybe Bool) -smtpConnect = do +dispatchHealthCheckSMTPConnect :: Handler HealthReport +dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> do smtpPool <- getsYesod appSmtpPool for smtpPool . flip withResource $ \smtpConn -> do response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP @@ -121,8 +116,8 @@ smtpConnect = do return False -widgetMemcached :: Handler (Maybe Bool) -widgetMemcached = do +dispatchHealthCheckWidgetMemcached :: Handler HealthReport +dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do memcachedConn <- getsYesod appWidgetMemcached for memcachedConn $ \_memcachedConn' -> do let ext = "bin" diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f333f0c7d..3522ff802 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -69,7 +69,7 @@ data JobCtl = JobCtlFlush | JobCtlPerform QueuedJobId | JobCtlDetermineCrontab | JobCtlQueue Job - | JobCtlGenerateHealthReport + | JobCtlGenerateHealthReport HealthCheck deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Hashable JobCtl diff --git a/src/Mail.hs b/src/Mail.hs index 82bac2273..8cfa03200 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -35,7 +35,9 @@ module Mail , _partType, _partEncoding, _partFilename, _partHeaders, _partContent ) where -import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender) +import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON) + +import Model.Types.TH.JSON import Network.Mail.Mime hiding (addPart, addAttachment) import qualified Network.Mail.Mime as Mime (addPart) @@ -159,6 +161,7 @@ instance Default MailLanguages where instance Hashable MailLanguages + data MailContext = MailContext { mcLanguages :: MailLanguages , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat @@ -506,3 +509,6 @@ setMailSmtpData = do in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp } | otherwise -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from } + + +derivePersistFieldJSON ''MailLanguages diff --git a/src/Model.hs b/src/Model.hs index 1e1ecf062..c86406275 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -6,7 +6,7 @@ module Model , module Cron.Types ) where -import ClassyPrelude.Yesod +import Import.NoModel import Database.Persist.Quasi import Database.Persist.TH.Directory -- import Data.Time @@ -23,8 +23,6 @@ import Utils.Message (MessageStatus) import Settings.Cluster (ClusterSettingsKey) -import Data.Binary (Binary) - -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: @@ -38,9 +36,5 @@ deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial --- Primary keys mentioned in dbtable row-keys must be Binary --- Automatically generated (i.e. numeric) ids are already taken care of -deriving instance Binary (Key Term) - submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 4720bf099..e5ed53362 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -7,7 +7,7 @@ import Data.Aeson.TH (deriveJSON, defaultOptions) import Utils.PathPiece import qualified Model as Current -import qualified Model.Types.JSON as Current +import qualified Model.Types.TH.JSON as Current import Data.Universe diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b1692283c..a8e2fc90c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -1,72 +1,14 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) - - - module Model.Types - ( module Model.Types - , module Model.Types.Sheet - , module Model.Types.DateTime - , module Model.Types.Security - , module Model.Types.Misc - , module Numeric.Natural - , module Mail - , module Utils.DateTime - , module Data.UUID.Types + ( module Types ) where -import ClassyPrelude -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.NonNull.Instances () - -import Data.Text (Text) -import qualified Data.Text as Text -import Data.CaseInsensitive (CI) -import Data.CaseInsensitive.Instances () - -import Data.Universe.Instances.Reverse () - -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Yesod.Auth.Util.PasswordStore as PWStore -import Web.PathPieces - -import Mail (MailLanguages(..)) -import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..)) -import Numeric.Natural - -import Model.Types.Sheet -import Model.Types.DateTime -import Model.Types.Security -import Model.Types.Misc - ----- --- Just bringing together the different Model.Types submodules. - -instance PathPiece UUID where - fromPathPiece = UUID.fromString . unpack - toPathPiece = pack . UUID.toString - -instance {-# OVERLAPS #-} PathMultiPiece FilePath where - fromPathMultiPiece = Just . unpack . intercalate "/" - toPathMultiPiece = Text.splitOn "/" . pack - - --- Type synonyms - -type Email = Text - -type SchoolName = CI Text -type SchoolShorthand = CI Text -type CourseName = CI Text -type CourseShorthand = CI Text -type SheetName = CI Text -type MaterialName = CI Text -type UserEmail = CI Email -type TutorialName = CI Text - -type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString -type InstanceId = UUID -type ClusterId = UUID -type TokenId = UUID -type TermCandidateIncidence = UUID +import Model.Types.Common as Types +import Model.Types.Course as Types +import Model.Types.DateTime as Types +import Model.Types.Exam as Types +import Model.Types.Health as Types +import Model.Types.Mail as Types +import Model.Types.Security as Types +import Model.Types.Sheet as Types +import Model.Types.Submission as Types +import Model.Types.Misc as Types diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs new file mode 100644 index 000000000..5ffbcfb07 --- /dev/null +++ b/src/Model/Types/Common.hs @@ -0,0 +1,35 @@ +{-| +Module: Model.Types.Common +Description: Common types used by most @Model.Types.*@-Modules + +Types used by multiple other @Model.Types.*@-Modules +-} +module Model.Types.Common + ( module Model.Types.Common + ) where + +import Import.NoModel + +import qualified Yesod.Auth.Util.PasswordStore as PWStore + + +type Count = Sum Integer +type Points = Centi + + +type Email = Text + +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text +type CourseShorthand = CI Text +type SheetName = CI Text +type MaterialName = CI Text +type UserEmail = CI Email +type TutorialName = CI Text + +type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString +type InstanceId = UUID +type ClusterId = UUID +type TokenId = UUID +type TermCandidateIncidence = UUID diff --git a/src/Model/Types/Course.hs b/src/Model/Types/Course.hs new file mode 100644 index 000000000..4a1a08b3c --- /dev/null +++ b/src/Model/Types/Course.hs @@ -0,0 +1,26 @@ +{-| +Module: Model.Types.Course +Description: Types for modeling Courses + +Also see `Model.Types.Sheet` +-} +module Model.Types.Course + ( module Model.Types.Course + ) where + +import Import.NoModel + + +data LecturerType = CourseLecturer | CourseAssistant + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe LecturerType +instance Finite LecturerType + +nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''LecturerType +derivePersistFieldJSON ''LecturerType + +instance Hashable LecturerType diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index cb7b2999d..10783550e 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -1,34 +1,28 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +{-| +Module: Model.Types.DateTime +Description: Time related types -module Model.Types.DateTime where +Terms, Seasons, and Occurence schedules +-} +module Model.Types.DateTime + ( module Model.Types.DateTime + ) where - -import ClassyPrelude -import GHC.Generics (Generic) -import Utils +import Import.NoModel import Control.Lens -import Data.NonNull.Instances () -import Data.Typeable (Typeable) -import Data.Universe.Instances.Reverse () -import Data.Binary (Binary) -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -import Data.CaseInsensitive.Instances () import Text.Read (readMaybe) -import Database.Persist.Class import Database.Persist.Sql import Web.HttpApiData -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), withText) +import Data.Aeson.Types as Aeson + +import Time.Types (WeekDay(..)) +import Data.Time.LocalTime (LocalTime, TimeOfDay) ---- @@ -70,6 +64,7 @@ instance Enum TermIdentifier where -- from_TermIdentifier_to_TermId = TermKey shortened :: Iso' Integer Integer +-- ^ Year numbers shortened to two digits shortened = iso shorten expand where century = ($currentYear `div` 100) * 100 @@ -156,3 +151,44 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 timeYear = fst3 $ toGregorian time termYear = year term + +data OccurenceSchedule = ScheduleWeekly + { scheduleDayOfWeek :: WeekDay + , scheduleStart :: TimeOfDay + , scheduleEnd :: TimeOfDay + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "repeat" "schedule" + } ''OccurenceSchedule + +data OccurenceException = ExceptOccur + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccur + { exceptTime :: LocalTime + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "exception" "for" + } ''OccurenceException + +data Occurences = Occurences + { occurencesScheduled :: Set OccurenceSchedule + , occurencesExceptions :: Set OccurenceException + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''Occurences +derivePersistFieldJSON ''Occurences + diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs new file mode 100644 index 000000000..fb7ed10a1 --- /dev/null +++ b/src/Model/Types/Exam.hs @@ -0,0 +1,16 @@ +{-| +Module: Model.Types.Exam +Description: Types for modeling Exams +-} +module Model.Types.Exam + ( module Model.Types.Exam + ) where + +import Import.NoModel + +import Database.Persist.TH (derivePersistField) + + +data ExamStatus = Attended | NoShow | Voided + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +derivePersistField "ExamStatus" diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs new file mode 100644 index 000000000..aea99d735 --- /dev/null +++ b/src/Model/Types/Health.hs @@ -0,0 +1,87 @@ +{-| +Module: Model.Types.Health +Description: Types for running self-tests +-} +module Model.Types.Health + ( module Model.Types.Health + ) where + +import Import.NoModel + + +data HealthCheck + = HealthCheckMatchingClusterConfig + | HealthCheckHTTPReachable + | HealthCheckLDAPAdmins + | HealthCheckSMTPConnect + | HealthCheckWidgetMemcached + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe HealthCheck +instance Finite HealthCheck +instance Hashable HealthCheck + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + } ''HealthCheck +nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2 +pathPieceJSONKey ''HealthCheck + +data HealthReport + = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool } + -- ^ Is the database-stored configuration we're running under still up to date? + -- + -- Also tests database connection as a side effect + | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool } + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational } + -- ^ Proportion of school admins that could be found in LDAP + | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool } + -- ^ Can we connect to the SMTP server and say @NOOP@? + | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool } + -- ^ Can we store values in memcached and retrieve them via HTTP? + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + +instance NFData HealthReport + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + , sumEncoding = TaggedObject "test" "result" + , tagSingleConstructors = True + } ''HealthReport + +classifyHealthReport :: HealthReport -> HealthCheck +classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig +classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins +classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable +classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect +classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +healthReportStatus :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +healthReportStatus = \case + HealthMatchingClusterConfig False -> HealthFailure + HealthHTTPReachable (Just False) -> HealthFailure + HealthLDAPAdmins (Just prop ) + | prop <= 0 -> HealthFailure + HealthSMTPConnect (Just False) -> HealthFailure + HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? + _other -> maxBound -- Minimum badness diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs new file mode 100644 index 000000000..d2507e6f9 --- /dev/null +++ b/src/Model/Types/Mail.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Model.Types.Mail +Description: Types related to Notifications +-} + +module Model.Types.Mail + ( module Model.Types.Mail + ) where + +import Import.NoModel + +import qualified Data.Aeson.Types as Aeson + +import qualified Data.HashMap.Strict as HashMap + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger + = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetSoonInactive + | NTSheetInactive + | NTCorrectionsAssigned + | NTCorrectionsNotDistributed + | NTUserRightsUpdate + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetSoonInactive -> False + NTSheetInactive -> True + NTCorrectionsAssigned -> True + NTCorrectionsNotDistributed -> True + NTUserRightsUpdate -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = Aeson.withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index aa3811f9d..efe0308a6 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -1,50 +1,25 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +{-| +Module: Model.Types.Misc +Description: Additional uncategorized types +-} -module Model.Types.Misc where +module Model.Types.Misc + ( module Model.Types.Misc + ) where - -import ClassyPrelude -import Utils +import Import.NoModel import Control.Lens -import Data.NonNull.Instances () -import Data.Set (Set) import Data.Maybe (fromJust) -import Data.Universe -import Data.Universe.Helpers import qualified Data.Text as Text import qualified Data.Text.Lens as Text -import Data.CaseInsensitive.Instances () -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON - -import Data.Aeson (Value()) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) - -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - -import Data.Universe.Instances.Reverse () - -import Data.Time.LocalTime (LocalTime, TimeOfDay) -import Time.Types (WeekDay(..)) - - ------ --- Miscellaneous Model.Types - -derivePersistFieldJSON ''Value data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) derivePersistField "StudyFieldType" --- instance DisplayAble StudyFieldType data Theme = ThemeDefault @@ -59,89 +34,11 @@ deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Theme" } ''Theme -instance Universe Theme where universe = universeDef +instance Universe Theme instance Finite Theme -nullaryPathPiece ''Theme (camelToPathPiece' 1) +nullaryPathPiece ''Theme $ camelToPathPiece' 1 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user derivePersistField "Theme" - - -data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = fromJust . stripPrefix "Corrector" - } ''CorrectorState - -instance Universe CorrectorState -instance Finite CorrectorState - -instance Hashable CorrectorState - -nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) - -derivePersistField "CorrectorState" - - -data LecturerType = CourseLecturer | CourseAssistant - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe LecturerType -instance Finite LecturerType - -nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''LecturerType -derivePersistFieldJSON ''LecturerType - -instance Hashable LecturerType - - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - } ''WeekDay - -data OccurenceSchedule = ScheduleWeekly - { scheduleDayOfWeek :: WeekDay - , scheduleStart :: TimeOfDay - , scheduleEnd :: TimeOfDay - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , tagSingleConstructors = True - , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule - -data OccurenceException = ExceptOccur - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccur - { exceptTime :: LocalTime - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException - -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences - diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 27be35f81..1c1919fdf 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -1,83 +1,26 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Model.Types.Security where +{-| +Module: Model.Types.Security +Description: Types for authentication and authorisation +-} +module Model.Types.Security + ( module Model.Types.Security + ) where -import ClassyPrelude -import Utils -import Control.Lens hiding (universe) +import Import.NoModel import Data.Set (Set) -import qualified Data.Set as Set -import Data.Universe -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.NonNull.Instances () - -import Data.Default - -import Model.Types.JSON -import Database.Persist.Class -import Database.Persist.Sql - -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.HashMap.Strict as HashMap -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.CaseInsensitive.Instances () - -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject) -import Data.Aeson.Types (toJSONKeyText) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - -import Data.Universe.Instances.Reverse () - -import Mail (MailLanguages(..)) - -import Data.Word.Word24 (Word24) -import Data.Bits -import Data.Ix -import Data.List (genericIndex, elemIndex) -import System.Random (Random(..)) -import Data.Data (Data) - -import Model.Types.Wordlist -import Data.Text.Metrics (damerauLevenshtein) - -import Data.Binary (Binary) import qualified Data.Binary as Binary -import Data.Semigroup (Min(..)) -import Control.Monad.Trans.Writer (execWriter) -import Control.Monad.Writer.Class (MonadWriter(..)) - - ----- --- Security, Authentification, Notification Stuff - -instance PersistField UUID where - toPersistValue = PersistDbSpecific . UUID.toASCIIBytes - fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t - fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x - -instance PersistFieldSql UUID where - sqlType _ = SqlOther "uuid" - data AuthenticationMode = AuthLDAP | AuthPWHash { authPWHash :: Text } @@ -92,167 +35,6 @@ deriveJSON defaultOptions derivePersistFieldJSON ''AuthenticationMode - --- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ --- --- Could maybe be replaced with `Structure Notification` in the long term -data NotificationTrigger = NTSubmissionRatedGraded - | NTSubmissionRated - | NTSheetActive - | NTSheetSoonInactive - | NTSheetInactive - | NTCorrectionsAssigned - | NTCorrectionsNotDistributed - | NTUserRightsUpdate - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } ''NotificationTrigger - -instance ToJSONKey NotificationTrigger where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey NotificationTrigger where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - - -newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } - deriving (Generic, Typeable) - deriving newtype (Eq, Ord, Read, Show) - -instance Default NotificationSettings where - def = NotificationSettings $ \case - NTSubmissionRatedGraded -> True - NTSubmissionRated -> False - NTSheetActive -> True - NTSheetSoonInactive -> False - NTSheetInactive -> True - NTCorrectionsAssigned -> True - NTCorrectionsNotDistributed -> True - NTUserRightsUpdate -> True - -instance ToJSON NotificationSettings where - toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF - -instance FromJSON NotificationSettings where - parseJSON = withObject "NotificationSettings" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) - return . NotificationSettings $ \n -> case HashMap.lookup n o' of - Nothing -> notificationAllowed def n - Just b -> b - -derivePersistFieldJSON ''NotificationSettings - - -instance ToBackendKey SqlBackend record => Hashable (Key record) where - hashWithSalt s key = s `hashWithSalt` fromSqlKey key - -derivePersistFieldJSON ''MailLanguages - - -type PseudonymWord = CI Text - -newtype Pseudonym = Pseudonym Word24 - deriving (Eq, Ord, Read, Show, Generic, Data) - deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) - - -instance PersistField Pseudonym where - toPersistValue p = toPersistValue (fromIntegral p :: Word32) - fromPersistValue v = do - w <- fromPersistValue v :: Either Text Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> Left "Pseudonym out of range" - -instance PersistFieldSql Pseudonym where - sqlType _ = SqlInt32 - -instance Random Pseudonym where - randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen - random = randomR (minBound, maxBound) - -instance FromJSON Pseudonym where - parseJSON v@(Aeson.Number _) = do - w <- parseJSON v :: Aeson.Parser Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> fail "Pseudonym out auf range" - parseJSON (Aeson.String t) - = case t ^? _PseudonymText of - Just p -> return p - Nothing -> fail "Could not parse pseudonym" - parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do - ws' <- toList . map CI.mk <$> mapM parseJSON ws - case ws' ^? _PseudonymWords of - Just p -> return p - Nothing -> fail "Could not parse pseudonym words" - -instance ToJSON Pseudonym where - toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) - -pseudonymWordlist :: [PseudonymWord] -pseudonymCharacters :: Set (CI Char) -(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") - -_PseudonymWords :: Prism' [PseudonymWord] Pseudonym -_PseudonymWords = prism' pToWords pFromWords - where - pFromWords :: [PseudonymWord] -> Maybe Pseudonym - pFromWords [w1, w2] - | Just i1 <- elemIndex w1 pseudonymWordlist - , Just i2 <- elemIndex w2 pseudonymWordlist - , i1 <= maxWord, i2 <= maxWord - = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 - pFromWords _ = Nothing - - pToWords :: Pseudonym -> [PseudonymWord] - pToWords (Pseudonym p) - = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord - , genericIndex pseudonymWordlist $ p .&. maxWord - ] - - maxWord :: Num a => a - maxWord = 0b111111111111 - -_PseudonymText :: Prism' Text Pseudonym -_PseudonymText = prism' tToWords tFromWords . _PseudonymWords - where - tFromWords :: Text -> Maybe [PseudonymWord] - tFromWords input - | [result] <- input ^.. pseudonymFragments - = Just result - | otherwise - = Nothing - - tToWords :: [PseudonymWord] -> Text - tToWords = Text.unwords . map CI.original - -pseudonymWords :: Fold Text PseudonymWord -pseudonymWords = folding - $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist - where - distance = damerauLevenshtein `on` CI.foldedCase - -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 - distanceCutoff = 2 - -pseudonymFragments :: Fold Text [PseudonymWord] -pseudonymFragments = folding - $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) - - data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer = AuthAdmin | AuthLecturer @@ -313,7 +95,7 @@ instance ToJSON AuthTagActive where toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF instance FromJSON AuthTagActive where - parseJSON = withObject "AuthTagActive" $ \o -> do + parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) return . AuthTagActive $ \n -> case HashMap.lookup n o' of Nothing -> authTagIsActive def n @@ -359,53 +141,3 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag - - -data HealthReport = HealthReport - { healthMatchingClusterConfig :: Bool - -- ^ Is the database-stored configuration we're running under still up to date? - , healthHTTPReachable :: Maybe Bool - -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? - -- - -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings - , healthLDAPAdmins :: Maybe Rational - -- ^ Proportion of school admins that could be found in LDAP - -- - -- Is `Nothing` if LDAP is not configured or no users are school admins - , healthSMTPConnect :: Maybe Bool - -- ^ Can we connect to the SMTP server and say @NOOP@? - , healthWidgetMemcached :: Maybe Bool - -- ^ Can we store values in memcached and retrieve them via HTTP? - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , omitNothingFields = True - } ''HealthReport - --- | `HealthReport` classified (`classifyHealthReport`) by badness --- --- > a < b = a `worseThan` b --- --- Currently all consumers of this type check for @(== HealthSuccess)@; this --- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe HealthStatus -instance Finite HealthStatus - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''HealthStatus -nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 - -classifyHealthReport :: HealthReport -> HealthStatus --- ^ Classify `HealthReport` by badness -classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point - unless healthMatchingClusterConfig . tell $ Min HealthFailure - unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure - unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure - unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure - unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure - diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 426e375c5..74fb91dc1 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -1,62 +1,31 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +{-| +Module: Model.Types.Sheet +Description: Types for modeling sheets +-} -module Model.Types.Sheet where +module Model.Types.Sheet + ( module Model.Types.Sheet + ) where -import ClassyPrelude -import Utils -import Numeric.Natural +import Import.NoModel +import Model.Types.Common +import Utils.Lens.TH import Control.Lens -import Utils.Lens.TH -import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Data.Typeable (Typeable) -import Data.Universe -import Data.Universe.Helpers -import Data.Universe.Instances.Reverse () -import Data.NonNull.Instances () import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Fixed -import Data.Monoid (Sum(..)) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) -import Data.CaseInsensitive.Instances () import Text.Blaze (Markup) -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON import Yesod.Core.Dispatch (PathPiece(..)) -import Network.Mime +import Data.Maybe (fromJust) - ----- --- Sheet and Submission realted Model.Types - -type Count = Sum Integer -type Points = Centi - -toPoints :: Integral a => a -> Points -- deprecated -toPoints = fromIntegral - -pToI :: Points -> Integer -- deprecated -pToI = fromPoints - -fromPoints :: Integral a => Points -> a -- deprecated -fromPoints = round - -instance DisplayAble Points - -instance DisplayAble a => DisplayAble (Sum a) where - display (Sum x) = display x - data SheetGrading = Points { maxPoints :: Points } | PassPoints { maxPoints, passingPoints :: Points } @@ -179,7 +148,7 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) derivePersistField "SheetFileType" -instance Universe SheetFileType where universe = universeDef +instance Universe SheetFileType instance Finite SheetFileType instance PathPiece SheetFileType where @@ -208,22 +177,6 @@ sheetFile2markup SheetMarking = iconMarking partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs -data SubmissionFileType = SubmissionOriginal | SubmissionCorrected - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) - -instance Universe SubmissionFileType -instance Finite SubmissionFileType - -nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1 - -submissionFileTypeIsUpdate :: SubmissionFileType -> Bool -submissionFileTypeIsUpdate SubmissionOriginal = False -submissionFileTypeIsUpdate SubmissionCorrected = True - -isUpdateSubmissionFileType :: Bool -> SubmissionFileType -isUpdateSubmissionFileType False = SubmissionOriginal -isUpdateSubmissionFileType True = SubmissionCorrected - data UploadSpecificFile = UploadSpecificFile { specificFileLabel :: Text @@ -306,10 +259,6 @@ classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth -data ExamStatus = Attended | NoShow | Voided - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "ExamStatus" - -- | Specify a corrector's workload data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload @@ -340,3 +289,19 @@ instance Monoid Load where isByTutorial (ByTutorial {}) = True isByTutorial _ = False -} + +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState + +instance Universe CorrectorState +instance Finite CorrectorState + +instance Hashable CorrectorState + +nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) + +derivePersistField "CorrectorState" diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs new file mode 100644 index 000000000..c31fa38fc --- /dev/null +++ b/src/Model/Types/Submission.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| +Module: Model.Types.Submission +Description: Types to support sheet submissions +-} + +module Model.Types.Submission + ( module Model.Types.Submission + ) where + +import Import.NoModel + +import Data.Aeson.Types (ToJSON(..), FromJSON(..)) +import qualified Data.Aeson.Types as Aeson + +import Database.Persist.Sql + +import Data.Word.Word24 + +import qualified Data.CaseInsensitive as CI + +import Control.Lens + +import qualified Data.Text as Text +import qualified Data.Set as Set + + +import Data.List (elemIndex, genericIndex) +import Data.Bits +import Data.Text.Metrics (damerauLevenshtein) + +------------------------- +-- Submission Download -- +------------------------- + +data SubmissionFileType = SubmissionOriginal | SubmissionCorrected + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) + +instance Universe SubmissionFileType +instance Finite SubmissionFileType + +nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1 + +submissionFileTypeIsUpdate :: SubmissionFileType -> Bool +submissionFileTypeIsUpdate SubmissionOriginal = False +submissionFileTypeIsUpdate SubmissionCorrected = True + +isUpdateSubmissionFileType :: Bool -> SubmissionFileType +isUpdateSubmissionFileType False = SubmissionOriginal +isUpdateSubmissionFileType True = SubmissionCorrected + +--------------------------- +-- Submission Pseudonyms -- +--------------------------- + +type PseudonymWord = CI Text + +newtype Pseudonym = Pseudonym Word24 + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) + + +instance PersistField Pseudonym where + toPersistValue p = toPersistValue (fromIntegral p :: Word32) + fromPersistValue v = do + w <- fromPersistValue v :: Either Text Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> Left "Pseudonym out of range" + +instance PersistFieldSql Pseudonym where + sqlType _ = SqlInt32 + +instance Random Pseudonym where + randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen + random = randomR (minBound, maxBound) + +instance FromJSON Pseudonym where + parseJSON v@(Aeson.Number _) = do + w <- parseJSON v :: Aeson.Parser Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> fail "Pseudonym out auf range" + parseJSON (Aeson.String t) + = case t ^? _PseudonymText of + Just p -> return p + Nothing -> fail "Could not parse pseudonym" + parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do + ws' <- toList . map CI.mk <$> mapM parseJSON ws + case ws' ^? _PseudonymWords of + Just p -> return p + Nothing -> fail "Could not parse pseudonym words" + +instance ToJSON Pseudonym where + toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) + +pseudonymWordlist :: [PseudonymWord] +pseudonymCharacters :: Set (CI Char) +(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") + +_PseudonymWords :: Prism' [PseudonymWord] Pseudonym +_PseudonymWords = prism' pToWords pFromWords + where + pFromWords :: [PseudonymWord] -> Maybe Pseudonym + pFromWords [w1, w2] + | Just i1 <- elemIndex w1 pseudonymWordlist + , Just i2 <- elemIndex w2 pseudonymWordlist + , i1 <= maxWord, i2 <= maxWord + = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + pFromWords _ = Nothing + + pToWords :: Pseudonym -> [PseudonymWord] + pToWords (Pseudonym p) + = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord + , genericIndex pseudonymWordlist $ p .&. maxWord + ] + + maxWord :: Num a => a + maxWord = 0b111111111111 + +_PseudonymText :: Prism' Text Pseudonym +_PseudonymText = prism' tToWords tFromWords . _PseudonymWords + where + tFromWords :: Text -> Maybe [PseudonymWord] + tFromWords input + | [result] <- input ^.. pseudonymFragments + = Just result + | otherwise + = Nothing + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + +pseudonymWords :: Fold Text PseudonymWord +pseudonymWords = folding + $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist + where + distance = damerauLevenshtein `on` CI.foldedCase + -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 + distanceCutoff = 2 + +pseudonymFragments :: Fold Text [PseudonymWord] +pseudonymFragments = folding + $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/TH/JSON.hs similarity index 98% rename from src/Model/Types/JSON.hs rename to src/Model/Types/TH/JSON.hs index 66ed78163..34a752350 100644 --- a/src/Model/Types/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -1,4 +1,4 @@ -module Model.Types.JSON +module Model.Types.TH.JSON ( derivePersistFieldJSON , predNFAesonOptions ) where diff --git a/src/Model/Types/Wordlist.hs b/src/Model/Types/TH/Wordlist.hs similarity index 95% rename from src/Model/Types/Wordlist.hs rename to src/Model/Types/TH/Wordlist.hs index 5cfecd662..de3d159d8 100644 --- a/src/Model/Types/Wordlist.hs +++ b/src/Model/Types/TH/Wordlist.hs @@ -1,4 +1,6 @@ -module Model.Types.Wordlist (wordlist) where +module Model.Types.TH.Wordlist + ( wordlist + ) where import ClassyPrelude hiding (lift) diff --git a/src/Settings.hs b/src/Settings.hs index a60b4597b..c53e90269 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -10,14 +10,13 @@ module Settings , module Settings.Cluster ) where -import ClassyPrelude.Yesod +import Import.NoModel import Data.UUID (UUID) import qualified Control.Exception as Exception -import Data.Aeson (Result (..), fromJSON, withObject +import Data.Aeson (fromJSON, withObject ,(.!=), (.:?), withScientific ) import qualified Data.Aeson.Types as Aeson -import Data.Aeson.TH import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') import Database.Persist.Postgresql (PostgresConf) @@ -45,7 +44,6 @@ import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap -import Utils hiding (MessageStatus(..)) import Control.Lens import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) @@ -70,7 +68,6 @@ import Jose.Jwt (JwtEncoding(..)) import System.FilePath.Glob import Handler.Utils.Submission.TH -import Network.Mime import Network.Mime.TH import qualified Data.Map as Map @@ -118,9 +115,9 @@ data AppSettings = AppSettings , appJwtExpiration :: Maybe NominalDiffTime , appJwtEncoding :: JwtEncoding - , appHealthCheckInterval :: NominalDiffTime - , appHealthCheckHTTP :: Bool + , appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime , appHealthCheckDelayNotify :: Bool + , appHealthCheckHTTP :: Bool , appInitialLogSettings :: LogSettings @@ -389,9 +386,9 @@ instance FromJSON AppSettings where appJwtExpiration <- o .:? "jwt-expiration" appJwtEncoding <- o .: "jwt-encoding" - appHealthCheckInterval <- o .: "health-check-interval" - appHealthCheckHTTP <- o .: "health-check-http" + appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval" appHealthCheckDelayNotify <- o .: "health-check-delay-notify" + appHealthCheckHTTP <- o .: "health-check-http" appSessionTimeout <- o .: "session-timeout" @@ -483,5 +480,5 @@ configSettingsYmlValue = either Exception.throw id compileTimeAppSettings :: AppSettings compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of - Error e -> error e - Success settings -> settings + Aeson.Error e -> error e + Aeson.Success settings -> settings diff --git a/src/System/FilePath/Instances.hs b/src/System/FilePath/Instances.hs new file mode 100644 index 000000000..b37e2291a --- /dev/null +++ b/src/System/FilePath/Instances.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module System.FilePath.Instances + ( + ) where + +import ClassyPrelude + +import qualified Data.Text as Text + +import Web.PathPieces + + +instance {-# OVERLAPS #-} PathMultiPiece FilePath where + fromPathMultiPiece = Just . unpack . intercalate "/" + toPathMultiPiece = Text.splitOn "/" . pack diff --git a/src/Time/Types/Instances.hs b/src/Time/Types/Instances.hs index af91312e3..fa61bca45 100644 --- a/src/Time/Types/Instances.hs +++ b/src/Time/Types/Instances.hs @@ -12,8 +12,14 @@ import Data.Universe import Utils.PathPiece +import Data.Aeson.TH + instance Universe WeekDay instance Finite WeekDay nullaryPathPiece ''WeekDay camelToPathPiece + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + } ''WeekDay diff --git a/src/Utils.hs b/src/Utils.hs index 4f9d28a25..376817556 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult - module Utils ( module Utils ) where @@ -68,9 +66,10 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 -import Data.Fixed (Centi) +import Data.Fixed import Data.Ratio ((%)) +import Data.Binary (Binary) import qualified Data.Binary as Binary import Network.Wai (requestMethod) @@ -79,6 +78,8 @@ import Data.Time.Clock import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice) + {-# ANN choice ("HLint: ignore Use asum" :: String) #-} @@ -275,6 +276,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where instance DisplayAble a => DisplayAble (CI a) where display = display . CI.original +instance HasResolution a => DisplayAble (Fixed a) where + display = pack . showFixed True + +instance DisplayAble a => DisplayAble (Sum a) where + display = display . getSum + {- We do not want DisplayAble for every Show-Class: We want to explicitly verify that the resulting text can be displayed to the User! For example: UTCTime values were shown without proper format rendering! @@ -908,10 +915,18 @@ encodedSecretBoxOpen ciphertext = do -- Caching -- ------------- +cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b +cachedByBinary k = cachedBy (toStrict $ Binary.encode k) + cachedHere :: Q Exp cachedHere = do loc <- location - [e| cachedBy (toStrict $ Binary.encode loc) |] + [e| cachedByBinary loc |] + +cachedHereBinary :: Q Exp +cachedHereBinary = do + loc <- location + [e| \k -> cachedByBinary (loc, k) |] hashToText :: Hashable a => a -> Text hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash @@ -936,3 +951,13 @@ setLastModified lastModified = do precision = 1 safeMethods = [ methodGet, methodHead, methodOptions ] + +-------------- +-- Lattices -- +-------------- + +foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono +foldJoin = foldr (\/) bottom + +foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono +foldMeet = foldr (/\) top diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 0b5855566..3f66c65ee 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Utils.DateTime ( timeLocaleMap @@ -14,10 +13,9 @@ module Utils.DateTime import ClassyPrelude.Yesod hiding (lift) import System.Locale.Read -import Data.Time (TimeZone(..), TimeLocale(..)) +import Data.Time (TimeLocale(..)) import Data.Time.Zones (TZ) import Data.Time.Zones.TH (includeSystemTZ) -import Data.Time.Clock.POSIX import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) @@ -35,11 +33,8 @@ import Data.Aeson.TH import Utils.PathPiece -deriving instance Lift TimeZone -deriving instance Lift TimeLocale - -instance Hashable UTCTime where - hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds +import Data.Time.Format.Instances () + -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default @@ -91,7 +86,7 @@ instance Finite SelDateTimeFormat instance Hashable SelDateTimeFormat deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + { constructorTagModifier = camelToPathPiece' 2 } ''SelDateTimeFormat instance ToJSONKey SelDateTimeFormat where diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index c7434b54f..2d9b8b860 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -5,6 +5,7 @@ module Utils.PathPiece , splitCamel , camelToPathPiece, camelToPathPiece' , tuplePathPiece + , pathPieceJSONKey ) where import ClassyPrelude.Yesod @@ -22,6 +23,8 @@ import qualified Data.Map as Map import Numeric.Natural import Data.List (foldl) + +import Data.Aeson.Types finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a @@ -109,3 +112,13 @@ tuplePathPiece tupleDim = do ]) [] ] ] + + +pathPieceJSONKey :: Name -> DecsQ +-- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance +pathPieceJSONKey tName + = [d| instance ToJSONKey $(conT tName) where + toJSONKey = toJSONKeyText toPathPiece + instance FromJSONKey $(conT tName) where + fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t + |] diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 5402ce3ba..2f03d0e94 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -2,7 +2,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-} module Yesod.Core.Types.Instances - ( CachedMemoT(..) + ( CachedMemoT + , runCachedMemoT ) where import ClassyPrelude.Yesod @@ -13,9 +14,15 @@ import Control.Monad.Fix import Control.Monad.Memo import Data.Binary (Binary) -import qualified Data.Binary as Binary import Control.Monad.Logger (MonadLoggerIO) + +import Utils + +import Language.Haskell.TH + +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT) instance MonadFix m => MonadFix (HandlerT site m) where @@ -26,23 +33,31 @@ instance MonadFix m => MonadFix (WidgetT site m) where -- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo` -newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a } +newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a } deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix , MonadIO , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO , MonadResource, MonadHandler, MonadWidget - , IsString, Semigroup, Monoid ) deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m) deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m) -deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m) +instance MonadReader r m => MonadReader r (CachedMemoT k v m) where + reader = CachedMemoT . lift . reader + local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act instance MonadTrans (CachedMemoT k v) where - lift = CachedMemoT + lift = CachedMemoT . lift -- | Uses `cachedBy` with a `Binary`-encoded @k@ instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where - memo act key = cachedBy (toStrict $ Binary.encode key) $ act key + memo act key = do + loc <- CachedMemoT ask + cachedByBinary (loc, key) $ act key + +runCachedMemoT :: Q Exp +runCachedMemoT = do + loc <- location + [e| flip runReaderT loc . runCachedMemoT' |] diff --git a/templates/material-show.hamlet b/templates/material-show.hamlet index c3e00bc22..e31b5c9c0 100644 --- a/templates/material-show.hamlet +++ b/templates/material-show.hamlet @@ -10,11 +10,11 @@ $maybe descr <- materialDescription $maybe matKind <- materialType
_{MsgMaterialType}
#{matKind} - $maybe matVisible <- materialVisibleFrom + $maybe matVisibleFromWgt <- matVisibleFromMB
_{MsgVisibleFrom} -
#{matVisible} +
^{matVisibleFromWgt}
_{MsgFileModified} -
#{materialLastEdit} +
^{matLastEdit} $if hasFiles
diff --git a/test/MailSpec.hs b/test/MailSpec.hs index c9972548d..ad54385c6 100644 --- a/test/MailSpec.hs +++ b/test/MailSpec.hs @@ -27,7 +27,7 @@ spec = do lawsCheckHspec (Proxy @MailSmtpData) [ eqLaws, ordLaws, showReadLaws, monoidLaws ] lawsCheckHspec (Proxy @MailLanguages) - [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ] + [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws, persistFieldLaws ] lawsCheckHspec (Proxy @MailContext) [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ] lawsCheckHspec (Proxy @VerpMode) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index ad74f5831..3805809db 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -267,8 +267,6 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ] lawsCheckHspec (Proxy @NotificationSettings) [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] - lawsCheckHspec (Proxy @MailLanguages) - [ persistFieldLaws ] lawsCheckHspec (Proxy @Pseudonym) [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @AuthTag) diff --git a/test/TestImport.hs b/test/TestImport.hs index a9c5cd88d..4fb09576b 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -32,6 +32,7 @@ import Data.Proxy as X import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr) import Jobs (handleJobs, stopJobCtl) +import Numeric.Natural as X import Control.Lens as X hiding ((<.), elements) diff --git a/test/Utils/DateTimeSpec.hs b/test/Utils/DateTimeSpec.hs index b2480749d..2e0d086eb 100644 --- a/test/Utils/DateTimeSpec.hs +++ b/test/Utils/DateTimeSpec.hs @@ -2,6 +2,9 @@ module Utils.DateTimeSpec where import TestImport +import Utils.DateTime + + instance Arbitrary DateTimeFormat where arbitrary = DateTimeFormat <$> arbitrary shrink = genericShrink