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/form.js b/frontend/src/utils/form/form.js index c3432dcc6..300603c53 100644 --- a/frontend/src/utils/form/form.js +++ b/frontend/src/utils/form/form.js @@ -254,6 +254,7 @@ export const interactiveFieldset = { * * 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) @@ -261,6 +262,7 @@ export const interactiveFieldset = { var NAVIGATE_AWAY_PROMPT_UTIL_NAME = 'navigateAwayPrompt'; var NAVIGATE_AWAY_PROMPT_UTIL_SELECTOR = 'form'; +var NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT = '[uw-no-navigate-away-prompt]'; var NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS = 'navigate-away-prompt--initialized'; @@ -282,6 +284,10 @@ var navigateAwayPromptUtil = function(element) { return false; } + if (element.matches(NAVIGATE_AWAY_PROMPT_UTIL_OPTOUT)) { + return false; + } + window.addEventListener('beforeunload', beforeUnloadHandler); element.addEventListener('submit', function() { 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..bf7927e51 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, @@ -75,17 +75,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 +157,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 @@ -333,7 +338,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 +364,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 +416,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/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..a4fc86fb5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 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/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/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index e9121be5f..dab7f1d51 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 @@ -20,8 +20,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) 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/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 15a2952f5..063b06fd6 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(..) 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..639eca131 --- /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 (CachedMemoT(..)) + +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..5ba9f1fa4 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -32,6 +32,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 +52,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 @@ -284,21 +283,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..2080947ec 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,7 +66,7 @@ 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 qualified Data.Binary as Binary @@ -79,6 +77,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 +275,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! @@ -936,3 +942,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/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