refactor: hlint
This commit is contained in:
Gregor Kleen
parent
7512420131
commit
0fcb65f9fa
@ -94,11 +94,11 @@ import Handler.Utils.Routes (classifyHandler)
|
||||
|
||||
import qualified Data.Acid.Memory as Acid
|
||||
import qualified Web.ServerSession.Backend.Acid as Acid
|
||||
|
||||
|
||||
import qualified Ldap.Client as Ldap (Host(Plain, Tls))
|
||||
|
||||
import qualified Network.Minio as Minio
|
||||
|
||||
|
||||
import Web.ServerSession.Core (StorageException(..))
|
||||
|
||||
import GHC.RTS.Flags (getRTSFlags)
|
||||
@ -142,7 +142,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
|
||||
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX
|
||||
makeFoundation appSettings'@AppSettings{..} = do
|
||||
registerGHCMetrics
|
||||
|
||||
|
||||
-- Some basic initializations: HTTP connection manager, logger, and static
|
||||
-- subsite.
|
||||
appHttpManager <- newManager
|
||||
@ -356,7 +356,7 @@ makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlai
|
||||
makeMiddleware :: MonadIO m => UniWorX -> m Middleware
|
||||
makeMiddleware app = do
|
||||
logWare <- makeLogWare
|
||||
return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging
|
||||
return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging
|
||||
where
|
||||
makeLogWare = do
|
||||
logWareMap <- liftIO $ newTVarIO HashMap.empty
|
||||
@ -391,7 +391,7 @@ makeMiddleware app = do
|
||||
respond $ Wai.mapResponseHeaders (const resHdrs') res
|
||||
where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
|
||||
parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
|
||||
|
||||
|
||||
go [] = return []
|
||||
go (hdr@(hdrName, hdrValue) : hdrs)
|
||||
| hdrName == hSetCookie = do
|
||||
@ -458,7 +458,7 @@ warpSettings foundation = defaultSettings
|
||||
Just (SessionDoesNotExist{} :: StorageException (AcidStorage SessionMap)) -> False
|
||||
_other -> True
|
||||
]
|
||||
|
||||
|
||||
|
||||
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
|
||||
getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
|
||||
@ -479,7 +479,7 @@ develMain = runResourceT $ do
|
||||
lift $ threadDelay 100e3
|
||||
whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $
|
||||
callCC ($ ())
|
||||
|
||||
|
||||
void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing
|
||||
runAppLoggingT foundation $ handleJobs foundation
|
||||
void . liftIO $ awaitTermination `race` runSettings wsettings app
|
||||
|
||||
@ -54,7 +54,7 @@ getRemote = handle testHandler $ do
|
||||
guard $ h `elem` ["x-real-ip", "x-forwarded-for"]
|
||||
v' <- either (const mzero) return $ Text.decodeUtf8' v
|
||||
maybeToList $ IP.decode v'
|
||||
|
||||
|
||||
byRemoteHost wai = case Wai.remoteHost wai of
|
||||
Wai.SockAddrInet _ hAddr
|
||||
-> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr
|
||||
|
||||
@ -23,7 +23,7 @@ data Transaction
|
||||
{ transactionExam :: ExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
|
||||
|
||||
| TransactionExamPartResultEdit
|
||||
{ transactionExamPart :: ExamPartId
|
||||
, transactionUser :: UserId
|
||||
@ -88,7 +88,7 @@ data Transaction
|
||||
{ transactionSubmission :: SubmissionId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
|
||||
|
||||
| TransactionSubmissionFileEdit
|
||||
{ transactionSubmissionFile :: SubmissionFileId
|
||||
, transactionSubmission :: SubmissionId
|
||||
@ -133,7 +133,7 @@ data Transaction
|
||||
{ transactionExternalExam :: ExternalExamId
|
||||
, transactionSchool :: SchoolId
|
||||
}
|
||||
|
||||
|
||||
| TransactionExternalExamStaffEdit
|
||||
{ transactionExternalExam :: ExternalExamId
|
||||
, transactionUser :: UserId
|
||||
|
||||
@ -45,7 +45,7 @@ dummyLogin = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
apName = "dummy"
|
||||
|
||||
|
||||
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
||||
apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
|
||||
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard dummyForm
|
||||
@ -62,7 +62,7 @@ dummyLogin = AuthPlugin{..}
|
||||
setCredsRedirect $ Creds apName (CI.original ident) []
|
||||
apDispatch _ [] = badMethod
|
||||
apDispatch _ _ = notFound
|
||||
|
||||
|
||||
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard dummyForm
|
||||
|
||||
@ -52,7 +52,7 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
|
||||
[ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||
, ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident
|
||||
]
|
||||
|
||||
|
||||
findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
||||
where
|
||||
@ -76,8 +76,8 @@ ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||
ldapSex = Ldap.Attr "schacGender"
|
||||
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
||||
|
||||
@ -145,7 +145,7 @@ campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
|
||||
|
||||
campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' pool mode
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
|
||||
@ -177,7 +177,7 @@ campusLogin pool mode = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
apName = apLdap
|
||||
|
||||
|
||||
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
||||
apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
|
||||
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
|
||||
|
||||
@ -16,7 +16,7 @@ instance MonadResource m => MonadResource (StateCache c m) where
|
||||
|
||||
instance MonadLogger m => MonadLogger (StateCache c m)
|
||||
instance MonadLoggerIO m => MonadLoggerIO (StateCache c m)
|
||||
|
||||
|
||||
instance MonadHandler m => MonadHandler (StateCache c m) where
|
||||
type HandlerSite (StateCache c m) = HandlerSite m
|
||||
type SubHandlerSite (StateCache c m) = SubHandlerSite m
|
||||
|
||||
@ -21,7 +21,7 @@ import qualified Data.Set as Set
|
||||
|
||||
import Utils.Lens hiding (from, to)
|
||||
|
||||
|
||||
|
||||
data CronDate = CronDate
|
||||
{ cdYear, cdWeekYear, cdWeekOfYear, cdDayOfYear
|
||||
, cdMonth, cdWeekOfMonth, cdDayOfMonth
|
||||
@ -101,7 +101,7 @@ instance Alternative CronNextMatch where
|
||||
_ <|> MatchAsap = MatchAsap
|
||||
MatchAsap <|> _ = MatchAsap
|
||||
(MatchAt a) <|> (MatchAt _) = MatchAt a
|
||||
|
||||
|
||||
|
||||
listToMatch :: [a] -> CronNextMatch a
|
||||
listToMatch [] = MatchNone
|
||||
@ -203,7 +203,7 @@ nextCronMatch tz mPrev prec now c@Cron{..} = onlyOnceWithinPrec $ case notAfter
|
||||
in case execRef now False cronInitial of
|
||||
MatchAsap
|
||||
| now < cutoffTime -> MatchAt cutoffTime
|
||||
MatchAt ts
|
||||
MatchAt ts
|
||||
| ts < cutoffTime -> MatchAt cutoffTime
|
||||
other -> other
|
||||
CronRepeatScheduled cronNext
|
||||
|
||||
@ -11,12 +11,12 @@ import ClassyPrelude
|
||||
|
||||
import Utils.Lens.TH
|
||||
|
||||
import Data.Time
|
||||
import Data.Time
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
|
||||
data CronMatch
|
||||
= CronMatchAny
|
||||
|
||||
@ -26,7 +26,7 @@ instance HashAlgorithm hash => PersistField (Digest hash) where
|
||||
fromPersistValue _ = Left "Digest values must be converted from PersistByteString or PersistText"
|
||||
|
||||
instance HashAlgorithm hash => PersistFieldSql (Digest hash) where
|
||||
sqlType _ = SqlBlob
|
||||
sqlType _ = SqlBlob
|
||||
|
||||
instance HashAlgorithm hash => PathPiece (Digest hash) where
|
||||
toPathPiece = showToPathPiece
|
||||
|
||||
@ -38,7 +38,7 @@ encrypt :: forall plaintext ciphertext m.
|
||||
, Typeable ciphertext
|
||||
, PathPiece plaintext
|
||||
)
|
||||
=> plaintext -> m (I.CryptoID ciphertext plaintext)
|
||||
=> plaintext -> m (I.CryptoID ciphertext plaintext)
|
||||
encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain
|
||||
|
||||
decrypt :: forall plaintext ciphertext m.
|
||||
@ -47,7 +47,7 @@ decrypt :: forall plaintext ciphertext m.
|
||||
, Typeable plaintext
|
||||
, PathPiece ciphertext
|
||||
)
|
||||
=> I.CryptoID ciphertext plaintext -> m plaintext
|
||||
=> I.CryptoID ciphertext plaintext -> m plaintext
|
||||
decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher
|
||||
|
||||
|
||||
|
||||
@ -38,7 +38,7 @@ instance PersistField (CI String) where
|
||||
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
|
||||
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
|
||||
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
|
||||
|
||||
|
||||
instance PersistFieldSql (CI Text) where
|
||||
sqlType _ = SqlOther "citext"
|
||||
|
||||
|
||||
@ -16,7 +16,7 @@ import Data.Proxy (Proxy(..))
|
||||
|
||||
import Data.Scientific
|
||||
import Data.Scientific.Instances ()
|
||||
|
||||
|
||||
|
||||
instance HasResolution a => ToMarkup (Fixed a) where
|
||||
toMarkup = toMarkup . showFixed True
|
||||
|
||||
@ -10,4 +10,4 @@ import Text.Blaze (ToMarkup(..), string)
|
||||
|
||||
instance ToMarkup a => ToMarkup (Maybe a) where
|
||||
toMarkup Nothing = string ""
|
||||
toMarkup (Just x) = toMarkup x
|
||||
toMarkup (Just x) = toMarkup x
|
||||
|
||||
@ -19,7 +19,7 @@ instance MonoFunctor All where
|
||||
|
||||
instance MonoPointed Any where
|
||||
opoint = Any
|
||||
|
||||
|
||||
instance MonoPointed All where
|
||||
opoint = All
|
||||
|
||||
|
||||
@ -11,5 +11,5 @@ import Web.PathPieces
|
||||
|
||||
|
||||
instance PathPiece Scientific where
|
||||
toPathPiece = pack . formatScientific Fixed Nothing
|
||||
toPathPiece = pack . formatScientific Fixed Nothing
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
@ -10,4 +10,4 @@ import Data.Monoid (Sum(..))
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
|
||||
instance ToMarkup a => ToMarkup (Sum a) where
|
||||
toMarkup = toMarkup . getSum
|
||||
toMarkup = toMarkup . getSum
|
||||
|
||||
@ -10,7 +10,7 @@ import qualified Data.UUID as UUID
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = UUID.fromString . unpack
|
||||
|
||||
@ -7,11 +7,11 @@ module Data.Universe.Instances.Reverse.MonoTraversable
|
||||
import Data.Universe
|
||||
import Data.MonoTraversable
|
||||
|
||||
import Data.Universe.Instances.Reverse
|
||||
|
||||
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,7 +23,7 @@ import Data.List (elemIndex)
|
||||
getTVBName :: TyVarBndr -> Name
|
||||
getTVBName (PlainTV name ) = name
|
||||
getTVBName (KindedTV name _) = name
|
||||
|
||||
|
||||
|
||||
|
||||
finiteEnum :: Name -> DecsQ
|
||||
@ -33,7 +33,7 @@ finiteEnum tName = do
|
||||
|
||||
let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars
|
||||
tUniverse = [e|universeF :: [$(datatype)]|]
|
||||
|
||||
|
||||
[d|
|
||||
instance Bounded $(datatype) where
|
||||
minBound = head $(tUniverse)
|
||||
|
||||
@ -189,7 +189,7 @@ orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Va
|
||||
orderByList vals
|
||||
= let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
|
||||
in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)
|
||||
|
||||
|
||||
orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
||||
orderByOrd = orderByList $ List.sort universeF
|
||||
|
||||
@ -199,12 +199,12 @@ orderByEnum = orderByList $ List.sortOn fromEnum universeF
|
||||
|
||||
lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
|
||||
lower = E.unsafeSqlFunction "LOWER"
|
||||
|
||||
|
||||
strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
|
||||
strip = E.unsafeSqlFunction "TRIM"
|
||||
|
||||
infix 4 `ciEq`
|
||||
|
||||
|
||||
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
ciEq a b = lower a E.==. lower b
|
||||
|
||||
@ -242,7 +242,7 @@ maybe onNothing onJust val = E.case_
|
||||
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
|
||||
]
|
||||
(E.else_ onNothing)
|
||||
|
||||
|
||||
infix 4 `maybeEq`
|
||||
|
||||
maybeEq :: PersistField a
|
||||
|
||||
@ -46,7 +46,7 @@ sqlInTuple arity = do
|
||||
xsV <- newName "xs"
|
||||
|
||||
let
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs)
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
|
||||
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
||||
|
||||
instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
||||
|
||||
@ -18,13 +18,13 @@ import qualified System.Directory.Tree as DirTree
|
||||
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
|
||||
|
||||
import Control.Lens
|
||||
|
||||
|
||||
|
||||
persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
|
||||
persistDirectoryWith settings dir = do
|
||||
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
|
||||
fn <- MaybeT . return . fromNullable $ takeFileName fp
|
||||
guard . not $ head fn == '.'
|
||||
guard $ head fn /= '.'
|
||||
guard . not $ head fn == '#' && last fn == '#'
|
||||
|
||||
lift $ do
|
||||
@ -32,5 +32,5 @@ persistDirectoryWith settings dir = do
|
||||
SIO.hSetEncoding h SIO.utf8_bom
|
||||
Text.hGetContents h
|
||||
mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files
|
||||
|
||||
|
||||
parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files
|
||||
|
||||
@ -15,7 +15,8 @@ import Foundation.Routes as Foundation
|
||||
|
||||
|
||||
import Import.NoFoundation hiding (embedFile)
|
||||
import Database.Persist.Sql (runSqlPool)
|
||||
import Database.Persist.Sql
|
||||
( runSqlPool, transactionUndo, SqlReadBackend(..) )
|
||||
import Text.Hamlet (hamletFile)
|
||||
|
||||
import Yesod.Auth.Message
|
||||
@ -105,7 +106,6 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
||||
import Web.Cookie
|
||||
|
||||
import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild))
|
||||
import Database.Persist.Sql (transactionUndo, SqlReadBackend(..))
|
||||
|
||||
import qualified Control.Retry as Retry
|
||||
import GHC.IO.Exception (IOErrorType(OtherError))
|
||||
@ -196,7 +196,7 @@ data Nav
|
||||
|
||||
makeLenses_ ''Nav
|
||||
makePrisms ''Nav
|
||||
|
||||
|
||||
data NavChildren
|
||||
type instance Children NavChildren a = ChildrenNavChildren a
|
||||
type family ChildrenNavChildren a where
|
||||
@ -217,13 +217,13 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
|
||||
where
|
||||
shortCircuit :: HandlerContents -> m Bool
|
||||
shortCircuit _ = return False
|
||||
|
||||
|
||||
accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
|
||||
accessCheck nt (urlRoute -> route) = do
|
||||
authCtx <- getAuthContext
|
||||
$memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
|
||||
bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
|
||||
|
||||
|
||||
|
||||
getTimeLocale' :: [Lang] -> TimeLocale
|
||||
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
|
||||
@ -244,7 +244,7 @@ appLanguagesOpts = do
|
||||
}
|
||||
langOptions = map mkOption $ toList appLanguages
|
||||
return $ mkOptionList langOptions
|
||||
|
||||
|
||||
instance RenderMessage UniWorX WeekDay where
|
||||
renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
|
||||
|
||||
@ -419,7 +419,7 @@ requireCurrentBearerRestrictions = runMaybeT $ do
|
||||
bearer <- requireBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
||||
|
||||
|
||||
maybeCurrentBearerRestrictions :: forall a m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -450,7 +450,7 @@ isDryRun = $cachedHere $ orM
|
||||
mAuthId <- maybeAuthId
|
||||
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
||||
isWrite <- isWriteRequest currentRoute
|
||||
|
||||
|
||||
let noTokenAuth :: AuthDNF -> AuthDNF
|
||||
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
||||
|
||||
@ -528,7 +528,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
||||
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
||||
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
||||
|
||||
|
||||
E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
|
||||
guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
|
||||
return Authorized
|
||||
@ -635,7 +635,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
|
||||
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
|
||||
guard $ Just authId == submissionRatingBy
|
||||
return Authorized
|
||||
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -715,7 +715,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
|
||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
|
||||
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
@ -742,7 +742,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
-> guard $ visible
|
||||
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
||||
ERegisterOccR occn -> do
|
||||
occId <- (>>= hoistMaybe) . $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
||||
occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
||||
if
|
||||
| (registration >>= examRegistrationOccurrence . entityVal) == Just occId
|
||||
-> guard $ visible
|
||||
@ -850,7 +850,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
guard $ NTop (Just now) <= NTop deregUntil
|
||||
return Authorized
|
||||
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
||||
|
||||
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||
@ -879,7 +879,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= cTime
|
||||
&& NTop systemMessageTo >= cTime
|
||||
return Authorized
|
||||
@ -887,7 +887,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= cTime
|
||||
&& NTop systemMessageTo >= cTime
|
||||
return Authorized
|
||||
@ -895,7 +895,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
|
||||
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
guard $ NTop courseNewsVisibleFrom <= cTime
|
||||
return Authorized
|
||||
|
||||
@ -1195,7 +1195,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
when onlyActive $
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
-- participant has at least one submission
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($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
|
||||
@ -1205,7 +1205,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId 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
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($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
|
||||
@ -1222,7 +1222,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId 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
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($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
|
||||
@ -1254,7 +1254,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant has an exam result for this course
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
|
||||
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
@ -1263,7 +1263,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is registered for an exam for this course
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
@ -1271,21 +1271,19 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
|
||||
return ()
|
||||
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
|
||||
uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
isApplicant <- isCourseApplicant tid ssh csh uid
|
||||
guard isApplicant
|
||||
return Authorized
|
||||
|
||||
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
isApplicant <- isCourseApplicant tid ssh csh uid
|
||||
guard isApplicant
|
||||
return Authorized
|
||||
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthApplicant r
|
||||
where
|
||||
isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
@ -1628,10 +1626,10 @@ instance Yesod UniWorX where
|
||||
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
@ -1664,7 +1662,7 @@ instance Yesod UniWorX where
|
||||
notForBearer' (SessionBackend load)
|
||||
= let load' req
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just) $ map W.extractBearerAuth aHdrs
|
||||
, any (is _Just . W.extractBearerAuth) aHdrs
|
||||
= return (mempty, const $ return [])
|
||||
| otherwise
|
||||
= load req
|
||||
@ -1686,7 +1684,7 @@ instance Yesod UniWorX where
|
||||
dryRun <- isDryRun
|
||||
if | dryRun -> do
|
||||
hData <- ask
|
||||
prevState <- readIORef (handlerState hData)
|
||||
prevState <- readIORef (handlerState hData)
|
||||
let
|
||||
restoreSession =
|
||||
modifyIORef (handlerState hData) $
|
||||
@ -1698,7 +1696,7 @@ instance Yesod UniWorX where
|
||||
handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
|
||||
|
||||
addCustomHeader HeaderDryRun ("1" :: Text)
|
||||
|
||||
|
||||
handler' `finally` restoreSession
|
||||
| otherwise -> handler
|
||||
updateFavouritesMiddleware :: Handler a -> Handler a
|
||||
@ -1893,7 +1891,7 @@ updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
updateFavourites cData = void . runMaybeT $ do
|
||||
$logDebugS "updateFavourites" "Updating favourites"
|
||||
|
||||
now <- liftIO $ getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- MaybeT $ liftHandler maybeAuthId
|
||||
mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
User{userMaxFavourites} <- MaybeT $ get uid
|
||||
@ -2004,7 +2002,7 @@ siteLayout' headingOverride widget = do
|
||||
[ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent
|
||||
, E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
|
||||
] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
|
||||
|
||||
|
||||
E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
|
||||
|
||||
return (course, reason)
|
||||
@ -2016,7 +2014,7 @@ siteLayout' headingOverride widget = do
|
||||
|
||||
let favouriteTerms :: [TermIdentifier]
|
||||
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _) -> Set.singleton $ unTermKey courseTerm) favourites'
|
||||
|
||||
|
||||
favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite)
|
||||
-> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
favouriteReason = fromMaybe FavouriteCurrent mFavourite
|
||||
@ -2028,7 +2026,7 @@ siteLayout' headingOverride widget = do
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
|
||||
items <- memcachedLimitedKeyTimeoutBy
|
||||
MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
|
||||
(Right <$> appFavouritesQuickActionsCacheTTL)
|
||||
(Right <$> appFavouritesQuickActionsCacheTTL)
|
||||
appFavouritesQuickActionsTimeout
|
||||
cK
|
||||
cK
|
||||
@ -2241,7 +2239,7 @@ getSystemMessageState smId = liftHandler $ do
|
||||
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
|
||||
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
|
||||
lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
|
||||
|
||||
|
||||
cRoute <- lift getCurrentRoute
|
||||
guard $ cRoute /= Just NewsR
|
||||
|
||||
@ -2258,14 +2256,14 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
|
||||
, systemMessageHiddenTime
|
||||
}
|
||||
[ SystemMessageHiddenTime =. systemMessageHiddenTime ]
|
||||
|
||||
|
||||
when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
|
||||
deleteBy $ UniqueSystemMessageHidden uid smId
|
||||
|
||||
modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
|
||||
-> fmap MergeHashMap . assertM' (/= mempty) $
|
||||
HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
|
||||
|
||||
|
||||
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
|
||||
guard $ not systemMessageNewsOnly
|
||||
|
||||
@ -2325,7 +2323,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
User{..} <- MaybeT . runDB $ get uid
|
||||
return (userDisplayName, Just UsersR)
|
||||
breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
|
||||
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
|
||||
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
|
||||
breadcrumb (UserNotificationR cID) = do
|
||||
mayList <- hasReadAccessTo UsersR
|
||||
if
|
||||
@ -2344,12 +2342,12 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
|
||||
|
||||
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
|
||||
breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
|
||||
breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
|
||||
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
|
||||
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
|
||||
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
|
||||
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
||||
|
||||
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
|
||||
School{..} <- MaybeT . runDB $ get ssh
|
||||
@ -2403,12 +2401,12 @@ instance YesodBreadcrumbs UniWorX where
|
||||
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
|
||||
mr <- getMessageRender
|
||||
Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
|
||||
ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
|
||||
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
|
||||
cid <- decrypt cID
|
||||
Course{..} <- hoist runDB $ do
|
||||
aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
|
||||
aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
|
||||
guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
|
||||
MaybeT $ get cid
|
||||
return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
|
||||
@ -2460,7 +2458,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR
|
||||
CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR
|
||||
CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR
|
||||
|
||||
|
||||
breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of
|
||||
CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR
|
||||
@ -2554,7 +2552,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR
|
||||
|
||||
breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing
|
||||
|
||||
|
||||
breadcrumb (MessageR _) = do
|
||||
mayList <- (== Authorized) <$> evalAccess MessageListR False
|
||||
if
|
||||
@ -2581,9 +2579,9 @@ instance YesodBreadcrumbs UniWorX where
|
||||
| otherwise -> EExamListR
|
||||
EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
|
||||
EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
|
||||
-- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
|
||||
|
||||
submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
|
||||
@ -2666,7 +2664,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
}
|
||||
, do
|
||||
mCurrentRoute <- getCurrentRoute
|
||||
|
||||
|
||||
return NavHeader
|
||||
{ navHeaderRole = NavHeaderSecondary
|
||||
, navIcon = IconMenuHelp
|
||||
@ -2678,7 +2676,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
}
|
||||
, return $ NavFooter NavLink
|
||||
{ navLabel = MsgMenuDataProt
|
||||
, navRoute = LegalR :#: ("data-protection" :: Text)
|
||||
@ -2787,7 +2785,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navLabel = SomeMessage MsgAdminHeading
|
||||
, navIcon = IconMenuAdmin
|
||||
, navChildren =
|
||||
, navChildren =
|
||||
[ NavLink
|
||||
{ navLabel = MsgMenuUsers
|
||||
, navRoute = UsersR
|
||||
@ -2858,7 +2856,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navLabel = SomeMessage (mempty :: Text)
|
||||
, navIcon = IconMenuExtra
|
||||
, navChildren =
|
||||
, navChildren =
|
||||
[ NavLink
|
||||
{ navLabel = MsgMenuCourseNew
|
||||
, navRoute = CourseNewR
|
||||
@ -3084,7 +3082,7 @@ pageActions (CourseR tid ssh csh CShowR) = do
|
||||
, navAccess' = do
|
||||
uid <- requireAuthId
|
||||
runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
E.selectExists $ do
|
||||
(_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
|
||||
E.where_ $ E.not_ isForced
|
||||
@ -3362,7 +3360,7 @@ pageActions HelpR = return
|
||||
, ("allocations", MsgInfoLecturerAllocations)
|
||||
] :: [(Text, UniWorXMessage)]
|
||||
return NavLink
|
||||
{ navLabel
|
||||
{ navLabel
|
||||
, navRoute = InfoLecturerR :#: section
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
@ -3477,7 +3475,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
]
|
||||
pageActions (AllocationR tid ssh ash AUsersR) = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
@ -3501,7 +3499,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
]
|
||||
pageActions CourseListR = do
|
||||
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
|
||||
return
|
||||
@ -3538,7 +3536,7 @@ pageActions CourseListR = do
|
||||
}
|
||||
, navChildren = participantsSecondary
|
||||
}
|
||||
]
|
||||
]
|
||||
pageActions CourseNewR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
@ -3578,14 +3576,13 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return
|
||||
case muid of
|
||||
Nothing -> return False
|
||||
(Just uid) -> do
|
||||
ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
||||
runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return ok
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
||||
, navForceActive = False
|
||||
@ -3609,7 +3606,7 @@ pageActions (CourseR tid ssh csh SheetListR) = do
|
||||
, navChildren = correctionsSecondary
|
||||
}
|
||||
showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections
|
||||
|
||||
|
||||
return $
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
@ -3956,7 +3953,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do
|
||||
, navChildren = subsSecondary
|
||||
}
|
||||
showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions
|
||||
|
||||
|
||||
return $
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
@ -4373,19 +4370,19 @@ pageHeading UsersR
|
||||
= Just $ i18nHeading MsgUsers
|
||||
pageHeading (AdminUserR _)
|
||||
= Just $ i18nHeading MsgAdminUserHeading
|
||||
pageHeading (AdminTestR)
|
||||
= Just $ [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading (AdminErrMsgR)
|
||||
pageHeading AdminTestR
|
||||
= Just [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading AdminErrMsgR
|
||||
= Just $ i18nHeading MsgErrMsgHeading
|
||||
|
||||
pageHeading (InfoR)
|
||||
pageHeading InfoR
|
||||
= Just $ i18nHeading MsgInfoHeading
|
||||
pageHeading (LegalR)
|
||||
pageHeading LegalR
|
||||
= Just $ i18nHeading MsgLegalHeading
|
||||
pageHeading (VersionR)
|
||||
pageHeading VersionR
|
||||
= Just $ i18nHeading MsgVersionHeading
|
||||
|
||||
pageHeading (HelpR)
|
||||
pageHeading HelpR
|
||||
= Just $ i18nHeading MsgHelpRequest
|
||||
|
||||
pageHeading ProfileR
|
||||
@ -4408,8 +4405,8 @@ pageHeading (TermSchoolCourseListR tid ssh)
|
||||
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
|
||||
i18nHeading $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading (CourseListR)
|
||||
= Just $ i18nHeading $ MsgCourseListTitle
|
||||
pageHeading CourseListR
|
||||
= Just $ i18nHeading MsgCourseListTitle
|
||||
pageHeading CourseNewR
|
||||
= Just $ i18nHeading MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
@ -4585,7 +4582,7 @@ runSqlPoolRetry :: forall m a backend.
|
||||
=> ReaderT backend m a
|
||||
-> Pool backend
|
||||
-> m a
|
||||
runSqlPoolRetry action pool = do
|
||||
runSqlPoolRetry action pool = do
|
||||
let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
|
||||
handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
|
||||
where suggestRetry :: IOException -> m Bool
|
||||
@ -4608,7 +4605,7 @@ runSqlPoolRetry action pool = do
|
||||
runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
|
||||
runDBRead action = do
|
||||
$logDebugS "YesodPersist" "runDBRead"
|
||||
runSqlPoolRetry (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod
|
||||
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist UniWorX where
|
||||
@ -4622,7 +4619,7 @@ instance YesodPersist UniWorX where
|
||||
| dryRun = action <* transactionUndo
|
||||
| otherwise = action
|
||||
|
||||
runSqlPoolRetry action' =<< appConnPool <$> getYesod
|
||||
runSqlPoolRetry action' . appConnPool =<< getYesod
|
||||
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = do
|
||||
@ -4774,7 +4771,7 @@ upsertCampusUser plugin ldapData = do
|
||||
-- , UserDisplayName =. userDisplayName
|
||||
, UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserTitle =. userTitle
|
||||
, UserTitle =. userTitle
|
||||
, UserEmail =. userEmail
|
||||
, UserSex =. userSex
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
@ -4852,7 +4849,7 @@ upsertCampusUser plugin ldapData = do
|
||||
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
||||
let matchingFeatures = case knownParents of
|
||||
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
||||
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||
if
|
||||
@ -4911,12 +4908,12 @@ upsertCampusUser plugin ldapData = do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||
oldFs <- selectKeysList
|
||||
([ StudyFeaturesUser ==. studyFeaturesUser
|
||||
[ StudyFeaturesUser ==. studyFeaturesUser
|
||||
, StudyFeaturesDegree ==. studyFeaturesDegree
|
||||
, StudyFeaturesField ==. studyFeaturesField
|
||||
, StudyFeaturesType ==. studyFeaturesType
|
||||
, StudyFeaturesSemester ==. studyFeaturesSemester
|
||||
])
|
||||
]
|
||||
[]
|
||||
case oldFs of
|
||||
[oldF] -> update oldF
|
||||
@ -4933,20 +4930,20 @@ upsertCampusUser plugin ldapData = do
|
||||
associateUserSchoolsByTerms userId
|
||||
|
||||
let
|
||||
userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSchoolAssociation
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
|
||||
ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
|
||||
|
||||
forM_ ss $ \frag -> void . runMaybeT $ do
|
||||
let
|
||||
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
||||
infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
|
||||
infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
|
||||
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
||||
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
||||
return schoolLdap
|
||||
@ -4960,7 +4957,7 @@ upsertCampusUser plugin ldapData = do
|
||||
}
|
||||
|
||||
forM_ ss $ void . insertUnique . SchoolLdap Nothing
|
||||
|
||||
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
@ -5092,7 +5089,7 @@ instance YesodAuth UniWorX where
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
|
||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
@ -5122,7 +5119,7 @@ campusUserFailoverMode = FailoverUnlimited
|
||||
instance YesodAuthPersist UniWorX where
|
||||
getAuthEntity = liftHandler . runDBRead . get
|
||||
|
||||
|
||||
|
||||
unsafeHandler :: UniWorX -> Handler a -> IO a
|
||||
unsafeHandler f h = do
|
||||
logger <- makeLogger f
|
||||
|
||||
@ -110,7 +110,7 @@ ordinalEN (toMessage -> numStr) = case lastChar of
|
||||
Just '3' -> [st|#{numStr}rd|]
|
||||
_other -> [st|#{numStr}th|]
|
||||
where
|
||||
lastChar = last <$> fromNullable numStr
|
||||
lastChar = last <$> fromNullable numStr
|
||||
|
||||
|
||||
-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
|
||||
@ -172,7 +172,7 @@ instance RenderMessage UniWorX MsgLanguage where
|
||||
| ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
|
||||
| ("de" : _) <- lang' = mr MsgGerman
|
||||
| ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
|
||||
| ("en" : _) <- lang' = mr MsgEnglish
|
||||
| ("en" : _) <- lang' = mr MsgEnglish
|
||||
| otherwise = lang
|
||||
where
|
||||
mr = renderMessage foundation $ lang : filter (/= lang) ls
|
||||
@ -247,7 +247,7 @@ instance RenderMessage UniWorX StudyDegreeTerm where
|
||||
where
|
||||
mr :: RenderMessage UniWorX msg => msg -> Text
|
||||
mr = renderMessage foundation ls
|
||||
|
||||
|
||||
newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
|
||||
embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
|
||||
|
||||
@ -333,7 +333,7 @@ instance RenderMessage UniWorX UniWorXMessages where
|
||||
uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
|
||||
uniworxMessages = UniWorXMessages . map SomeMessage
|
||||
|
||||
|
||||
|
||||
-- This instance is required to use forms. You can modify renderMessage to
|
||||
-- achieve customized and internationalized form validation messages.
|
||||
instance RenderMessage UniWorX FormMessage where
|
||||
|
||||
@ -75,11 +75,11 @@ pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX
|
||||
pattern CApplicationR tid ssh csh appId ptn
|
||||
= CourseR tid ssh csh (CourseApplicationR appId ptn)
|
||||
|
||||
|
||||
pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX
|
||||
pattern CNewsR tid ssh csh nId ptn
|
||||
= CourseR tid ssh csh (CourseNewsR nId ptn)
|
||||
|
||||
|
||||
pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX
|
||||
pattern CEventR tid ssh csh nId ptn
|
||||
= CourseR tid ssh csh (CourseEventR nId ptn)
|
||||
|
||||
@ -47,7 +47,7 @@ embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
|
||||
instance Button UniWorX ButtonAdminStudyTermsParents where
|
||||
btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||
|
||||
|
||||
data ButtonAdminStudyTermsStandalone
|
||||
= BtnStandaloneCandidatesDeleteRedundant
|
||||
| BtnStandaloneCandidatesDeleteAll
|
||||
@ -62,7 +62,7 @@ instance Button UniWorX ButtonAdminStudyTermsStandalone where
|
||||
btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||
|
||||
|
||||
|
||||
{-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-}
|
||||
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
||||
getAdminFeaturesR = postAdminFeaturesR
|
||||
@ -147,7 +147,7 @@ postAdminFeaturesR = do
|
||||
deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
|
||||
addMessageI Success MsgAllStandaloneIncidencesDeleted
|
||||
redirect AdminFeaturesR
|
||||
|
||||
|
||||
|
||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
||||
badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
|
||||
@ -208,7 +208,7 @@ postAdminFeaturesR = do
|
||||
infRedundantStandalone <- Candidates.removeRedundantStandalone
|
||||
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
||||
return updated
|
||||
|
||||
|
||||
let newKeys = catMaybes $ Map.elems updated
|
||||
unless (null newKeys) $ do
|
||||
setSessionJson SessionNewStudyTerms newKeys
|
||||
@ -247,19 +247,19 @@ postAdminFeaturesR = do
|
||||
=> Lens' a (Maybe Text)
|
||||
-> Getter (DBRow r) (Maybe Text)
|
||||
-> Getter (DBRow r) i
|
||||
-> DBRow r
|
||||
-> DBRow r
|
||||
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||
(\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvWidget
|
||||
<$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
|
||||
)
|
||||
|
||||
|
||||
checkboxCell :: Ord i
|
||||
=> Lens' a Bool
|
||||
-> Getter (DBRow r) Bool
|
||||
-> Getter (DBRow r) i
|
||||
-> DBRow r
|
||||
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||
-> DBRow r
|
||||
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||
( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
|
||||
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
|
||||
@ -306,7 +306,7 @@ postAdminFeaturesR = do
|
||||
( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
|
||||
<$> mopt degreeField "" (Just $ row ^. lensDefault)
|
||||
)
|
||||
|
||||
|
||||
fieldTypeCell :: Ord i
|
||||
=> Lens' a (Maybe StudyFieldType)
|
||||
-> Getter (DBRow r) (Maybe StudyFieldType)
|
||||
@ -359,7 +359,7 @@ postAdminFeaturesR = do
|
||||
fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
|
||||
E.where_ . E.exists . E.from $ \schoolTerms ->
|
||||
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
||||
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
|
||||
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
|
||||
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
|
||||
return $ school E.^. SchoolId
|
||||
fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do
|
||||
|
||||
@ -45,10 +45,10 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
|
||||
|
||||
maxSizeRes <- wreq intField (fslI MsgTestDownloadMaxSize) . Just $ 2 * 2^30
|
||||
modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
|
||||
|
||||
|
||||
return $ TestDownloadOptions
|
||||
<$> pure randomSeed
|
||||
<*> maxSizeRes
|
||||
randomSeed
|
||||
<$> maxSizeRes
|
||||
<*> pure (2^20)
|
||||
<*> modeRes
|
||||
|
||||
@ -86,7 +86,7 @@ testDownload = do
|
||||
sourceDBFiles = E.selectSource . E.from $ \fileContent -> do
|
||||
E.orderBy [E.asc $ E.random_ @Int64]
|
||||
return fileContent
|
||||
|
||||
|
||||
takeLimit n | n <= 0 = return ()
|
||||
takeLimit n = do
|
||||
c <- await
|
||||
|
||||
@ -30,7 +30,7 @@ bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
|
||||
bearerTokenForm = do
|
||||
muid <- maybeAuthId
|
||||
mr <- getMessageRender
|
||||
|
||||
|
||||
btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") MsgBearerTokenAuthorityGroupMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
|
||||
btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
|
||||
let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
|
||||
@ -58,7 +58,7 @@ bearerTokenForm = do
|
||||
|
||||
miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")
|
||||
|
||||
|
||||
btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm
|
||||
|
||||
btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing
|
||||
@ -87,7 +87,7 @@ postAdminTokensR = do
|
||||
& HashSet.map (left toJSON)
|
||||
|
||||
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
|
||||
|
||||
|
||||
siteLayoutMsg' MsgMenuAdminTokens $ do
|
||||
setTitleI MsgMenuAdminTokens
|
||||
|
||||
|
||||
@ -33,7 +33,7 @@ newtype SessionDataAllocationResults = SessionDataAllocationResults
|
||||
deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun))
|
||||
|
||||
makeWrapped ''SessionDataAllocationResults
|
||||
|
||||
|
||||
|
||||
data AllocationAcceptButton
|
||||
= BtnAllocationAccept
|
||||
@ -59,7 +59,7 @@ allocationAcceptForm aId = runMaybeT $ do
|
||||
let applications = E.subSelectCount . E.from $ \courseApplication ->
|
||||
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
|
||||
E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
|
||||
return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
|
||||
return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
|
||||
[ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications)
|
||||
E.then_ (applications :: E.SqlExpr (E.Value Int))
|
||||
]
|
||||
@ -124,7 +124,7 @@ allocationAcceptForm aId = runMaybeT $ do
|
||||
= invDualHeat (optimumAllocated capN) capN
|
||||
degenerateHeat capN
|
||||
= capN <= optimumAllocated capN
|
||||
|
||||
|
||||
return (prevAllocMatches, $(widgetFile "allocation/accept"))
|
||||
|
||||
getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
||||
@ -135,7 +135,7 @@ postAAcceptR tid ssh ash = do
|
||||
|
||||
acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId
|
||||
|
||||
formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
|
||||
formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
|
||||
|
||||
didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do
|
||||
modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $
|
||||
|
||||
@ -58,24 +58,24 @@ data ApplicationFormMode = ApplicationFormMode
|
||||
, afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown)
|
||||
, afmLecturer :: Bool -- ^ Allow editing rating
|
||||
}
|
||||
|
||||
|
||||
|
||||
data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception ApplicationFormException
|
||||
|
||||
applicationForm :: (Maybe AllocationId)
|
||||
applicationForm :: Maybe AllocationId
|
||||
-> CourseId
|
||||
-> UserId
|
||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
||||
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
|
||||
|
||||
|
||||
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
|
||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||
course <- getJust cid
|
||||
(fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
(fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||
@ -91,25 +91,25 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
|
||||
mkPrioOption :: Natural -> Option Natural
|
||||
mkPrioOption i = Option
|
||||
{ optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i
|
||||
{ optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i
|
||||
, optionInternalValue = i
|
||||
, optionExternalValue = tshow i
|
||||
}
|
||||
|
||||
|
||||
prioOptions :: OptionList Natural
|
||||
prioOptions = OptionList
|
||||
{ olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum']
|
||||
, olReadExternal = readMay
|
||||
}
|
||||
prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
|
||||
|
||||
|
||||
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
||||
(True , True , True , Nothing)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
|
||||
(True , True , True , Just _ )
|
||||
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
||||
(True , True , False, _ )
|
||||
-> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
|
||||
-> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
|
||||
(True , False, _ , Just _ )
|
||||
| is _Just oldPrio
|
||||
-> pure (FormSuccess oldPrio, Nothing)
|
||||
@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
|
||||
filesLinkView <- if
|
||||
| fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
-> let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
-> return Nothing
|
||||
|
||||
filesWarningView <- if
|
||||
| fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
| Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
@ -174,16 +174,16 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
in if
|
||||
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
|
||||
-> return $ (FormSuccess Nothing, Nothing)
|
||||
-> return (FormSuccess Nothing, Nothing)
|
||||
| otherwise
|
||||
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
||||
|
||||
(vetoRes, vetoView) <- if
|
||||
| afmLecturer
|
||||
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
|
||||
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
|
||||
| otherwise
|
||||
-> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
|
||||
|
||||
-> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
|
||||
|
||||
(pointsRes, pointsView) <- if
|
||||
| afmLecturer
|
||||
-> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal)
|
||||
@ -195,7 +195,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal)
|
||||
| otherwise
|
||||
-> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing)
|
||||
|
||||
|
||||
let
|
||||
buttons = catMaybes
|
||||
[ guardOn (not afmApplicantEdit && is _Just mApp && afmLecturer) BtnAllocationApplicationRate
|
||||
@ -225,7 +225,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
<*> actionRes
|
||||
, ApplicationFormView
|
||||
{ afvPriority = prioView
|
||||
, afvForm = catMaybes $
|
||||
, afvForm = catMaybes $
|
||||
[ Just fieldView'
|
||||
, textView
|
||||
, filesLinkView
|
||||
@ -240,7 +240,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
editApplicationR :: Maybe AllocationId
|
||||
@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
, courseApplicationRatingTime = guardOn rated now
|
||||
}
|
||||
|
||||
runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
audit $ TransactionCourseApplicationEdit cid uid appId
|
||||
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
|
||||
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
|
||||
@ -354,7 +354,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
redirect postAction
|
||||
|
||||
return (appView, appEnc)
|
||||
|
||||
|
||||
|
||||
postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
|
||||
postAApplyR tid ssh ash cID = do
|
||||
|
||||
@ -62,7 +62,7 @@ missingPriorities aId = wFormToAForm $ do
|
||||
missingPriosFieldView theId name attrs res isReq
|
||||
= $(i18nWidgetFile "allocation-confirm-missing-prios")
|
||||
where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq
|
||||
|
||||
|
||||
if
|
||||
| null usersWithoutPrio
|
||||
-> return $ pure Set.empty
|
||||
|
||||
@ -5,7 +5,7 @@ module Handler.Allocation.List
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Handler.Utils.Table.Columns
|
||||
@ -23,16 +23,16 @@ queryAllocation = id
|
||||
|
||||
|
||||
countCourses :: (Num n, PersistField n)
|
||||
=> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
|
||||
=> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
|
||||
-> E.SqlExpr (Entity Allocation)
|
||||
-> E.SqlExpr (E.Value n)
|
||||
countCourses addWhere allocation = E.subSelectCount . E.from $ \allocationCourse ->
|
||||
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
|
||||
E.&&. addWhere allocationCourse
|
||||
|
||||
|
||||
queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
|
||||
queryAvailable = queryAllocation . to (countCourses $ const E.true)
|
||||
|
||||
|
||||
queryApplied :: UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
|
||||
queryApplied uid = queryAllocation . to (\allocation -> countCourses (addWhere allocation) allocation)
|
||||
where
|
||||
@ -51,7 +51,7 @@ resultApplied = _dbrOutput . _3
|
||||
|
||||
allocationTermLink :: TermId -> SomeRoute UniWorX
|
||||
allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
|
||||
|
||||
|
||||
allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
|
||||
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
|
||||
|
||||
|
||||
@ -26,7 +26,7 @@ instance Finite AllocationPrioritiesMode
|
||||
nullaryPathPiece ''AllocationPrioritiesMode $ camelToPathPiece' 2
|
||||
|
||||
embedRenderMessage ''UniWorX ''AllocationPrioritiesMode id
|
||||
|
||||
|
||||
|
||||
getAPriosR, postAPriosR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
||||
getAPriosR = postAPriosR
|
||||
@ -37,7 +37,7 @@ postAPriosR tid ssh ash = do
|
||||
numericPrios <- E.selectCountRows . E.from $ \allocationUser -> do
|
||||
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
||||
E.where_ . E.maybe E.false sqlAllocationPriorityNumeric $ allocationUser E.^. AllocationUserPriority
|
||||
|
||||
|
||||
ordinalPrios <- E.selectCountRows . E.from $ \allocationUser -> do
|
||||
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
||||
E.where_ . E.maybe E.false (E.not_ . sqlAllocationPriorityNumeric) $ allocationUser E.^. AllocationUserPriority
|
||||
@ -59,7 +59,7 @@ postAPriosR tid ssh ash = do
|
||||
let sourcePrios = case mode of
|
||||
AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
|
||||
AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities
|
||||
|
||||
|
||||
(matrSunk, matrMissing) <- runDB $ do
|
||||
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
updateWhere
|
||||
@ -77,7 +77,7 @@ postAPriosR tid ssh ash = do
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
|
||||
return (matrSunk, matrMissing)
|
||||
|
||||
when (matrSunk > 0) $
|
||||
when (matrSunk > 0) $
|
||||
addMessageI Success $ MsgAllocationPrioritiesSunk matrSunk
|
||||
when (matrMissing > 0) $
|
||||
addMessageI Error $ MsgAllocationPrioritiesMissing matrMissing
|
||||
|
||||
@ -46,7 +46,7 @@ postARegisterR tid ssh ash = do
|
||||
formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do
|
||||
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
isRegistered <- existsBy $ UniqueAllocationUser aId uid
|
||||
void $ upsert AllocationUser
|
||||
void $ upsert AllocationUser
|
||||
{ allocationUserAllocation = aId
|
||||
, allocationUserUser = uid
|
||||
, allocationUserTotalCourses = arfTotalCourses
|
||||
@ -57,5 +57,5 @@ postARegisterR tid ssh ash = do
|
||||
if
|
||||
| isRegistered -> addMessageI Success MsgAllocationRegistrationEdited
|
||||
| otherwise -> addMessageI Success MsgAllocationRegistered
|
||||
|
||||
|
||||
redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text)
|
||||
|
||||
@ -4,7 +4,7 @@ module Handler.Allocation.Show
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Handler.Allocation.Register
|
||||
import Handler.Allocation.Application
|
||||
|
||||
|
||||
@ -63,11 +63,11 @@ type UserTableData = DBRow ( Entity User
|
||||
, Int -- ^ Applied
|
||||
, Int -- ^ Assigned
|
||||
, Int -- ^ Vetoed
|
||||
)
|
||||
)
|
||||
|
||||
resultUser :: Lens' UserTableData (Entity User)
|
||||
resultUser = _dbrOutput . _1
|
||||
|
||||
|
||||
resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
|
||||
resultAllocationUser = _dbrOutput . _2
|
||||
|
||||
@ -83,7 +83,7 @@ data AllocationUserTableCsv = AllocationUserTableCsv
|
||||
, csvAUserName :: Text
|
||||
, csvAUserMatriculation :: Maybe Text
|
||||
, csvAUserRequested
|
||||
, csvAUserApplied
|
||||
, csvAUserApplied
|
||||
, csvAUserVetos
|
||||
, csvAUserAssigned :: Natural
|
||||
, csvAUserPriority :: Maybe AllocationPriority
|
||||
@ -94,10 +94,10 @@ allocationUserTableCsvOptions :: Csv.Options
|
||||
allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3}
|
||||
|
||||
instance Csv.ToNamedRecord AllocationUserTableCsv where
|
||||
toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions
|
||||
toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions
|
||||
|
||||
instance Csv.DefaultOrdered AllocationUserTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions
|
||||
headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions
|
||||
|
||||
instance CsvColumnsExplained AllocationUserTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat
|
||||
|
||||
@ -42,7 +42,7 @@ getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCAppsFilesR tid ssh csh = do
|
||||
runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
|
||||
|
||||
let
|
||||
@ -61,12 +61,12 @@ getCAppsFilesR tid ssh csh = do
|
||||
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||
let
|
||||
applicationAllocs = setOf (folded . _1) apps'
|
||||
|
||||
|
||||
allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
|
||||
|
||||
allEqualOn :: Eq x => Getter _ x -> Bool
|
||||
allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
|
||||
|
||||
|
||||
mkAllocationDir mbAlloc
|
||||
| not $ allEqualOn _1
|
||||
, Just Allocation{..} <- mbAlloc
|
||||
@ -92,7 +92,7 @@ getCAppsFilesR tid ssh csh = do
|
||||
fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
||||
return courseApplicationFile
|
||||
|
||||
|
||||
yield $ _FileReference # ( FileReference
|
||||
{ fileReferenceModified = courseApplicationTime
|
||||
, fileReferenceTitle = mkAppDir ""
|
||||
|
||||
@ -47,7 +47,7 @@ type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Maybe (Entity StudyDegree)
|
||||
, Bool -- isParticipant
|
||||
)
|
||||
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
@ -120,7 +120,7 @@ instance Csv.FromField CourseApplicationsTableVeto where
|
||||
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
|
||||
return . CourseApplicationsTableVeto $ elem t
|
||||
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
|
||||
|
||||
|
||||
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
|
||||
{ csvCAAllocation :: Maybe AllocationShorthand
|
||||
, csvCAApplication :: Maybe CryptoFileNameCourseApplication
|
||||
@ -223,7 +223,7 @@ instance Exception CourseApplicationsTableCsvException
|
||||
|
||||
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
|
||||
|
||||
|
||||
|
||||
data ButtonAcceptApplications = BtnAcceptApplications
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonAcceptApplications
|
||||
@ -277,7 +277,7 @@ postCApplicationsR tid ssh csh = do
|
||||
applicationLink appId = liftHandler $ do
|
||||
cID <- encrypt appId
|
||||
return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
|
||||
|
||||
|
||||
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
courseApplication <- view queryCourseApplication
|
||||
@ -415,13 +415,13 @@ postCApplicationsR tid ssh csh = do
|
||||
-> return () -- no addition
|
||||
DBCsvDiffExisting{..} -> do
|
||||
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
|
||||
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
|
||||
yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
|
||||
|
||||
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
|
||||
whenIsJust mVeto $ \veto ->
|
||||
whenIsJust mVeto $ \veto ->
|
||||
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
|
||||
yield $ CourseApplicationsTableCsvSetVetoData appId veto
|
||||
|
||||
@ -638,7 +638,7 @@ postCApplicationsR tid ssh csh = do
|
||||
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||
registrationOpen = maybe True (now <)
|
||||
|
||||
|
||||
|
||||
((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
|
||||
(,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
|
||||
<*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)
|
||||
@ -679,7 +679,7 @@ postCApplicationsR tid ssh csh = do
|
||||
AcceptApplicationsSecondaryRandom
|
||||
-> comparing $ view ratingL
|
||||
sortedApplications <- unstableSortBy cmp applications
|
||||
|
||||
|
||||
let applicants = sortedApplications
|
||||
& nubOn (view $ _1 . _entityKey)
|
||||
& maybe id take openCapacity
|
||||
@ -687,7 +687,7 @@ postCApplicationsR tid ssh csh = do
|
||||
AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
|
||||
AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
|
||||
)
|
||||
|
||||
|
||||
mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
|
||||
|
||||
@ -94,7 +94,7 @@ postCCommR tid ssh csh = do
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
return user
|
||||
return user
|
||||
)
|
||||
] ++ tuts ++ exams ++ sheets
|
||||
, crRecipientAuth = Just $ \uid -> do
|
||||
|
||||
@ -88,7 +88,7 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
|
||||
where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
|
||||
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
||||
return courseAppInstructionFile
|
||||
|
||||
|
||||
|
||||
allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
|
||||
allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
|
||||
@ -134,7 +134,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
addView' = $(widgetFile "course/lecturerMassInput/add")
|
||||
return (addRes'', addView')
|
||||
|
||||
@ -194,9 +194,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
||||
_allIOtherCases -> do
|
||||
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
||||
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
||||
return ( Just . toMidnight . termStart . entityVal <$> mbLastTerm
|
||||
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
|
||||
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm )
|
||||
|
||||
let
|
||||
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
||||
@ -208,7 +208,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
E.exists . E.from $ \allocationCourse ->
|
||||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
|
||||
|
||||
|
||||
E.where_ $ term E.^. TermActive
|
||||
E.||. alreadyParticipates
|
||||
E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
|
||||
@ -238,8 +238,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
|
||||
let
|
||||
userAdmin = not $ null adminSchools
|
||||
mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
|
||||
|
||||
mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
|
||||
|
||||
allocationForm' =
|
||||
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
||||
ainp
|
||||
@ -260,8 +260,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
|
||||
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
(cfCourseId =<< template)
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
||||
@ -322,7 +322,7 @@ validateCourse = do
|
||||
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
||||
$ NTop cfRegFrom <= NTop cfRegTo
|
||||
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
||||
$ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
|
||||
$ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
|
||||
unless userAdmin $
|
||||
guardValidation MsgCourseUserMustBeLecturer
|
||||
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
||||
@ -335,7 +335,7 @@ validateCourse = do
|
||||
|
||||
warnValidation MsgCourseShorthandTooLong
|
||||
$ length (CI.original cfShort) <= 10
|
||||
|
||||
|
||||
|
||||
getCourseNewR :: Handler Html -- call via toTextUrl
|
||||
getCourseNewR = do
|
||||
@ -521,7 +521,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
|
||||
let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
|
||||
|
||||
upsertAllocationCourse cid $ cfAllocation res
|
||||
|
||||
|
||||
@ -8,13 +8,13 @@ import Handler.Utils.Occurrences
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
|
||||
getCEvDeleteR, postCEvDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> Handler Html
|
||||
getCEvDeleteR = postCEvDeleteR
|
||||
postCEvDeleteR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
|
||||
|
||||
let
|
||||
drRecords :: Set (Key CourseEvent)
|
||||
drRecords = Set.singleton nId
|
||||
@ -31,23 +31,23 @@ postCEvDeleteR tid ssh csh cID = do
|
||||
:
|
||||
^{occurrencesWidget courseEventTime}
|
||||
|]
|
||||
|
||||
|
||||
drRecordConfirmString :: Entity CourseEvent -> DB Text
|
||||
drRecordConfirmString _ = return ""
|
||||
|
||||
|
||||
drCaption, drSuccessMessage :: SomeMessage UniWorX
|
||||
drCaption = SomeMessage MsgCourseEventDeleteQuestion
|
||||
drSuccessMessage = SomeMessage MsgCourseEventDeleted
|
||||
|
||||
|
||||
drAbort, drSuccess :: SomeRoute UniWorX
|
||||
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
|
||||
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
|
||||
|
||||
|
||||
drFormMessage :: [Entity CourseEvent] -> DB (Maybe Message)
|
||||
drFormMessage _ = return Nothing
|
||||
|
||||
|
||||
drDelete :: forall a. CourseEventId -> JobDB a -> JobDB a
|
||||
drDelete _ = id
|
||||
|
||||
|
||||
deleteR DeleteRoute{..}
|
||||
|
||||
|
||||
@ -4,7 +4,7 @@ module Handler.Course.Events.Edit
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Handler.Course.Events.Form
|
||||
|
||||
|
||||
|
||||
@ -31,7 +31,7 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
|
||||
)
|
||||
let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
|
||||
courseEventRooms = optionsPairs [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ]
|
||||
|
||||
|
||||
cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
|
||||
cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template)
|
||||
cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
|
||||
|
||||
@ -4,7 +4,7 @@ module Handler.Course.Events.New
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Handler.Course.Events.Form
|
||||
|
||||
getCEventsNewR, postCEventsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
|
||||
@ -12,7 +12,7 @@ getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUU
|
||||
getCNDeleteR = postCNDeleteR
|
||||
postCNDeleteR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
|
||||
|
||||
let
|
||||
drRecords :: Set (Key CourseNews)
|
||||
drRecords = Set.singleton nId
|
||||
@ -26,22 +26,22 @@ postCNDeleteR tid ssh csh cID = do
|
||||
[ toWidget <$> courseNewsTitle
|
||||
, toWidget <$> courseNewsSummary
|
||||
]
|
||||
|
||||
|
||||
drRecordConfirmString :: Entity CourseNews -> DB Text
|
||||
drRecordConfirmString _ = return ""
|
||||
|
||||
|
||||
drCaption, drSuccessMessage :: SomeMessage UniWorX
|
||||
drCaption = SomeMessage MsgCourseNewsDeleteQuestion
|
||||
drSuccessMessage = SomeMessage MsgCourseNewsDeleted
|
||||
|
||||
|
||||
drAbort, drSuccess :: SomeRoute UniWorX
|
||||
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
|
||||
|
||||
drFormMessage :: [Entity CourseNews] -> DB (Maybe Message)
|
||||
drFormMessage _ = return Nothing
|
||||
|
||||
|
||||
drDelete :: forall a. CourseNewsId -> JobDB a -> JobDB a
|
||||
drDelete _ = id
|
||||
|
||||
|
||||
deleteR DeleteRoute{..}
|
||||
|
||||
@ -25,7 +25,7 @@ getCNArchiveR tid ssh csh cID = do
|
||||
|
||||
serveSomeFiles archiveName getFilesQuery
|
||||
|
||||
|
||||
|
||||
getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
|
||||
getCNFileR _ _ _ cID title = do
|
||||
nId <- decrypt cID
|
||||
|
||||
@ -34,7 +34,7 @@ postCNEditR tid ssh csh cID = do
|
||||
, courseNewsLastEdit = now
|
||||
}
|
||||
let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
|
||||
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
|
||||
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
|
||||
addMessageI Success MsgCourseNewsEdited
|
||||
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
|
||||
|
||||
@ -16,7 +16,7 @@ data CourseNewsForm = CourseNewsForm
|
||||
, cnfContent :: Html
|
||||
, cnfParticipantsOnly :: Bool
|
||||
, cnfVisibleFrom :: Maybe UTCTime
|
||||
, cnfFiles :: Maybe FileUploads
|
||||
, cnfFiles :: Maybe FileUploads
|
||||
}
|
||||
|
||||
courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm
|
||||
|
||||
@ -96,7 +96,7 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
|
||||
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
||||
res <- act -- insertUnique
|
||||
@ -138,7 +138,7 @@ postCAddUserR tid ssh csh = do
|
||||
|
||||
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
|
||||
hoist runDBJobs . registerUsers' cid
|
||||
|
||||
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
@ -169,7 +169,7 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> AddParticipantsResult
|
||||
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
||||
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
||||
(aurAlreadyRegistered', aurNoUniquePrimaryField') <-
|
||||
(aurAlreadyRegistered', aurNoUniquePrimaryField') <-
|
||||
(,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
|
||||
<*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
|
||||
|
||||
|
||||
@ -63,7 +63,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister]
|
||||
return . (, btn) . wFormToAForm $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
|
||||
secretRes <- if
|
||||
| Just secret <- courseRegisterSecret
|
||||
, not isRegistered
|
||||
@ -112,7 +112,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
|
||||
when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
|
||||
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
|
||||
let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -130,7 +130,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
|]
|
||||
in void $ wforced filesLinkField (fslI filesMsg) Nothing
|
||||
|
||||
when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
|
||||
|
||||
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
@ -145,14 +145,14 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog
|
||||
when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $
|
||||
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow
|
||||
|
||||
|
||||
return $ CourseRegisterForm
|
||||
<$ secretRes
|
||||
<*> fieldRes
|
||||
<*> appTextRes
|
||||
<*> appFilesRes
|
||||
|
||||
|
||||
|
||||
-- | Workaround for klicking register button without being logged in.
|
||||
-- After log in, the user sees a "get request not supported" error.
|
||||
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -193,8 +193,8 @@ postCRegisterR tid ssh csh = do
|
||||
|
||||
return $ Just prevId
|
||||
|
||||
whenIsJust appRes $
|
||||
audit . TransactionCourseApplicationEdit cid uid
|
||||
whenIsJust appRes $
|
||||
audit . TransactionCourseApplicationEdit cid uid
|
||||
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
|
||||
runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
return appRes
|
||||
@ -275,7 +275,7 @@ deregisterParticipant uid cid = do
|
||||
forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do
|
||||
delete erId
|
||||
audit $ TransactionExamDeregister examRegistrationExam uid
|
||||
|
||||
|
||||
E.delete . E.from $ \tutorialParticipant -> do
|
||||
let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
|
||||
|
||||
|
||||
@ -103,16 +103,15 @@ getCShowR tid ssh csh = do
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
return $ submissionGroup E.^. SubmissionGroupName
|
||||
let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup'
|
||||
|
||||
|
||||
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup)
|
||||
|
||||
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||
|
||||
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
|
||||
<$> pure alloc
|
||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
|
||||
<$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
regForm <- if
|
||||
| is _Just mbAid -> do
|
||||
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
||||
@ -125,9 +124,9 @@ getCShowR tid ssh csh = do
|
||||
| otherwise
|
||||
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
|
||||
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
|
||||
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
|
||||
let
|
||||
tutorialDBTable = DBTable{..}
|
||||
where
|
||||
|
||||
@ -60,7 +60,7 @@ postCUserR tid ssh csh uCId = do
|
||||
registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]
|
||||
|
||||
return (course, Entity uid user, registered)
|
||||
|
||||
|
||||
sections <- mapM (runMaybeT . ($ user) . ($ course))
|
||||
[ courseUserProfileSection
|
||||
, courseUserNoteSection
|
||||
@ -202,11 +202,11 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
|
||||
|
||||
return $(widgetFile "course/user/profile")
|
||||
|
||||
|
||||
|
||||
courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
||||
courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
|
||||
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
|
||||
|
||||
|
||||
currentRoute <- MaybeT getCurrentRoute
|
||||
|
||||
(thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
|
||||
@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
|
||||
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
|
||||
|
||||
uCID <- encrypt uid
|
||||
|
||||
|
||||
let
|
||||
examDBTable = DBTable{..}
|
||||
where
|
||||
|
||||
@ -137,7 +137,7 @@ _userSheets = _dbrOutput . _8
|
||||
|
||||
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserComment tid ssh csh =
|
||||
sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
|
||||
sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
|
||||
maybeEmpty mbNoteKey $ const $
|
||||
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
|
||||
where
|
||||
@ -189,15 +189,15 @@ colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgSubmiss
|
||||
colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c)
|
||||
colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
|
||||
where
|
||||
caption = i18nCell MsgCourseUserSheets
|
||||
caption = i18nCell MsgCourseUserSheets
|
||||
& cellAttrs <>~ [ ("uw-hide-column-header", "sheets")
|
||||
, ("uw-hide-column-default-hidden", "")
|
||||
]
|
||||
|
||||
|
||||
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
|
||||
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
|
||||
Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
|
||||
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points
|
||||
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
|
||||
_other -> mempty
|
||||
|
||||
|
||||
@ -208,7 +208,7 @@ data UserTableCsvStudyFeature = UserTableCsvStudyFeature
|
||||
, csvUserType :: StudyFieldType
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
makeLenses_ ''UserTableCsvStudyFeature
|
||||
|
||||
|
||||
data UserTableCsv = UserTableCsv
|
||||
{ csvUserName :: Text
|
||||
, csvUserSex :: Maybe Sex
|
||||
@ -387,33 +387,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ sortUserEmail queryUser
|
||||
, single $ sortUserMatriclenr queryUser
|
||||
, sortUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
, single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
E.subSelectMaybe . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||
, single ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
||||
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
||||
return . E.min_ $ tutorial E.^. TutorialName
|
||||
)
|
||||
, single $ ("exams" , SortColumn $ queryUser >>> \user ->
|
||||
, single ("exams" , SortColumn $ queryUser >>> \user ->
|
||||
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||
return . E.min_ $ exam E.^. ExamName
|
||||
)
|
||||
, single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||
, single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||
, mconcat
|
||||
[ single ( SortingKey $ "sheet-" <> sheetName
|
||||
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -421,8 +421,8 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId
|
||||
return $ submission E.^. SubmissionRatingPoints
|
||||
|
||||
)
|
||||
|
||||
)
|
||||
| Entity shId Sheet{..} <- sheets
|
||||
]
|
||||
]
|
||||
@ -433,38 +433,38 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ fltrUserMatriclenr queryUser
|
||||
, single $ fltrUserNameEmail queryUser
|
||||
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single $ ("field" , FilterColumn $ E.anyFilter
|
||||
, single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single ("field" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
||||
] )
|
||||
, single $ ("degree" , FilterColumn $ E.anyFilter
|
||||
, single ("degree" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||
] )
|
||||
, single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
, single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
||||
)
|
||||
, single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
, single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||
E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
|
||||
)
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||
|
||||
|
||||
, single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||
]
|
||||
where single = uncurry Map.singleton
|
||||
dbtFilterUI mPrev = mconcat $
|
||||
@ -498,7 +498,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
{ dbtCsvExportForm = UserCsvExportData
|
||||
<$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
|
||||
<*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
|
||||
, dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
|
||||
, dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
|
||||
UserTableCsv
|
||||
<$> view (hasUser . _userDisplayName)
|
||||
<*> view (hasUser . _userSex)
|
||||
@ -615,7 +615,7 @@ postCUsersR tid ssh csh = do
|
||||
hasExams = not $ null exams
|
||||
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
|
||||
examOccActs = examOccurrencesPerExam
|
||||
& (map (bimap entityKey hoistMaybe))
|
||||
& map (bimap entityKey hoistMaybe)
|
||||
& Map.fromListWith (<>)
|
||||
& imap (\k v -> case v of
|
||||
[] -> pure (k, Nothing)
|
||||
@ -684,7 +684,7 @@ postCUsersR tid ssh csh = do
|
||||
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
(CourseUserRegisterTutorialData{..}, selectedUsers) -> do
|
||||
runDB . forM_ selectedUsers $
|
||||
runDB . forM_ selectedUsers $
|
||||
void . insertUnique . TutorialParticipant registerTutorial
|
||||
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
@ -725,7 +725,7 @@ postCUsersR tid ssh csh = do
|
||||
]
|
||||
[ CourseParticipantState =. CourseParticipantActive
|
||||
, CourseParticipantRegistration =. now
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
]
|
||||
guard $ didUpdate > 0
|
||||
lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ]
|
||||
|
||||
@ -62,7 +62,7 @@ instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch
|
||||
handleCryptoID :: CryptoIDError -> Handler (Maybe a)
|
||||
handleCryptoID _ = return Nothing
|
||||
dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext
|
||||
|
||||
|
||||
|
||||
getCryptoUUIDDispatchR :: UUID -> Handler ()
|
||||
getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAccessWith movedPermanently301)
|
||||
@ -75,5 +75,5 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAcce
|
||||
getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
|
||||
getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectAccessWith movedPermanently301)
|
||||
where
|
||||
p :: Proxy '[ SubmissionId ]
|
||||
p :: Proxy '[ SubmissionId ]
|
||||
p = Proxy
|
||||
|
||||
@ -8,15 +8,15 @@ import Handler.Exam.RegistrationInvite
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Semigroup (Option(..))
|
||||
|
||||
|
||||
import Control.Monad.Error.Class (MonadError(..))
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
import Generics.Deriving.Monoid
|
||||
|
||||
|
||||
@ -43,7 +43,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
now <- liftIO getCurrentTime
|
||||
occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
|
||||
|
||||
|
||||
let
|
||||
localNow = utcToLocalTime now
|
||||
tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
|
||||
@ -65,7 +65,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
= max tomorrowEndOfDay earliestDate'
|
||||
| otherwise
|
||||
= tomorrowEndOfDay
|
||||
|
||||
|
||||
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
|
||||
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
|
||||
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
|
||||
@ -132,7 +132,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
lift $ lift examRegister
|
||||
throwError $ mempty { aurSuccess = pure userEmail }
|
||||
|
||||
unless registerCourse $
|
||||
unless registerCourse $
|
||||
throwError $ mempty { aurNoCourseRegistration = pure userEmail }
|
||||
|
||||
guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True)
|
||||
|
||||
@ -52,7 +52,7 @@ examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamA
|
||||
examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
|
||||
= identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
|
||||
where
|
||||
eaocForm =
|
||||
eaocForm =
|
||||
(set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms))
|
||||
<*> pure def
|
||||
|
||||
@ -62,7 +62,7 @@ examAutoOccurrenceNudgeForm occId protoForm html = do
|
||||
(btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html
|
||||
oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
|
||||
oldDataId <- newIdent
|
||||
|
||||
|
||||
let protoForm' = fromMaybe def $ oldDataRes <|> protoForm
|
||||
genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n
|
||||
where n = case btn of
|
||||
@ -83,12 +83,12 @@ examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceCon
|
||||
examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
|
||||
examAutoOccurrenceCalculateWidget tid ssh csh examn = do
|
||||
(formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def
|
||||
|
||||
|
||||
wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
|
||||
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
||||
, formEncoding
|
||||
}
|
||||
|
||||
|
||||
|
||||
postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
postEAutoOccurrenceR tid ssh csh examn = do
|
||||
@ -96,8 +96,8 @@ postEAutoOccurrenceR tid ssh csh examn = do
|
||||
exam@(Entity eId _) <- fetchExam tid ssh csh examn
|
||||
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
|
||||
return (exam, occurrences)
|
||||
|
||||
|
||||
|
||||
|
||||
((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def
|
||||
|
||||
nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
|
||||
|
||||
@ -84,15 +84,15 @@ getECorrectR tid ssh csh examn = do
|
||||
return (exam, entityVal <$> examParts)
|
||||
|
||||
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
|
||||
let
|
||||
heading = prependCourseTitle tid ssh csh $ (mr . MsgExamCorrectHeading . CI.original) examName
|
||||
|
||||
|
||||
ptsInput :: ExamPartNumber -> Widget
|
||||
ptsInput n = do
|
||||
name <- newIdent
|
||||
fieldView (pointsField :: Field Handler Points) ("exam-correct__" <> toPathPiece n) name [("uw-exam-correct--part-input", toPathPiece n)] (Left "") False
|
||||
|
||||
|
||||
examGrades :: [ExamGrade]
|
||||
examGrades = universeF
|
||||
|
||||
@ -111,12 +111,12 @@ postECorrectR tid ssh csh examn = do
|
||||
CorrectInterfaceRequest{..} <- requireCheckJsonBody
|
||||
|
||||
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
|
||||
response <- runDB . exceptT (<$ transactionUndo) return $ do
|
||||
Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
|
||||
euid <- traverse decrypt ciqUser
|
||||
|
||||
guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $
|
||||
guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $
|
||||
CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort)
|
||||
|
||||
|
||||
@ -188,7 +188,7 @@ postECorrectR tid ssh csh examn = do
|
||||
in CorrectInterfaceResponseFailure
|
||||
<$> (Just <$> userToResponse match)
|
||||
<*> (getMessageRender <*> pure msg)
|
||||
|
||||
|
||||
newExamPartResult <- lift $ upsert ExamPartResult
|
||||
{ examPartResultExamPart = examPartId
|
||||
, examPartResultUser = uid
|
||||
@ -230,7 +230,7 @@ postECorrectR tid ssh csh examn = do
|
||||
return $ newResult ^? _entityVal . _examResultResult
|
||||
| otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult
|
||||
| otherwise -> return Nothing
|
||||
|
||||
|
||||
user <- userToResponse match
|
||||
return CorrectInterfaceResponseSuccess
|
||||
{ cirsUser = user
|
||||
@ -252,7 +252,7 @@ postECorrectR tid ssh csh examn = do
|
||||
{ ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants
|
||||
, ciraUsers = Set.fromList users
|
||||
}
|
||||
|
||||
|
||||
let
|
||||
responseStatus = case response of
|
||||
CorrectInterfaceResponseSuccess{} -> ok200
|
||||
@ -261,5 +261,5 @@ postECorrectR tid ssh csh examn = do
|
||||
|
||||
whenM acceptsJson $
|
||||
sendResponseStatus responseStatus $ toJSON response
|
||||
|
||||
|
||||
redirect $ CExamR tid ssh csh examn EShowR
|
||||
|
||||
@ -18,7 +18,7 @@ import Data.Aeson hiding (Result(..))
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
|
||||
instance IsInvitableJunction ExamCorrector where
|
||||
type InvitationFor ExamCorrector = Exam
|
||||
data InvitableJunction ExamCorrector = JunctionExamCorrector
|
||||
|
||||
@ -96,7 +96,7 @@ examForm template html = do
|
||||
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
||||
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
||||
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
||||
<*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
<* aformSection MsgExamFormParts
|
||||
@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let
|
||||
addRes'
|
||||
| otherwise
|
||||
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||
, not $ Set.null existing
|
||||
@ -201,7 +201,7 @@ examPartsForm prev = wFormToAForm $ do
|
||||
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts) False $ Set.toList <$> prev
|
||||
where
|
||||
examPartForm' nudge mPrev csrf = do
|
||||
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
|
||||
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
|
||||
(epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) (fslI MsgExamPartNumber & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
|
||||
(epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamPartName & addName (nudge "name")) (epfName <$> mPrev)
|
||||
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField (fslI MsgExamPartMaxPoints & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
|
||||
@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
|
||||
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
||||
let
|
||||
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
|
||||
| any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
|
||||
| any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
|
||||
-> FormFailure [mr MsgExamPartAlreadyExists]
|
||||
| otherwise -> FormSuccess $ pure newDat
|
||||
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
||||
@ -336,10 +336,10 @@ validateExam = do
|
||||
|
||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||||
guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
|
||||
@ -6,7 +6,7 @@ module Handler.Exam.List
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -75,7 +75,7 @@ mkExamTable (Entity cid Course{..}) = do
|
||||
examDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
& forceFilter "may-read" (Any True)
|
||||
|
||||
|
||||
dbTable examDBTableValidator examDBTable
|
||||
|
||||
|
||||
|
||||
@ -12,7 +12,7 @@ import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
@ -29,7 +29,7 @@ postCExamNewR tid ssh csh = do
|
||||
formResult newExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
|
||||
insertRes <- insertUnique Exam
|
||||
{ examName = efName
|
||||
, examCourse = cid
|
||||
@ -90,7 +90,7 @@ postCExamNewR tid ssh csh = do
|
||||
when didRecord $
|
||||
audit $ TransactionExamResultEdit examid courseParticipantUser
|
||||
runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
|
||||
|
||||
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Nothing -> addMessageI Error $ MsgExamNameTaken efName
|
||||
|
||||
@ -21,7 +21,7 @@ data ButtonExamRegister = BtnExamRegisterOccurrence
|
||||
instance Universe ButtonExamRegister
|
||||
instance Finite ButtonExamRegister
|
||||
nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 2
|
||||
|
||||
|
||||
instance Button UniWorX ButtonExamRegister where
|
||||
btnClasses BtnExamRegisterOccurrence = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnExamSwitchOccurrence = [BCIsButton, BCPrimary]
|
||||
@ -70,7 +70,7 @@ postERegisterOccR tid ssh csh examn occn = do
|
||||
return (eId, occ)
|
||||
|
||||
((btnResult, _), _) <- runFormPost buttonForm
|
||||
|
||||
|
||||
formResult btnResult $ \case
|
||||
BtnExamDeregister -> do
|
||||
runDB $ do
|
||||
@ -89,4 +89,4 @@ postERegisterOccR tid ssh csh examn occn = do
|
||||
_other -> error "Unexpected due to definition of buttonForm'"
|
||||
|
||||
redirect $ CExamR tid ssh csh examn EShowR
|
||||
|
||||
|
||||
|
||||
@ -16,13 +16,13 @@ import Handler.Utils.Invitations
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
|
||||
instance IsInvitableJunction ExamRegistration where
|
||||
type InvitationFor ExamRegistration = Exam
|
||||
@ -98,7 +98,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
(False, True ) -> do
|
||||
fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
|
||||
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $ \cpField -> do
|
||||
void $ upsert
|
||||
@ -110,7 +110,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
]
|
||||
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
|
||||
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
|
||||
|
||||
|
||||
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
|
||||
act <* doAudit
|
||||
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
|
||||
|
||||
@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
sumRegisteredCount = sumOf (folded . _3) occurrences
|
||||
|
||||
noBonus = fromMaybe False $ do
|
||||
noBonus = (Just True ==) $ do
|
||||
guardM $ bonusOnlyPassed <$> examBonusRule
|
||||
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
|
||||
sumPoints = fmap getSum . mconcat $ catMaybes
|
||||
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
|
||||
@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
|
||||
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
||||
|
||||
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
|
||||
$(widgetFile "exam-show")
|
||||
|
||||
@ -88,7 +88,7 @@ queryExamOccurrence = $(sqlLOJproj 6 2)
|
||||
|
||||
queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
|
||||
|
||||
|
||||
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
|
||||
|
||||
@ -184,7 +184,7 @@ csvExamPartHeader = prism' toHeader fromHeader
|
||||
review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
|
||||
|
||||
partPrefix = "part-"
|
||||
|
||||
|
||||
|
||||
data ExamUserTableCsv = ExamUserTableCsv
|
||||
{ csvEUserSurname :: Maybe Text
|
||||
@ -498,7 +498,7 @@ postEUsersR tid ssh csh examn = do
|
||||
[ (epId, (examPart, mbRes))
|
||||
| (Entity epId examPart, mbRes) <- rawResults
|
||||
]
|
||||
|
||||
|
||||
dbtColonnade = mconcat $ catMaybes
|
||||
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
|
||||
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
@ -507,7 +507,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, pure $ colDegreeShort resultStudyDegree
|
||||
, pure $ colFeaturesSemester resultStudyFeatures
|
||||
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
|
||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
|
||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
|
||||
let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
|
||||
SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
|
||||
in propCell (getSum achievedPasses) (getSum numSheetsPasses)
|
||||
@ -516,7 +516,7 @@ postEUsersR tid ssh csh examn = do
|
||||
SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
|
||||
in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
|
||||
, guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
|
||||
, pure $ mconcat
|
||||
, pure $ mconcat
|
||||
[ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
|
||||
| Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
|
||||
]
|
||||
@ -597,7 +597,7 @@ postEUsersR tid ssh csh examn = do
|
||||
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
|
||||
when (is _Just examGradingRule) $
|
||||
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
|
||||
when (not $ null examParts) $
|
||||
unless (null examParts) $
|
||||
tell =<< optionsF [ ExamUserSetPartResult ]
|
||||
when doBonus $
|
||||
tell =<< optionsF [ ExamUserSetBonus ]
|
||||
@ -651,7 +651,7 @@ postEUsersR tid ssh csh examn = do
|
||||
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
||||
yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
|
||||
when (newFeatures /= oldFeatures) $
|
||||
@ -662,10 +662,10 @@ postEUsersR tid ssh csh examn = do
|
||||
iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
|
||||
when (epNumber `elem` examPartNumbers) $
|
||||
yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
|
||||
|
||||
|
||||
when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
|
||||
yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
|
||||
|
||||
|
||||
whenIsJust (csvEUserExamResult dbCsvNew) $ \res -> do
|
||||
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
|
||||
guardResultKind res
|
||||
@ -693,7 +693,7 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
|
||||
newResults = sequence (csvEUserExamPartResults dbCsvNew)
|
||||
<|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
|
||||
<|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
|
||||
|
||||
newBonus, oldBonus :: Maybe Points
|
||||
newBonus = join (csvEUserBonus dbCsvNew)
|
||||
@ -702,7 +702,7 @@ postEUsersR tid ssh csh examn = do
|
||||
newResult, oldResult :: Maybe ExamResultPassedGrade
|
||||
newResult = fmap (fmap $ bool Right (Left . view passingGrade) $ is _ExamGradingGrades examGradingMode) . examGrade examVal (newBonus <|> oldBonus) =<< newResults
|
||||
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
|
||||
|
||||
|
||||
when doBonus $
|
||||
case newBonus of
|
||||
_ | newBonus == oldBonus
|
||||
@ -715,7 +715,7 @@ postEUsersR tid ssh csh examn = do
|
||||
-> yield $ ExamUserCsvSetBonusData False uid newBonus
|
||||
Just _
|
||||
-> yield $ ExamUserCsvSetBonusData True uid newBonus
|
||||
|
||||
|
||||
case newResult of
|
||||
_ | csvEUserExamResult dbCsvNew == oldResult
|
||||
-> return ()
|
||||
@ -964,15 +964,15 @@ postEUsersR tid ssh csh examn = do
|
||||
| is (_ExamAttended . _Left) res -> ExamGradingPass
|
||||
| otherwise -> ExamGradingGrades
|
||||
| otherwise = return ()
|
||||
|
||||
|
||||
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
|
||||
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
||||
where
|
||||
Entity _ User{..} = view resultUser $ existing ! registration
|
||||
|
||||
|
||||
guessUser' :: ExamUserTableCsv -> DB (Bool, UserId)
|
||||
guessUser' ExamUserTableCsv{..} = do
|
||||
let criteria = Set.fromList $ catMaybes
|
||||
let criteria = Set.fromList $ catMaybes
|
||||
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
|
||||
, GuessUserDisplayName <$> csvEUserName
|
||||
, GuessUserSurname <$> csvEUserSurname
|
||||
@ -1088,7 +1088,7 @@ postEUsersR tid ssh csh examn = do
|
||||
audit $ TransactionExamBonusEdit eId uid
|
||||
| otherwise
|
||||
-> return ()
|
||||
|
||||
|
||||
insert_ ExamResult
|
||||
{ examResultExam = eId
|
||||
, examResultUser = uid
|
||||
|
||||
@ -28,7 +28,7 @@ getCExamOfficeR = postCExamOfficeR
|
||||
postCExamOfficeR tid ssh csh = do
|
||||
uid <- requireAuthId
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
|
||||
|
||||
(cid, optOuts, hasForced) <- runDB $ do
|
||||
cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh)
|
||||
optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] []
|
||||
@ -65,7 +65,7 @@ postCExamOfficeR tid ssh csh = do
|
||||
setTitleI MsgMenuCourseExamOffice
|
||||
|
||||
let explanation = $(i18nWidgetFile "course-exam-office-explanation")
|
||||
|
||||
|
||||
[whamlet|
|
||||
$newline never
|
||||
<section>
|
||||
|
||||
@ -34,7 +34,7 @@ embedRenderMessage ''UniWorX ''ButtonCloseExam id
|
||||
instance Button UniWorX ButtonCloseExam where
|
||||
btnClasses BtnCloseExam = [BCIsButton]
|
||||
|
||||
|
||||
|
||||
examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget
|
||||
examCloseWidget dest eId = do
|
||||
Exam{..} <- runDB $ get404 eId
|
||||
@ -47,7 +47,7 @@ examCloseWidget dest eId = do
|
||||
|
||||
unless (is _Nothing examClosed) $
|
||||
invalidArgs ["Exam is already closed"]
|
||||
|
||||
|
||||
runDB $ update eId [ ExamClosed =. Just now ]
|
||||
addMessageI Success MsgExamDidClose
|
||||
redirect dest
|
||||
@ -189,7 +189,7 @@ newtype ExamUserCsvExportData = ExamUserCsvExportData
|
||||
{ csvEUserMarkSynchronised :: Bool
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
|
||||
-- | View a list of all users' grades that the current user has access to
|
||||
getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEGradesR = postEGradesR
|
||||
@ -271,7 +271,7 @@ postEGradesR tid ssh csh examn = do
|
||||
|
||||
E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid
|
||||
|
||||
unless isLecturer $
|
||||
unless isLecturer $
|
||||
E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
|
||||
|
||||
return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
|
||||
@ -314,9 +314,9 @@ postEGradesR tid ssh csh examn = do
|
||||
syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange]
|
||||
++ [ Left lastChange ]
|
||||
++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]
|
||||
|
||||
|
||||
syncIcon :: Widget
|
||||
syncIcon
|
||||
syncIcon
|
||||
| not isSynced
|
||||
, not hasSyncs
|
||||
= mempty
|
||||
@ -324,7 +324,7 @@ postEGradesR tid ssh csh examn = do
|
||||
= toWidget iconNotOK
|
||||
| otherwise
|
||||
= toWidget iconOK
|
||||
|
||||
|
||||
syncsModal :: Widget
|
||||
syncsModal = $(widgetFile "exam-office/exam-result-synced")
|
||||
lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon
|
||||
|
||||
@ -30,7 +30,7 @@ queryExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 1)
|
||||
|
||||
queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course)))
|
||||
queryCourse = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 1)
|
||||
|
||||
|
||||
queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam)))
|
||||
queryExternalExam = to $(E.sqlFOJproj 2 2)
|
||||
|
||||
@ -48,7 +48,7 @@ querySynchronised office = to . runReader $ do
|
||||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
||||
E.where_ $ ExternalExam.resultIsSynced office externalExamResult
|
||||
return $ E.maybe (E.val 0) examSynchronised (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalExamSynchronised (externalExam' E.?. ExternalExamId)
|
||||
|
||||
|
||||
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
|
||||
queryResults office = to . runReader $ do
|
||||
exam' <- view queryExam
|
||||
@ -75,7 +75,7 @@ queryIsSynced now office = to . runReader $ do
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
||||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
||||
E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
|
||||
open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed'
|
||||
open examClosed' = E.maybe E.true (E.>. E.val now) examClosed'
|
||||
return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
|
||||
|
||||
|
||||
@ -95,7 +95,7 @@ resultResults = _dbrOutput . _3
|
||||
resultIsSynced :: Getter ExamsTableData Bool
|
||||
resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
|
||||
|
||||
|
||||
|
||||
-- | List of all exams where the current user may (in her function as
|
||||
-- exam-office) access users grades
|
||||
getEOExamsR :: Handler Html
|
||||
@ -106,15 +106,15 @@ getEOExamsR = do
|
||||
examsTable <- runDB $ do
|
||||
let
|
||||
examLink :: Course -> Exam -> SomeRoute UniWorX
|
||||
examLink Course{..} Exam{..}
|
||||
examLink Course{..} Exam{..}
|
||||
= SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR
|
||||
|
||||
courseLink :: Course -> SomeRoute UniWorX
|
||||
courseLink Course{..}
|
||||
= SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
|
||||
externalExamLink :: ExternalExam -> SomeRoute UniWorX
|
||||
externalExamLink ExternalExam{..}
|
||||
externalExamLink ExternalExam{..}
|
||||
= SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR
|
||||
|
||||
querySynchronised' = querySynchronised $ E.val uid
|
||||
@ -150,11 +150,9 @@ getEOExamsR = do
|
||||
|
||||
case (exam, course, externalExam) of
|
||||
(Just exam', Just course', Nothing) ->
|
||||
(,,)
|
||||
<$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Nothing, Nothing, Just externalExam') ->
|
||||
(,,)
|
||||
<$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
_other -> return $ error "Got exam & externalExam in same result"
|
||||
|
||||
|
||||
@ -182,7 +180,7 @@ getEOExamsR = do
|
||||
& cellAttrs <>~ [ ("class", "heated")
|
||||
, ("style", [st|--hotness: #{tshow (heat results synced)}|])
|
||||
]
|
||||
|
||||
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
@ -192,7 +190,7 @@ getEOExamsR = do
|
||||
)
|
||||
$ emptyOpticColonnade (resultExam . _entityVal . _examName <> resultExternalExam . _entityVal . _externalExamExamName) colExamName
|
||||
, emptyOpticColonnade (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) colExamTime
|
||||
, emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice
|
||||
, emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice
|
||||
, emptyOpticColonnade (resultExam . _entityVal . _examClosed) colExamClosed
|
||||
, maybeAnchorColonnade (previews (resultCourse . _entityVal) courseLink)
|
||||
$ emptyOpticColonnade (resultCourse . _entityVal . _courseName <> resultExternalExam . _entityVal . _externalExamCourseName) colCourseName
|
||||
|
||||
@ -7,7 +7,7 @@ import Import
|
||||
import Handler.Utils
|
||||
|
||||
import Handler.Utils.ExternalExam.Users
|
||||
|
||||
|
||||
getEEGradesR, postEEGradesR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html
|
||||
getEEGradesR = postEEGradesR
|
||||
postEEGradesR tid ssh coursen examn = do
|
||||
|
||||
@ -11,7 +11,7 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
|
||||
data ExamOfficeFieldMode
|
||||
= EOFNotSubscribed
|
||||
| EOFSubscribed
|
||||
@ -78,7 +78,7 @@ postEOFieldsR = do
|
||||
oldFields <- runDB $ do
|
||||
fields <- E.select . E.from $ \examOfficeField -> do
|
||||
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
|
||||
return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
||||
return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
||||
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
|
||||
|
||||
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
|
||||
|
||||
@ -21,7 +21,7 @@ import qualified Data.Map as Map
|
||||
import Data.Map ((!), (!?))
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
|
||||
instance IsInvitableJunction ExamOfficeUser where
|
||||
type InvitationFor ExamOfficeUser = User
|
||||
@ -84,11 +84,11 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
|
||||
return $ SomeMessage MsgExamOfficeUserInvitationAccepted
|
||||
invitationUltDest _ _ = return $ SomeRoute NewsR
|
||||
|
||||
|
||||
|
||||
makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
|
||||
makeExamOfficeUsersForm template = renderWForm FormStandard $ do
|
||||
cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
|
||||
let
|
||||
miAdd' :: (Text -> Text)
|
||||
-> FieldView UniWorX
|
||||
@ -132,7 +132,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
|
||||
return $ map Left invitations ++ map Right knownUsers'
|
||||
|
||||
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
|
||||
|
||||
|
||||
|
||||
-- | Manage the list of users this user (in her function as exam-office)
|
||||
-- has an interest in, i.e. that authorize her to view their grades
|
||||
|
||||
@ -39,7 +39,7 @@ postEEEditR tid ssh coursen examn = do
|
||||
, eefOfficeSchools = schools
|
||||
, eefStaff = staff
|
||||
}
|
||||
|
||||
|
||||
((examResult, examWidget'), examEnctype) <- runFormPost . externalExamForm $ Just template
|
||||
|
||||
formResult examResult $ \ExternalExamForm{..} -> do
|
||||
@ -54,7 +54,7 @@ postEEEditR tid ssh coursen examn = do
|
||||
}
|
||||
when (is _Nothing replaceRes) $ do
|
||||
audit $ TransactionExternalExamEdit eeId
|
||||
|
||||
|
||||
forM_ (eefStaff `setSymmDiff` staff) $ \change -> if
|
||||
| change `Set.member` eefStaff -> case change of
|
||||
Left invEmail -> do
|
||||
|
||||
@ -5,7 +5,7 @@ module Handler.ExternalExam.Form
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
import Handler.ExternalExam.StaffInvite ()
|
||||
|
||||
import qualified Data.Set as Set
|
||||
@ -104,7 +104,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
|
||||
validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExternalExamForm m ()
|
||||
validateExternalExam = do
|
||||
State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool)
|
||||
|
||||
|
||||
ExternalExamForm{..} <- State.get
|
||||
|
||||
isAdmin <- hasWriteAccessTo $ SchoolR eefSchool SchoolEditR
|
||||
|
||||
@ -3,7 +3,7 @@ module Handler.ExternalExam.List
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -24,7 +24,7 @@ getEExamListR = do
|
||||
|
||||
queryEExam = $(E.sqlIJproj 2 1)
|
||||
querySchool = $(E.sqlIJproj 2 2)
|
||||
|
||||
|
||||
dbtSQLQuery (eexam `E.InnerJoin` school) = do
|
||||
E.on $ eexam E.^. ExternalExamSchool E.==. school E.^. SchoolId
|
||||
let
|
||||
|
||||
@ -32,7 +32,7 @@ postEExamNewR = do
|
||||
}
|
||||
whenIsJust insertRes $ \eeId -> do
|
||||
audit $ TransactionExternalExamEdit eeId
|
||||
|
||||
|
||||
let eefOfficeSchools' = do
|
||||
externalExamOfficeSchoolSchool <- Set.toList eefOfficeSchools
|
||||
guard $ externalExamOfficeSchoolSchool /= eefSchool
|
||||
@ -41,7 +41,7 @@ postEExamNewR = do
|
||||
insertMany_ eefOfficeSchools'
|
||||
forM_ eefOfficeSchools' $ \ExternalExamOfficeSchool{..} ->
|
||||
audit $ TransactionExternalExamOfficeSchoolEdit eeId externalExamOfficeSchoolSchool
|
||||
|
||||
|
||||
let (invites, adds) = partitionEithers $ Set.toList eefStaff
|
||||
eefStaff' = do
|
||||
externalExamStaffUser <- adds
|
||||
@ -50,7 +50,7 @@ postEExamNewR = do
|
||||
insertMany_ eefStaff'
|
||||
forM_ eefStaff' $ \ExternalExamStaff{..} ->
|
||||
audit $ TransactionExternalExamStaffEdit eeId externalExamStaffUser
|
||||
|
||||
|
||||
sinkInvitationsF externalExamStaffInvitationConfig $ map (, eeId, (InvDBDataExternalExamStaff, InvTokenDataExternalExamStaff)) invites
|
||||
forM_ invites $ \invEmail ->
|
||||
audit $ TransactionExternalExamStaffInviteEdit eeId invEmail
|
||||
|
||||
@ -10,7 +10,7 @@ import qualified Data.Map as Map
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
|
||||
|
||||
data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
|
||||
deriving (Eq, Ord, Bounded, Enum, Show, Read)
|
||||
@ -58,7 +58,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
|
||||
Nothing -> return $ pure Nothing
|
||||
Just err ->
|
||||
let prettyErr = decodeUtf8 $ Yaml.encode err
|
||||
in optionalActionW
|
||||
in optionalActionW
|
||||
(err <$ aforced textareaField (fslI MsgHelpError) (Textarea prettyErr))
|
||||
(fslI MsgHelpSendLastError)
|
||||
(Just True)
|
||||
@ -69,7 +69,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
|
||||
<*> hfSubject'
|
||||
<*> hfRequest'
|
||||
<*> hfError'
|
||||
|
||||
|
||||
validateHelpForm :: FormValidator HelpForm Handler ()
|
||||
validateHelpForm = do
|
||||
HelpForm{..} <- State.get
|
||||
@ -99,7 +99,7 @@ postHelpR = do
|
||||
|
||||
whenIsJust hfError $ \error' ->
|
||||
modifySessionJson SessionError $ assertM (/= error')
|
||||
|
||||
|
||||
tell . pure =<< messageI Success MsgHelpSent
|
||||
|
||||
defaultLayout $ do
|
||||
@ -111,5 +111,5 @@ postHelpR = do
|
||||
}
|
||||
|
||||
mFaqs <- (>>= \(mWgt, truncated) -> (, truncated) <$> mWgt) <$> traverse (faqsWidget $ Just 5) (Just <$> mReferer)
|
||||
|
||||
|
||||
$(widgetFile "help")
|
||||
|
||||
@ -53,7 +53,7 @@ getInfoLecturerR =
|
||||
$(i18nWidgetFile "info-lecturer")
|
||||
where
|
||||
allocationInfo = $(i18nWidgetFile "allocation-info")
|
||||
|
||||
|
||||
tooltipNew, tooltipProblem, tooltipPlanned, tooltipNewU2W :: WidgetFor UniWorX ()
|
||||
tooltipNew = [whamlet| _{MsgLecturerInfoTooltipNew} |]
|
||||
tooltipProblem = [whamlet| _{MsgLecturerInfoTooltipProblem} |]
|
||||
@ -64,7 +64,7 @@ getInfoLecturerR =
|
||||
probFeatInline = [whamlet| ^{iconTooltip tooltipProblem (Just IconProblem) True} |] -- to be used inside text blocks
|
||||
plannedFeat = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) False} |]
|
||||
plannedFeatInline = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) True} |] -- to be used inside text blocks
|
||||
|
||||
|
||||
-- new feature with given introduction date
|
||||
newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
|
||||
newFeat year month day = do
|
||||
|
||||
@ -21,7 +21,7 @@ data MaterialForm = MaterialForm
|
||||
, mfType :: Maybe (CI Text)
|
||||
, mfDescription :: Maybe Html
|
||||
, mfVisibleFrom :: Maybe UTCTime
|
||||
, mfFiles :: Maybe FileUploads
|
||||
, mfFiles :: Maybe FileUploads
|
||||
}
|
||||
|
||||
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
|
||||
@ -135,7 +135,7 @@ getMaterialListR tid ssh csh = do
|
||||
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
|
||||
]
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) dbr
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) dbr
|
||||
-> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
@ -347,4 +347,4 @@ getMArchiveR tid ssh csh mnm = do
|
||||
return materialFile
|
||||
|
||||
serveSomeFiles archiveName getMatQuery
|
||||
|
||||
|
||||
|
||||
@ -28,7 +28,7 @@ getMetricsR = selectRep $ do
|
||||
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
|
||||
|
||||
encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
|
||||
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI MsgTitleMetrics
|
||||
$(widgetFile "metrics")
|
||||
|
||||
@ -29,7 +29,7 @@ getNewsR = do
|
||||
|
||||
when (is _Nothing muid) $
|
||||
notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch")
|
||||
|
||||
|
||||
case muid of
|
||||
Just uid -> do
|
||||
newsUpcomingExams uid
|
||||
@ -51,7 +51,7 @@ newsSystemMessages = do
|
||||
mkHideForm smId SystemMessage{..} = liftHandler $ do
|
||||
cID <- encrypt smId
|
||||
hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
|
||||
|
||||
|
||||
(btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
|
||||
return $ wrapForm btnView def
|
||||
{ formSubmit = FormNoSubmit
|
||||
@ -65,7 +65,7 @@ newsSystemMessages = do
|
||||
tell $ Any hidden
|
||||
|
||||
return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden)
|
||||
|
||||
|
||||
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
|
||||
transPipe lift (selectKeys [] [])
|
||||
.| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
|
||||
@ -87,7 +87,7 @@ newsUpcomingSheets :: UserId -> Widget
|
||||
newsUpcomingSheets uid = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime
|
||||
|
||||
|
||||
let tableData :: E.LeftOuterJoin
|
||||
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
|
||||
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
|
||||
@ -104,12 +104,12 @@ newsUpcomingSheets uid = do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||||
|
||||
let showSheetNoActiveTo =
|
||||
let showSheetNoActiveTo =
|
||||
E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom)
|
||||
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom)
|
||||
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom)
|
||||
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)
|
||||
|
||||
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
|
||||
|
||||
@ -35,7 +35,7 @@ instance ToNamedRecord ParticipantEntry where
|
||||
|
||||
instance DefaultOrdered ParticipantEntry where
|
||||
headerOrder _ = Csv.header ["course", "email"]
|
||||
|
||||
|
||||
|
||||
getParticipantsListR :: Handler Html
|
||||
getParticipantsListR = do
|
||||
@ -52,10 +52,10 @@ getParticipantsListR = do
|
||||
|
||||
schoolTerms' <- flip filterM schoolTerms'' $ \(E.Value ssh, E.Value tid) ->
|
||||
hasReadAccessTo $ ParticipantsR tid ssh
|
||||
|
||||
|
||||
let schoolTerms :: Set (SchoolId, TermId)
|
||||
schoolTerms = setOf (folded . $(multifocusG 2) (_1 . _Value) (_2 . _Value)) schoolTerms'
|
||||
|
||||
|
||||
siteLayoutMsg MsgMenuParticipantsList $ do
|
||||
setTitleI MsgMenuParticipantsList
|
||||
|
||||
|
||||
@ -227,7 +227,7 @@ notificationForm template = wFormToAForm $ do
|
||||
validateSettings :: User -> FormValidator SettingsForm Handler ()
|
||||
validateSettings User{..} = do
|
||||
userDisplayName' <- use _stgDisplayName
|
||||
|
||||
|
||||
guardValidation MsgUserDisplayNameInvalid $
|
||||
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
||||
|
||||
@ -812,7 +812,7 @@ postSetDisplayEmailR = do
|
||||
siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do
|
||||
setTitleI MsgTitleChangeUserDisplayEmail
|
||||
$(i18nWidgetFile "set-display-email")
|
||||
|
||||
|
||||
getCsvOptionsR, postCsvOptionsR :: Handler Html
|
||||
getCsvOptionsR = postCsvOptionsR
|
||||
postCsvOptionsR = do
|
||||
|
||||
@ -8,14 +8,14 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
|
||||
getSchoolListR :: Handler Html
|
||||
getSchoolListR = do
|
||||
let
|
||||
schoolLink :: SchoolId -> SomeRoute UniWorX
|
||||
schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR
|
||||
|
||||
|
||||
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
|
||||
dbtSQLQuery = return
|
||||
|
||||
@ -49,7 +49,7 @@ getSchoolListR = do
|
||||
|
||||
psValidator = def
|
||||
& defaultSorting [SortAscBy "school-name"]
|
||||
|
||||
|
||||
|
||||
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
@ -89,7 +89,7 @@ getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
|
||||
getSchoolEditR = postSchoolEditR
|
||||
postSchoolEditR ssh = do
|
||||
sForm <- runDB $ schoolToForm ssh
|
||||
|
||||
|
||||
((sfResult, sfView), sfEnctype) <- runFormPost sForm
|
||||
|
||||
formResult sfResult $ \SchoolForm{..} -> do
|
||||
|
||||
@ -19,7 +19,7 @@ import Handler.Sheet.Download as Handler.Sheet
|
||||
import Handler.Sheet.New as Handler.Sheet
|
||||
import Handler.Sheet.Show as Handler.Sheet
|
||||
|
||||
|
||||
|
||||
getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet!
|
||||
getSIsCorrR _ _ _ shn =
|
||||
|
||||
@ -6,7 +6,7 @@ module Handler.Sheet.Current
|
||||
import Import
|
||||
|
||||
import Utils.Sheet
|
||||
|
||||
|
||||
|
||||
getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Void
|
||||
getSheetCurrentR tid ssh csh = do
|
||||
|
||||
@ -43,7 +43,7 @@ getSArchiveR tid ssh csh shn = do
|
||||
E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId
|
||||
E.&&. sFile E.^. SheetFileType E.==. E.val sft
|
||||
return . E.max_ $ sFile E.^. SheetFileModified
|
||||
|
||||
|
||||
serveZipArchive archiveName $ do
|
||||
forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile
|
||||
{ sheetFileType = sft
|
||||
|
||||
@ -112,11 +112,11 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
|
||||
deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
|
||||
sinkInvitationsF correctorInvitationConfig invites
|
||||
|
||||
|
||||
return True
|
||||
when saveOkay $
|
||||
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
||||
(FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
||||
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module Handler.Sheet.Form
|
||||
( SheetForm(..), Loads
|
||||
, makeSheetForm
|
||||
, getFtIdMap
|
||||
, getFtIdMap
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -44,7 +44,7 @@ data SheetForm = SheetForm
|
||||
-- Keine SheetId im Formular!
|
||||
}
|
||||
|
||||
|
||||
|
||||
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
|
||||
getFtIdMap sId = do
|
||||
allSheetFiles <- E.select . E.from $ \sheetFile -> do
|
||||
@ -88,16 +88,16 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
||||
<*> correctorForm (maybe mempty sfCorrectors template)
|
||||
where
|
||||
validateSheet :: FormValidator SheetForm Handler ()
|
||||
validateSheet = do
|
||||
SheetForm{..} <- State.get
|
||||
|
||||
guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo
|
||||
guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo
|
||||
guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo
|
||||
guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo
|
||||
|
||||
guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom
|
||||
|
||||
@ -113,7 +113,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
||||
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
|
||||
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads
|
||||
|
||||
|
||||
let
|
||||
@ -124,7 +124,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
return user
|
||||
|
||||
miAdd :: ListPosition
|
||||
@ -150,7 +150,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
miCell _ userIdent initRes nudge csrf = do
|
||||
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
||||
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
let
|
||||
res :: FormResult (CorrectorState, Load)
|
||||
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
||||
@ -202,7 +202,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
|
||||
postProcess = Map.fromList . map postProcess' . Map.elems
|
||||
where
|
||||
where
|
||||
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
|
||||
postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
|
||||
|
||||
|
||||
@ -76,7 +76,7 @@ getSheetListR tid ssh csh = do
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
|
||||
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
|
||||
case mbSub of
|
||||
Nothing -> cellTell mempty $ stats Nothing
|
||||
|
||||
@ -11,6 +11,8 @@ import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient)
|
||||
import qualified Data.Binary as Binary (encode)
|
||||
import qualified Crypto.KDF.HKDF as HKDF
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
data StorageKeyType
|
||||
= SKTExamCorrect
|
||||
@ -64,7 +66,7 @@ postStorageKeyR = do
|
||||
timestamp = if
|
||||
| Just ts <- skReqTimestamp, timestampInBounds -> ts
|
||||
| otherwise -> now
|
||||
|
||||
|
||||
salt <- let sltSize = hashDigestSize SHA3_256 in if
|
||||
| Just slt <- Base64.decodeLenient . encodeUtf8 <$> skReqSalt
|
||||
, timestampInBounds
|
||||
|
||||
@ -32,7 +32,7 @@ import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
|
||||
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionOwnR tid ssh csh shn = do
|
||||
authId <- requireAuthId
|
||||
|
||||
@ -3,7 +3,7 @@ module Handler.Submission.Assign
|
||||
, getCAssignR, postCAssignR
|
||||
, getSAssignR, postSAssignR
|
||||
) where
|
||||
|
||||
|
||||
import Import hiding (link, unzip)
|
||||
|
||||
import Handler.Utils hiding (colSchool)
|
||||
@ -74,7 +74,7 @@ postSAssignR tid ssh csh shn = do
|
||||
assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
|
||||
assignHandler tid ssh csh cid assignSids = do
|
||||
currentRoute <- fromMaybe (error "assignHandler called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
|
||||
|
||||
-- gather data
|
||||
(orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, ((btnViews, btnCsrf), btnEncoding)) <- runDB $ do
|
||||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
@ -97,7 +97,7 @@ assignHandler tid ssh csh cid assignSids = do
|
||||
assignSheetNames' = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids'
|
||||
|
||||
assignButtons = Map.fromSet (maybe BtnSubmissionsAssignAll BtnSubmissionsAssign) $ Set.fromList . bool (Nothing :) id (null sheetList) $ map Just assignSheetNames'
|
||||
|
||||
|
||||
((btnResult, btnViews'), btnEncoding) <- runFormPost . identifyForm FIDAssignSubmissions $ \csrf ->
|
||||
fmap (over _1 (asum . fmap (hoistMaybe =<<)) . over _2 (, csrf) . unzip) . for assignButtons $ \btn -> mopt (buttonField btn) "" Nothing
|
||||
|
||||
@ -132,7 +132,7 @@ assignHandler tid ssh csh cid assignSids = do
|
||||
| otherwise -> do
|
||||
addMessageI Error $ MsgSheetsUnassignable $ CI.original shn
|
||||
return Nothing
|
||||
if | null sub_ok && null sub_fail ->
|
||||
if | null sub_ok && null sub_fail ->
|
||||
return $ Map.insert shn (status, countMapElems plan, deficit) acc
|
||||
| otherwise -> do
|
||||
(plan', deficit') <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
|
||||
@ -280,7 +280,7 @@ assignHandler tid ssh csh cid assignSids = do
|
||||
|
||||
doWrap $(widgetFile "corrections-overview")
|
||||
|
||||
|
||||
|
||||
data ButtonSubmissionsAssign
|
||||
= BtnSubmissionsAssign SheetName
|
||||
| BtnSubmissionsAssignAll
|
||||
|
||||
@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case results of
|
||||
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
||||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||||
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
|
||||
pointsForm = case sheetType of
|
||||
NotGraded
|
||||
-> pure Nothing
|
||||
@ -67,7 +67,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
| not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
|
||||
| otherwise = wFormToAForm $ do
|
||||
let correctors = E.from $ \user -> do
|
||||
let isCorrector = E.exists . E.from $ \sheetCorrector ->
|
||||
let isCorrector = E.exists . E.from $ \sheetCorrector ->
|
||||
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId
|
||||
isLecturer' = E.exists . E.from $ \lecturer ->
|
||||
@ -151,7 +151,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
|
||||
getCorrectionUserR tid ssh csh shn cid = do
|
||||
|
||||
|
||||
|
||||
sub <- decrypt cid
|
||||
|
||||
results <- runDB $ correctionData tid ssh csh shn sub
|
||||
|
||||
@ -104,9 +104,9 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
submittorsForm' = maybeT submittorsForm $ do
|
||||
restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
|
||||
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
|
||||
submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
||||
submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
||||
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
|
||||
|
||||
|
||||
|
||||
submittorsForm
|
||||
| isLecturer = do -- Form is being used by lecturer; allow Everything™
|
||||
@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
guard $ Map.size dat > 1
|
||||
|
||||
-- User may drop from submission only if it already exists; no directly creating submissions for other people
|
||||
guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid
|
||||
guard $ Just (Right uid) /= dat !? delPos || isJust msmid
|
||||
|
||||
miDeleteList dat delPos
|
||||
|
||||
@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
|
||||
corrector <- fmap join $ traverse getEntity submissionRatingBy
|
||||
corrector <- join <$> traverse getEntity submissionRatingBy
|
||||
|
||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
|
||||
|
||||
@ -336,9 +336,9 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
when ( is _Nothing muid
|
||||
&& is _Nothing msubmission
|
||||
&& not isLecturer
|
||||
)
|
||||
)
|
||||
notAuthenticated
|
||||
|
||||
|
||||
-- Determine old submission users
|
||||
subUsersOld <- if
|
||||
| Just smid <- msmid -> Set.union
|
||||
@ -411,7 +411,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
}
|
||||
audit $ TransactionSubmissionEdit sid shid
|
||||
return sid
|
||||
|
||||
|
||||
-- Determine new submission users
|
||||
subUsers <- if
|
||||
| isLecturer -> return adhocMembers
|
||||
@ -461,7 +461,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
audit $ TransactionSubmissionUserDelete smid subUid
|
||||
unless (Just subUid == muid) $
|
||||
queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid
|
||||
|
||||
|
||||
addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated
|
||||
| otherwise -> MsgSubmissionUpdated
|
||||
return smid
|
||||
@ -558,7 +558,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
courseSchool = ssh
|
||||
courseShorthand = csh
|
||||
in $(widgetFile "correction-user")
|
||||
|
||||
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
||||
|
||||
@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
|
||||
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
||||
NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
|
||||
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
@ -201,7 +201,7 @@ colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (Form
|
||||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
|
||||
|
||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
@ -398,11 +398,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
||||
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in any (\c -> c `isInfixOf` cid) criteria'
|
||||
in any (`isInfixOf` cid) criteria'
|
||||
)
|
||||
]
|
||||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
|
||||
, dbtParams
|
||||
, dbtIdent = "corrections" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
||||
-- return (tableRes, statistics)
|
||||
|
||||
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||
let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
<&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
||||
|
||||
formResult actionRes $ \case
|
||||
@ -610,7 +610,7 @@ assignAction selId = ( CorrSetCorrector
|
||||
|
||||
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
|
||||
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
|
||||
E.distinct $ return user
|
||||
|
||||
|
||||
@ -15,7 +15,7 @@ import Text.Hamlet (ihamlet)
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
|
||||
instance IsInvitableJunction SubmissionUser where
|
||||
type InvitationFor SubmissionUser = Submission
|
||||
data InvitableJunction SubmissionUser = JunctionSubmissionUser
|
||||
|
||||
@ -31,7 +31,7 @@ explainSubmissionDoneMode SubmissionDoneNever = return $(i18nWidgetFile "submis
|
||||
explainSubmissionDoneMode SubmissionDoneAlways = return $(i18nWidgetFile "submission-done-tip/always")
|
||||
explainSubmissionDoneMode SubmissionDoneByFile = return $(i18nWidgetFile "submission-done-tip/by-file")
|
||||
|
||||
|
||||
|
||||
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||||
getCorrectionsUploadR = postCorrectionsUploadR
|
||||
postCorrectionsUploadR = do
|
||||
|
||||
@ -57,9 +57,8 @@ postMessageR cID = do
|
||||
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
||||
$ (,)
|
||||
<$> fmap (Entity tId)
|
||||
( SystemMessageTranslation
|
||||
<$> pure systemMessageTranslationMessage
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||
( SystemMessageTranslation systemMessageTranslationMessage
|
||||
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
|
||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
|
||||
)
|
||||
@ -71,9 +70,8 @@ postMessageR cID = do
|
||||
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
|
||||
|
||||
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
||||
$ SystemMessageTranslation
|
||||
<$> pure smId
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||
$ SystemMessageTranslation smId
|
||||
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
|
||||
|
||||
|
||||
@ -40,13 +40,13 @@ guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart
|
||||
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd
|
||||
= fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5
|
||||
where longYear = is _Just $ fromWeekDateValid year 53 1
|
||||
(_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
(_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart
|
||||
= fromWeekDate year (wWeekStart + 2) 1
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
|
||||
= fromWeekDate year (wWeekStart + 17) 5
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
|
||||
|
||||
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
|
||||
@ -68,7 +68,7 @@ postTEditR tid ssh csh tutn = do
|
||||
}
|
||||
when (is _Nothing insertRes) $ do
|
||||
audit $ TransactionTutorialEdit tutid
|
||||
|
||||
|
||||
let (invites, adds) = partitionEithers $ Set.toList tfTutors
|
||||
|
||||
deleteWhere [ TutorTutorial ==. tutid ]
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user