Merge branch 'master' into utility-refactoring
This commit is contained in:
Felix Hamann
commit
59251bc570
10
.vscode/tasks.json
vendored
10
.vscode/tasks.json
vendored
@ -43,6 +43,16 @@
|
||||
"panel": "dedicated",
|
||||
"showReuseMessage": false
|
||||
}
|
||||
},
|
||||
{
|
||||
"type": "npm",
|
||||
"script": "yesod:lint",
|
||||
"problemMatcher": []
|
||||
},
|
||||
{
|
||||
"type": "npm",
|
||||
"script": "yesod:start",
|
||||
"problemMatcher": []
|
||||
}
|
||||
]
|
||||
}
|
||||
@ -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"
|
||||
|
||||
@ -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', () => {
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -126,6 +126,7 @@ dependencies:
|
||||
- streaming-commons
|
||||
- hourglass
|
||||
- unix
|
||||
- stm-delay
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module CryptoID
|
||||
|
||||
@ -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)
|
||||
|]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
18
src/Data/Time/Calendar/Instances.hs
Normal file
18
src/Data/Time/Calendar/Instances.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
14
src/Data/Time/Format/Instances.hs
Normal file
14
src/Data/Time/Format/Instances.hs
Normal file
@ -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
|
||||
23
src/Data/Time/LocalTime/Instances.hs
Normal file
23
src/Data/Time/LocalTime/Instances.hs
Normal file
@ -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
|
||||
27
src/Data/UUID/Instances.hs
Normal file
27
src/Data/UUID/Instances.hs
Normal file
@ -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"
|
||||
17
src/Data/Universe/Instances/Reverse/MonoTraversable.hs
Normal file
17
src/Data/Universe/Instances/Reverse/MonoTraversable.hs
Normal file
@ -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)
|
||||
|
||||
23
src/Database/Persist/Class/Instances.hs
Normal file
23
src/Database/Persist/Class/Instances.hs
Normal file
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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'
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
|
||||
<dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
|
||||
$maybe httpReachable <- healthHTTPReachable
|
||||
<dt .deflist__dt>_{MsgHealthHTTPReachable}
|
||||
<dd .deflist__dd>#{boolSymbol httpReachable}
|
||||
$maybe ldapAdmins <- healthLDAPAdmins
|
||||
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
|
||||
<dd .deflist__dd>#{textPercent ldapAdmins}
|
||||
$maybe smtpConnect <- healthSMTPConnect
|
||||
<dt .deflist__dt>_{MsgHealthSMTPConnect}
|
||||
<dd .deflist__dd>#{boolSymbol smtpConnect}
|
||||
$maybe widgetMemcached <- healthWidgetMemcached
|
||||
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
|
||||
<dd .deflist__dd>#{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
|
||||
<dl .deflist>
|
||||
$forall (_, report) <- healthReports'
|
||||
$case report
|
||||
$of HealthMatchingClusterConfig passed
|
||||
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of HealthHTTPReachable (Just passed)
|
||||
<dt .deflist__dt>_{MsgHealthHTTPReachable}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of HealthLDAPAdmins (Just found)
|
||||
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
|
||||
<dd .deflist__dd>#{textPercent found}
|
||||
$of HealthSMTPConnect (Just passed)
|
||||
<dt .deflist__dt>_{MsgHealthSMTPConnect}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of HealthWidgetMemcached (Just passed)
|
||||
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of _
|
||||
|]
|
||||
provideJson healthReports
|
||||
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
|
||||
|
||||
getInstanceR :: Handler TypedContent
|
||||
getInstanceR = do
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|<a href=@{url}>^{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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
105
src/Import/NoModel.hs
Normal file
105
src/Import/NoModel.hs
Normal file
@ -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
|
||||
150
src/Jobs.hs
150
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
35
src/Model/Types/Common.hs
Normal file
35
src/Model/Types/Common.hs
Normal file
@ -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
|
||||
26
src/Model/Types/Course.hs
Normal file
26
src/Model/Types/Course.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
|
||||
16
src/Model/Types/Exam.hs
Normal file
16
src/Model/Types/Exam.hs
Normal file
@ -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"
|
||||
87
src/Model/Types/Health.hs
Normal file
87
src/Model/Types/Health.hs
Normal file
@ -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
|
||||
75
src/Model/Types/Mail.hs
Normal file
75
src/Model/Types/Mail.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
151
src/Model/Types/Submission.hs
Normal file
151
src/Model/Types/Submission.hs
Normal file
@ -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)
|
||||
@ -1,4 +1,4 @@
|
||||
module Model.Types.JSON
|
||||
module Model.Types.TH.JSON
|
||||
( derivePersistFieldJSON
|
||||
, predNFAesonOptions
|
||||
) where
|
||||
@ -1,4 +1,6 @@
|
||||
module Model.Types.Wordlist (wordlist) where
|
||||
module Model.Types.TH.Wordlist
|
||||
( wordlist
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (lift)
|
||||
|
||||
@ -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
|
||||
|
||||
16
src/System/FilePath/Instances.hs
Normal file
16
src/System/FilePath/Instances.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
33
src/Utils.hs
33
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|]
|
||||
|
||||
@ -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' |]
|
||||
|
||||
@ -10,11 +10,11 @@ $maybe descr <- materialDescription
|
||||
$maybe matKind <- materialType
|
||||
<dt .deflist__dt>_{MsgMaterialType}
|
||||
<dd .deflist__dd>#{matKind}
|
||||
$maybe matVisible <- materialVisibleFrom
|
||||
$maybe matVisibleFromWgt <- matVisibleFromMB
|
||||
<dt .deflist__dt>_{MsgVisibleFrom}
|
||||
<dd .deflist__dd>#{matVisible}
|
||||
<dd .deflist__dd>^{matVisibleFromWgt}
|
||||
<dt .deflist__dt>_{MsgFileModified}
|
||||
<dd .deflist__dd>#{materialLastEdit}
|
||||
<dd .deflist__dd>^{matLastEdit}
|
||||
|
||||
$if hasFiles
|
||||
<section>
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -2,6 +2,9 @@ module Utils.DateTimeSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Utils.DateTime
|
||||
|
||||
|
||||
instance Arbitrary DateTimeFormat where
|
||||
arbitrary = DateTimeFormat <$> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
Loading…
Reference in New Issue
Block a user