refactor: hlint
This commit is contained in:
Gregor Kleen
parent
7512420131
commit
0fcb65f9fa
@ -46,7 +46,7 @@ sqlInTuple arity = do
|
|||||||
xsV <- newName "xs"
|
xsV <- newName "xs"
|
||||||
|
|
||||||
let
|
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
|
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)|])|]
|
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)|])|]
|
||||||
|
|||||||
@ -24,7 +24,7 @@ persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
|
|||||||
persistDirectoryWith settings dir = do
|
persistDirectoryWith settings dir = do
|
||||||
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
|
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
|
||||||
fn <- MaybeT . return . fromNullable $ takeFileName fp
|
fn <- MaybeT . return . fromNullable $ takeFileName fp
|
||||||
guard . not $ head fn == '.'
|
guard $ head fn /= '.'
|
||||||
guard . not $ head fn == '#' && last fn == '#'
|
guard . not $ head fn == '#' && last fn == '#'
|
||||||
|
|
||||||
lift $ do
|
lift $ do
|
||||||
|
|||||||
@ -15,7 +15,8 @@ import Foundation.Routes as Foundation
|
|||||||
|
|
||||||
|
|
||||||
import Import.NoFoundation hiding (embedFile)
|
import Import.NoFoundation hiding (embedFile)
|
||||||
import Database.Persist.Sql (runSqlPool)
|
import Database.Persist.Sql
|
||||||
|
( runSqlPool, transactionUndo, SqlReadBackend(..) )
|
||||||
import Text.Hamlet (hamletFile)
|
import Text.Hamlet (hamletFile)
|
||||||
|
|
||||||
import Yesod.Auth.Message
|
import Yesod.Auth.Message
|
||||||
@ -105,7 +106,6 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
|||||||
import Web.Cookie
|
import Web.Cookie
|
||||||
|
|
||||||
import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild))
|
import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild))
|
||||||
import Database.Persist.Sql (transactionUndo, SqlReadBackend(..))
|
|
||||||
|
|
||||||
import qualified Control.Retry as Retry
|
import qualified Control.Retry as Retry
|
||||||
import GHC.IO.Exception (IOErrorType(OtherError))
|
import GHC.IO.Exception (IOErrorType(OtherError))
|
||||||
@ -635,7 +635,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
|
|||||||
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||||
Submission{..} <- MaybeT . lift $ get sid
|
Submission{..} <- MaybeT . lift $ get sid
|
||||||
guard $ maybe False (== authId) submissionRatingBy
|
guard $ Just authId == submissionRatingBy
|
||||||
return Authorized
|
return Authorized
|
||||||
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||||
@ -742,7 +742,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|||||||
-> guard $ visible
|
-> guard $ visible
|
||||||
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
||||||
ERegisterOccR occn -> do
|
ERegisterOccR occn -> do
|
||||||
occId <- (>>= hoistMaybe) . $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
||||||
if
|
if
|
||||||
| (registration >>= examRegistrationOccurrence . entityVal) == Just occId
|
| (registration >>= examRegistrationOccurrence . entityVal) == Just occId
|
||||||
-> guard $ visible
|
-> guard $ visible
|
||||||
@ -879,7 +879,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|||||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||||
guard $ NTop systemMessageFrom <= cTime
|
guard $ NTop systemMessageFrom <= cTime
|
||||||
&& NTop systemMessageTo >= cTime
|
&& NTop systemMessageTo >= cTime
|
||||||
return Authorized
|
return Authorized
|
||||||
@ -887,7 +887,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|||||||
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||||
guard $ NTop systemMessageFrom <= cTime
|
guard $ NTop systemMessageFrom <= cTime
|
||||||
&& NTop systemMessageTo >= cTime
|
&& NTop systemMessageTo >= cTime
|
||||||
return Authorized
|
return Authorized
|
||||||
@ -895,7 +895,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
|||||||
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
|
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
|
||||||
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||||
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
|
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
|
||||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||||
guard $ NTop courseNewsVisibleFrom <= cTime
|
guard $ NTop courseNewsVisibleFrom <= cTime
|
||||||
return Authorized
|
return Authorized
|
||||||
|
|
||||||
@ -1195,7 +1195,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
|||||||
when onlyActive $
|
when onlyActive $
|
||||||
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||||
-- participant has at least one submission
|
-- 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
|
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 $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
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.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
-- participant is member of a submissionGroup
|
-- 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
|
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 $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||||
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
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.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
-- participant is a tutorial user
|
-- 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
|
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 $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
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.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
-- participant has an exam result for this course
|
-- 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
|
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 $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
||||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
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.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
-- participant is registered for an exam for this course
|
-- 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
|
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 $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||||
@ -1271,8 +1271,6 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
|||||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
|
|
||||||
return ()
|
|
||||||
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
|
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
|
||||||
CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
|
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
|
||||||
@ -1628,10 +1626,10 @@ instance Yesod UniWorX where
|
|||||||
|
|
||||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||||
SessionStorageMemcachedSql sqlStore
|
SessionStorageMemcachedSql sqlStore
|
||||||
-> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
|
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||||
SessionStorageAcid acidStore
|
SessionStorageAcid acidStore
|
||||||
| appServerSessionAcidFallback
|
| appServerSessionAcidFallback
|
||||||
-> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
|
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||||
_other
|
_other
|
||||||
-> return Nothing
|
-> return Nothing
|
||||||
where
|
where
|
||||||
@ -1664,7 +1662,7 @@ instance Yesod UniWorX where
|
|||||||
notForBearer' (SessionBackend load)
|
notForBearer' (SessionBackend load)
|
||||||
= let load' req
|
= let load' req
|
||||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders 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 [])
|
= return (mempty, const $ return [])
|
||||||
| otherwise
|
| otherwise
|
||||||
= load req
|
= load req
|
||||||
@ -1893,7 +1891,7 @@ updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
|
|||||||
updateFavourites cData = void . runMaybeT $ do
|
updateFavourites cData = void . runMaybeT $ do
|
||||||
$logDebugS "updateFavourites" "Updating favourites"
|
$logDebugS "updateFavourites" "Updating favourites"
|
||||||
|
|
||||||
now <- liftIO $ getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
uid <- MaybeT $ liftHandler maybeAuthId
|
uid <- MaybeT $ liftHandler maybeAuthId
|
||||||
mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||||
User{userMaxFavourites} <- MaybeT $ get uid
|
User{userMaxFavourites} <- MaybeT $ get uid
|
||||||
@ -2403,7 +2401,7 @@ instance YesodBreadcrumbs UniWorX where
|
|||||||
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
|
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
|
||||||
mr <- getMessageRender
|
mr <- getMessageRender
|
||||||
Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
|
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
|
ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
|
||||||
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
|
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
|
||||||
cid <- decrypt cID
|
cid <- decrypt cID
|
||||||
@ -3578,14 +3576,13 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return
|
|||||||
case muid of
|
case muid of
|
||||||
Nothing -> return False
|
Nothing -> return False
|
||||||
(Just uid) -> do
|
(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 $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||||
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
return ok
|
|
||||||
, navType = NavTypeLink { navModal = False }
|
, navType = NavTypeLink { navModal = False }
|
||||||
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
||||||
, navForceActive = False
|
, navForceActive = False
|
||||||
@ -4373,19 +4370,19 @@ pageHeading UsersR
|
|||||||
= Just $ i18nHeading MsgUsers
|
= Just $ i18nHeading MsgUsers
|
||||||
pageHeading (AdminUserR _)
|
pageHeading (AdminUserR _)
|
||||||
= Just $ i18nHeading MsgAdminUserHeading
|
= Just $ i18nHeading MsgAdminUserHeading
|
||||||
pageHeading (AdminTestR)
|
pageHeading AdminTestR
|
||||||
= Just $ [whamlet|Internal Code Demonstration Page|]
|
= Just [whamlet|Internal Code Demonstration Page|]
|
||||||
pageHeading (AdminErrMsgR)
|
pageHeading AdminErrMsgR
|
||||||
= Just $ i18nHeading MsgErrMsgHeading
|
= Just $ i18nHeading MsgErrMsgHeading
|
||||||
|
|
||||||
pageHeading (InfoR)
|
pageHeading InfoR
|
||||||
= Just $ i18nHeading MsgInfoHeading
|
= Just $ i18nHeading MsgInfoHeading
|
||||||
pageHeading (LegalR)
|
pageHeading LegalR
|
||||||
= Just $ i18nHeading MsgLegalHeading
|
= Just $ i18nHeading MsgLegalHeading
|
||||||
pageHeading (VersionR)
|
pageHeading VersionR
|
||||||
= Just $ i18nHeading MsgVersionHeading
|
= Just $ i18nHeading MsgVersionHeading
|
||||||
|
|
||||||
pageHeading (HelpR)
|
pageHeading HelpR
|
||||||
= Just $ i18nHeading MsgHelpRequest
|
= Just $ i18nHeading MsgHelpRequest
|
||||||
|
|
||||||
pageHeading ProfileR
|
pageHeading ProfileR
|
||||||
@ -4408,8 +4405,8 @@ pageHeading (TermSchoolCourseListR tid ssh)
|
|||||||
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
|
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
|
||||||
i18nHeading $ MsgTermSchoolCourseListHeading tid school
|
i18nHeading $ MsgTermSchoolCourseListHeading tid school
|
||||||
|
|
||||||
pageHeading (CourseListR)
|
pageHeading CourseListR
|
||||||
= Just $ i18nHeading $ MsgCourseListTitle
|
= Just $ i18nHeading MsgCourseListTitle
|
||||||
pageHeading CourseNewR
|
pageHeading CourseNewR
|
||||||
= Just $ i18nHeading MsgCourseNewHeading
|
= Just $ i18nHeading MsgCourseNewHeading
|
||||||
pageHeading (CourseR tid ssh csh CShowR)
|
pageHeading (CourseR tid ssh csh CShowR)
|
||||||
@ -4608,7 +4605,7 @@ runSqlPoolRetry action pool = do
|
|||||||
runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
|
runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
|
||||||
runDBRead action = do
|
runDBRead action = do
|
||||||
$logDebugS "YesodPersist" "runDBRead"
|
$logDebugS "YesodPersist" "runDBRead"
|
||||||
runSqlPoolRetry (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod
|
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
|
||||||
|
|
||||||
-- How to run database actions.
|
-- How to run database actions.
|
||||||
instance YesodPersist UniWorX where
|
instance YesodPersist UniWorX where
|
||||||
@ -4622,7 +4619,7 @@ instance YesodPersist UniWorX where
|
|||||||
| dryRun = action <* transactionUndo
|
| dryRun = action <* transactionUndo
|
||||||
| otherwise = action
|
| otherwise = action
|
||||||
|
|
||||||
runSqlPoolRetry action' =<< appConnPool <$> getYesod
|
runSqlPoolRetry action' . appConnPool =<< getYesod
|
||||||
|
|
||||||
instance YesodPersistRunner UniWorX where
|
instance YesodPersistRunner UniWorX where
|
||||||
getDBRunner = do
|
getDBRunner = do
|
||||||
@ -4852,7 +4849,7 @@ upsertCampusUser plugin ldapData = do
|
|||||||
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
||||||
let matchingFeatures = case knownParents of
|
let matchingFeatures = case knownParents of
|
||||||
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
[] -> 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{..} ->
|
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||||
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||||
if
|
if
|
||||||
@ -4911,12 +4908,12 @@ upsertCampusUser plugin ldapData = do
|
|||||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||||
oldFs <- selectKeysList
|
oldFs <- selectKeysList
|
||||||
([ StudyFeaturesUser ==. studyFeaturesUser
|
[ StudyFeaturesUser ==. studyFeaturesUser
|
||||||
, StudyFeaturesDegree ==. studyFeaturesDegree
|
, StudyFeaturesDegree ==. studyFeaturesDegree
|
||||||
, StudyFeaturesField ==. studyFeaturesField
|
, StudyFeaturesField ==. studyFeaturesField
|
||||||
, StudyFeaturesType ==. studyFeaturesType
|
, StudyFeaturesType ==. studyFeaturesType
|
||||||
, StudyFeaturesSemester ==. studyFeaturesSemester
|
, StudyFeaturesSemester ==. studyFeaturesSemester
|
||||||
])
|
]
|
||||||
[]
|
[]
|
||||||
case oldFs of
|
case oldFs of
|
||||||
[oldF] -> update oldF
|
[oldF] -> update oldF
|
||||||
@ -4933,7 +4930,7 @@ upsertCampusUser plugin ldapData = do
|
|||||||
associateUserSchoolsByTerms userId
|
associateUserSchoolsByTerms userId
|
||||||
|
|
||||||
let
|
let
|
||||||
userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
|
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
|
||||||
userAssociatedSchools' = do
|
userAssociatedSchools' = do
|
||||||
(k, v) <- ldapData
|
(k, v) <- ldapData
|
||||||
guard $ k == ldapUserSchoolAssociation
|
guard $ k == ldapUserSchoolAssociation
|
||||||
@ -4946,7 +4943,7 @@ upsertCampusUser plugin ldapData = do
|
|||||||
forM_ ss $ \frag -> void . runMaybeT $ do
|
forM_ ss $ \frag -> void . runMaybeT $ do
|
||||||
let
|
let
|
||||||
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
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.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
||||||
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
||||||
return schoolLdap
|
return schoolLdap
|
||||||
@ -5092,7 +5089,7 @@ instance YesodAuth UniWorX where
|
|||||||
_other
|
_other
|
||||||
-> acceptExisting
|
-> acceptExisting
|
||||||
|
|
||||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
|
||||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||||
, dummyLogin <$ guard appAuthDummyLogin
|
, dummyLogin <$ guard appAuthDummyLogin
|
||||||
|
|||||||
@ -47,8 +47,8 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
|
|||||||
modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
|
modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
|
||||||
|
|
||||||
return $ TestDownloadOptions
|
return $ TestDownloadOptions
|
||||||
<$> pure randomSeed
|
randomSeed
|
||||||
<*> maxSizeRes
|
<$> maxSizeRes
|
||||||
<*> pure (2^20)
|
<*> pure (2^20)
|
||||||
<*> modeRes
|
<*> modeRes
|
||||||
|
|
||||||
|
|||||||
@ -64,7 +64,7 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill
|
|||||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
instance Exception ApplicationFormException
|
instance Exception ApplicationFormException
|
||||||
|
|
||||||
applicationForm :: (Maybe AllocationId)
|
applicationForm :: Maybe AllocationId
|
||||||
-> CourseId
|
-> CourseId
|
||||||
-> UserId
|
-> UserId
|
||||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||||
@ -75,7 +75,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
|||||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||||
course <- getJust cid
|
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.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||||
@ -105,7 +105,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
|||||||
|
|
||||||
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
||||||
(True , True , True , Nothing)
|
(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 _ )
|
(True , True , True , Just _ )
|
||||||
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
||||||
(True , True , False, _ )
|
(True , True , False, _ )
|
||||||
@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
|||||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||||
|
|
||||||
filesLinkView <- if
|
filesLinkView <- if
|
||||||
| fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||||
-> let filesLinkField = Field{..}
|
-> let filesLinkField = Field{..}
|
||||||
where
|
where
|
||||||
fieldParse _ _ = return $ Right Nothing
|
fieldParse _ _ = return $ Right Nothing
|
||||||
@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
|||||||
-> return Nothing
|
-> return Nothing
|
||||||
|
|
||||||
filesWarningView <- if
|
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
|
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
|
||||||
| otherwise
|
| otherwise
|
||||||
-> return Nothing
|
-> return Nothing
|
||||||
@ -174,15 +174,15 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
|||||||
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||||
in if
|
in if
|
||||||
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
|
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
|
||||||
-> return $ (FormSuccess Nothing, Nothing)
|
-> return (FormSuccess Nothing, Nothing)
|
||||||
| otherwise
|
| otherwise
|
||||||
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
||||||
|
|
||||||
(vetoRes, vetoView) <- if
|
(vetoRes, vetoView) <- if
|
||||||
| afmLecturer
|
| 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
|
| otherwise
|
||||||
-> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
|
-> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
|
||||||
|
|
||||||
(pointsRes, pointsView) <- if
|
(pointsRes, pointsView) <- if
|
||||||
| afmLecturer
|
| afmLecturer
|
||||||
@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
|||||||
, courseApplicationRatingTime = guardOn rated now
|
, 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
|
audit $ TransactionCourseApplicationEdit cid uid appId
|
||||||
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
|
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
|
||||||
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
|
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
|
||||||
|
|||||||
@ -134,7 +134,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
|||||||
, not $ Set.null existing
|
, not $ Set.null existing
|
||||||
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
||||||
| otherwise
|
| 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")
|
addView' = $(widgetFile "course/lecturerMassInput/add")
|
||||||
return (addRes'', addView')
|
return (addRes'', addView')
|
||||||
|
|
||||||
@ -194,9 +194,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
|||||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
||||||
_allIOtherCases -> do
|
_allIOtherCases -> do
|
||||||
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
||||||
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
return ( Just . toMidnight . termStart . entityVal <$> mbLastTerm
|
||||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
|
||||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm )
|
||||||
|
|
||||||
let
|
let
|
||||||
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
||||||
@ -238,7 +238,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
|||||||
|
|
||||||
let
|
let
|
||||||
userAdmin = not $ null adminSchools
|
userAdmin = not $ null adminSchools
|
||||||
mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
|
mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
|
||||||
|
|
||||||
allocationForm' =
|
allocationForm' =
|
||||||
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
||||||
@ -260,8 +260,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
|||||||
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
|
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
|
||||||
|
|
||||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||||
<$> pure (cfCourseId =<< template)
|
(cfCourseId =<< template)
|
||||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||||
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
|
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
|
||||||
-- & addAttr "disabled" "disabled"
|
-- & addAttr "disabled" "disabled"
|
||||||
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
||||||
@ -322,7 +322,7 @@ validateCourse = do
|
|||||||
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
||||||
$ NTop cfRegFrom <= NTop cfRegTo
|
$ NTop cfRegFrom <= NTop cfRegTo
|
||||||
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
||||||
$ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
|
$ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
|
||||||
unless userAdmin $
|
unless userAdmin $
|
||||||
guardValidation MsgCourseUserMustBeLecturer
|
guardValidation MsgCourseUserMustBeLecturer
|
||||||
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
||||||
@ -521,7 +521,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
|||||||
insert_ $ CourseEdit aid now cid
|
insert_ $ CourseEdit aid now cid
|
||||||
|
|
||||||
let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
|
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
|
upsertAllocationCourse cid $ cfAllocation res
|
||||||
|
|
||||||
|
|||||||
@ -34,7 +34,7 @@ postCNEditR tid ssh csh cID = do
|
|||||||
, courseNewsLastEdit = now
|
, courseNewsLastEdit = now
|
||||||
}
|
}
|
||||||
let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
|
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
|
addMessageI Success MsgCourseNewsEdited
|
||||||
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||||
|
|
||||||
|
|||||||
@ -96,7 +96,7 @@ participantInvitationConfig = InvitationConfig{..}
|
|||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
(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
|
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
|
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
||||||
res <- act -- insertUnique
|
res <- act -- insertUnique
|
||||||
|
|||||||
@ -112,7 +112,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
|||||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||||
|
|
||||||
when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
|
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
|
||||||
let filesLinkField = Field{..}
|
let filesLinkField = Field{..}
|
||||||
where
|
where
|
||||||
fieldParse _ _ = return $ Right Nothing
|
fieldParse _ _ = return $ Right Nothing
|
||||||
@ -130,7 +130,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
|||||||
|]
|
|]
|
||||||
in void $ wforced filesLinkField (fslI filesMsg) Nothing
|
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
|
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
|
||||||
|
|
||||||
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||||
|
|||||||
@ -110,9 +110,8 @@ getCShowR tid ssh csh = do
|
|||||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||||
|
|
||||||
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
|
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
|
||||||
<$> pure alloc
|
<$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
|
||||||
regForm <- if
|
regForm <- if
|
||||||
| is _Just mbAid -> do
|
| is _Just mbAid -> do
|
||||||
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
||||||
|
|||||||
@ -197,7 +197,7 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
|
|||||||
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
|
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
|
||||||
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
|
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 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
|
_other -> mempty
|
||||||
|
|
||||||
|
|
||||||
@ -387,33 +387,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
|||||||
, single $ sortUserEmail queryUser
|
, single $ sortUserEmail queryUser
|
||||||
, single $ sortUserMatriclenr queryUser
|
, single $ sortUserMatriclenr queryUser
|
||||||
, sortUserSex (to queryUser . to (E.^. UserSex))
|
, sortUserSex (to queryUser . to (E.^. UserSex))
|
||||||
, single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
, single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||||
, single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
, single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||||
, single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
, single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||||
, single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
, single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||||
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
, single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||||
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||||
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||||
E.subSelectMaybe . E.from $ \edit -> do
|
E.subSelectMaybe . E.from $ \edit -> do
|
||||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
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.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
||||||
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
||||||
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
||||||
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
||||||
return . E.min_ $ tutorial E.^. TutorialName
|
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.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||||
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
||||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||||
return . E.min_ $ exam E.^. ExamName
|
return . E.min_ $ exam E.^. ExamName
|
||||||
)
|
)
|
||||||
, single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
, single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||||
, single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
, single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||||
, mconcat
|
, mconcat
|
||||||
[ single ( SortingKey $ "sheet-" <> sheetName
|
[ single ( SortingKey $ "sheet-" <> sheetName
|
||||||
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||||
@ -433,38 +433,38 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
|||||||
, single $ fltrUserMatriclenr queryUser
|
, single $ fltrUserMatriclenr queryUser
|
||||||
, single $ fltrUserNameEmail queryUser
|
, single $ fltrUserNameEmail queryUser
|
||||||
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
||||||
, single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
, single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||||
, single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
, single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||||
, single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
, single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||||
, single $ ("field" , FilterColumn $ E.anyFilter
|
, single ("field" , FilterColumn $ E.anyFilter
|
||||||
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
||||||
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
||||||
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
, 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.?. StudyDegreeName)
|
||||||
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
||||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||||
] )
|
] )
|
||||||
, single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
, single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||||
, single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
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.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
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.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
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.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||||
E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
|
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 ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||||
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
, single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||||
]
|
]
|
||||||
where single = uncurry Map.singleton
|
where single = uncurry Map.singleton
|
||||||
dbtFilterUI mPrev = mconcat $
|
dbtFilterUI mPrev = mconcat $
|
||||||
@ -615,7 +615,7 @@ postCUsersR tid ssh csh = do
|
|||||||
hasExams = not $ null exams
|
hasExams = not $ null exams
|
||||||
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
|
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
|
||||||
examOccActs = examOccurrencesPerExam
|
examOccActs = examOccurrencesPerExam
|
||||||
& (map (bimap entityKey hoistMaybe))
|
& map (bimap entityKey hoistMaybe)
|
||||||
& Map.fromListWith (<>)
|
& Map.fromListWith (<>)
|
||||||
& imap (\k v -> case v of
|
& imap (\k v -> case v of
|
||||||
[] -> pure (k, Nothing)
|
[] -> pure (k, Nothing)
|
||||||
|
|||||||
@ -96,7 +96,7 @@ examForm template html = do
|
|||||||
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
||||||
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
||||||
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
||||||
<*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
|
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||||
<* aformSection MsgExamFormCorrection
|
<* aformSection MsgExamFormCorrection
|
||||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||||
<* aformSection MsgExamFormParts
|
<* 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
|
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||||
let
|
let
|
||||||
addRes'
|
addRes'
|
||||||
| otherwise
|
|
||||||
= addRes <&> \newDat oldDat -> if
|
= addRes <&> \newDat oldDat -> if
|
||||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||||
, not $ Set.null existing
|
, not $ Set.null existing
|
||||||
@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
|
|||||||
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
||||||
let
|
let
|
||||||
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
|
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]
|
-> FormFailure [mr MsgExamPartAlreadyExists]
|
||||||
| otherwise -> FormSuccess $ pure newDat
|
| otherwise -> FormSuccess $ pure newDat
|
||||||
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
||||||
@ -336,10 +336,10 @@ validateExam = do
|
|||||||
|
|
||||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||||
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= 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 MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
|
||||||
guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
|
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
|
||||||
|
|
||||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||||
|
|||||||
@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
|
|||||||
|
|
||||||
sumRegisteredCount = sumOf (folded . _3) occurrences
|
sumRegisteredCount = sumOf (folded . _3) occurrences
|
||||||
|
|
||||||
noBonus = fromMaybe False $ do
|
noBonus = (Just True ==) $ do
|
||||||
guardM $ bonusOnlyPassed <$> examBonusRule
|
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
|
sumPoints = fmap getSum . mconcat $ catMaybes
|
||||||
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
|
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
|
||||||
@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
|
|||||||
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
||||||
|
|
||||||
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
|
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")
|
$(widgetFile "exam-show")
|
||||||
|
|||||||
@ -597,7 +597,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
|
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
|
||||||
when (is _Just examGradingRule) $
|
when (is _Just examGradingRule) $
|
||||||
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
|
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
|
||||||
when (not $ null examParts) $
|
unless (null examParts) $
|
||||||
tell =<< optionsF [ ExamUserSetPartResult ]
|
tell =<< optionsF [ ExamUserSetPartResult ]
|
||||||
when doBonus $
|
when doBonus $
|
||||||
tell =<< optionsF [ ExamUserSetBonus ]
|
tell =<< optionsF [ ExamUserSetBonus ]
|
||||||
@ -651,7 +651,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
||||||
if
|
if
|
||||||
| isPart -> do
|
| isPart -> do
|
||||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
|
||||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||||
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
|
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
|
||||||
when (newFeatures /= oldFeatures) $
|
when (newFeatures /= oldFeatures) $
|
||||||
@ -693,7 +693,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
|
|
||||||
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
|
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
|
||||||
newResults = sequence (csvEUserExamPartResults dbCsvNew)
|
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, oldBonus :: Maybe Points
|
||||||
newBonus = join (csvEUserBonus dbCsvNew)
|
newBonus = join (csvEUserBonus dbCsvNew)
|
||||||
|
|||||||
@ -75,7 +75,7 @@ queryIsSynced now office = to . runReader $ do
|
|||||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
||||||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
||||||
E.where_ . E.not_ $ ExternalExam.resultIsSynced 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)
|
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)
|
||||||
|
|
||||||
|
|
||||||
@ -150,11 +150,9 @@ getEOExamsR = do
|
|||||||
|
|
||||||
case (exam, course, externalExam) of
|
case (exam, course, externalExam) of
|
||||||
(Just exam', Just course', Nothing) ->
|
(Just exam', Just course', Nothing) ->
|
||||||
(,,)
|
(Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||||
<$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
|
||||||
(Nothing, Nothing, Just externalExam') ->
|
(Nothing, Nothing, Just externalExam') ->
|
||||||
(,,)
|
(Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||||
<$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
|
|
||||||
_other -> return $ error "Got exam & externalExam in same result"
|
_other -> return $ error "Got exam & externalExam in same result"
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -78,7 +78,7 @@ postEOFieldsR = do
|
|||||||
oldFields <- runDB $ do
|
oldFields <- runDB $ do
|
||||||
fields <- E.select . E.from $ \examOfficeField -> do
|
fields <- E.select . E.from $ \examOfficeField -> do
|
||||||
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
|
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
|
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
|
||||||
|
|
||||||
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
|
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
|
||||||
|
|||||||
@ -116,7 +116,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
|||||||
return True
|
return True
|
||||||
when saveOkay $
|
when saveOkay $
|
||||||
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
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) <-
|
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||||
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
||||||
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
||||||
|
|||||||
@ -88,7 +88,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
|||||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
<*> correctorForm (maybe mempty sfCorrectors template)
|
||||||
where
|
where
|
||||||
validateSheet :: FormValidator SheetForm Handler ()
|
validateSheet :: FormValidator SheetForm Handler ()
|
||||||
validateSheet = do
|
validateSheet = do
|
||||||
@ -113,7 +113,7 @@ correctorForm loads' = wFormToAForm $ do
|
|||||||
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
||||||
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, 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
|
let
|
||||||
@ -124,7 +124,7 @@ correctorForm loads' = wFormToAForm $ do
|
|||||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val 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
|
return user
|
||||||
|
|
||||||
miAdd :: ListPosition
|
miAdd :: ListPosition
|
||||||
@ -150,7 +150,7 @@ correctorForm loads' = wFormToAForm $ do
|
|||||||
miCell _ userIdent initRes nudge csrf = do
|
miCell _ userIdent initRes nudge csrf = do
|
||||||
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
(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
|
(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
|
let
|
||||||
res :: FormResult (CorrectorState, Load)
|
res :: FormResult (CorrectorState, Load)
|
||||||
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
||||||
|
|||||||
@ -11,6 +11,8 @@ import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient)
|
|||||||
import qualified Data.Binary as Binary (encode)
|
import qualified Data.Binary as Binary (encode)
|
||||||
import qualified Crypto.KDF.HKDF as HKDF
|
import qualified Crypto.KDF.HKDF as HKDF
|
||||||
|
|
||||||
|
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||||
|
|
||||||
|
|
||||||
data StorageKeyType
|
data StorageKeyType
|
||||||
= SKTExamCorrect
|
= SKTExamCorrect
|
||||||
|
|||||||
@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do
|
|||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
case results of
|
case results of
|
||||||
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
[(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
|
pointsForm = case sheetType of
|
||||||
NotGraded
|
NotGraded
|
||||||
-> pure Nothing
|
-> pure Nothing
|
||||||
|
|||||||
@ -104,7 +104,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
|||||||
submittorsForm' = maybeT submittorsForm $ do
|
submittorsForm' = maybeT submittorsForm $ do
|
||||||
restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
|
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
|
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
|
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
|
||||||
|
|
||||||
|
|
||||||
@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
|||||||
guard $ Map.size dat > 1
|
guard $ Map.size dat > 1
|
||||||
|
|
||||||
-- User may drop from submission only if it already exists; no directly creating submissions for other people
|
-- 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
|
miDeleteList dat delPos
|
||||||
|
|
||||||
@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do
|
|||||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
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)
|
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
|
||||||
|
|
||||||
|
|||||||
@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (
|
|||||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
|
(\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)
|
_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)
|
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 :: 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 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))
|
(\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) ->
|
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
||||||
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
||||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||||
in any (\c -> c `isInfixOf` cid) criteria'
|
in any (`isInfixOf` cid) criteria'
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
|
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
|
||||||
, dbtParams
|
, dbtParams
|
||||||
, dbtIdent = "corrections" :: Text
|
, dbtIdent = "corrections" :: Text
|
||||||
, dbtCsvEncode = noCsvEncode
|
, dbtCsvEncode = noCsvEncode
|
||||||
@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
|||||||
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
||||||
-- return (tableRes, statistics)
|
-- return (tableRes, statistics)
|
||||||
|
|
||||||
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||||
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
<&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||||
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
||||||
|
|
||||||
formResult actionRes $ \case
|
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.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
|
E.distinct $ return user
|
||||||
|
|
||||||
|
|||||||
@ -57,9 +57,8 @@ postMessageR cID = do
|
|||||||
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
||||||
$ (,)
|
$ (,)
|
||||||
<$> fmap (Entity tId)
|
<$> fmap (Entity tId)
|
||||||
( SystemMessageTranslation
|
( SystemMessageTranslation systemMessageTranslationMessage
|
||||||
<$> pure systemMessageTranslationMessage
|
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
|
||||||
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
|
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
|
||||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
|
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
|
||||||
)
|
)
|
||||||
@ -71,9 +70,8 @@ postMessageR cID = do
|
|||||||
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
|
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
|
||||||
|
|
||||||
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
||||||
$ SystemMessageTranslation
|
$ SystemMessageTranslation smId
|
||||||
<$> pure smId
|
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
|
||||||
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
||||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
|
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
|
||||||
|
|
||||||
|
|||||||
@ -43,7 +43,7 @@ tutorialForm cid template html = do
|
|||||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser . Just $ tutUserSuggestions uid) (fslI MsgTutorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser . Just $ tutUserSuggestions uid) (fslI MsgTutorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||||
let
|
let
|
||||||
addRes'
|
addRes'
|
||||||
| otherwise
|
|
||||||
= addRes <&> \newDat oldDat -> if
|
= addRes <&> \newDat oldDat -> if
|
||||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||||
, not $ Set.null existing
|
, not $ Set.null existing
|
||||||
|
|||||||
@ -74,7 +74,7 @@ getUsersR = postUsersR
|
|||||||
postUsersR = do
|
postUsersR = do
|
||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
let
|
let
|
||||||
dbtColonnade = mconcat $
|
dbtColonnade = mconcat
|
||||||
[ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
|
[ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
|
||||||
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||||
(AdminUserR <$> encrypt uid)
|
(AdminUserR <$> encrypt uid)
|
||||||
@ -233,7 +233,7 @@ postUsersR = do
|
|||||||
formResult allUsersRes $ \case
|
formResult allUsersRes $ \case
|
||||||
AllUsersLdapSync -> do
|
AllUsersLdapSync -> do
|
||||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||||
addMessageI Success $ MsgSynchroniseLdapAllUsersQueued
|
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||||
redirect UsersR
|
redirect UsersR
|
||||||
let allUsersWgt' = wrapForm allUsersWgt def
|
let allUsersWgt' = wrapForm allUsersWgt def
|
||||||
{ formSubmit = FormNoSubmit
|
{ formSubmit = FormNoSubmit
|
||||||
@ -569,7 +569,7 @@ functionInvitationConfig = InvitationConfig{..}
|
|||||||
itStartsAt = Nothing
|
itStartsAt = Nothing
|
||||||
return InvitationTokenConfig{..}
|
return InvitationTokenConfig{..}
|
||||||
invitationRestriction _ _ = return Authorized
|
invitationRestriction _ _ = return Authorized
|
||||||
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
|
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ())
|
||||||
invitationInsertHook _ _ _ _ _ = id
|
invitationInsertHook _ _ _ _ _ = id
|
||||||
invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
|
invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
|
||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
|||||||
@ -19,7 +19,7 @@ import qualified Database.Esqueleto.Utils as E
|
|||||||
import Control.Monad.Trans.State (execStateT)
|
import Control.Monad.Trans.State (execStateT)
|
||||||
import qualified Control.Monad.State.Class as State (get, modify')
|
import qualified Control.Monad.State.Class as State (get, modify')
|
||||||
|
|
||||||
import Data.List (genericLength, elemIndex)
|
import Data.List (genericLength)
|
||||||
import qualified Data.Vector as Vector
|
import qualified Data.Vector as Vector
|
||||||
import Data.Vector.Lens (vector)
|
import Data.Vector.Lens (vector)
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
@ -201,7 +201,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
|
|||||||
withNumericGrade :: Rational -> Rational
|
withNumericGrade :: Rational -> Rational
|
||||||
withNumericGrade
|
withNumericGrade
|
||||||
| Just grade' <- grade
|
| Just grade' <- grade
|
||||||
= let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
= let numberGrade' = maybe (error "non-passing grade") fromIntegral (elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||||
passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
|
passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
|
||||||
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
|
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
|
||||||
in (+) numericGrade
|
in (+) numericGrade
|
||||||
@ -244,7 +244,7 @@ doAllocation :: AllocationId
|
|||||||
-> DB ()
|
-> DB ()
|
||||||
doAllocation allocId now regs =
|
doAllocation allocId now regs =
|
||||||
forM_ regs $ \(uid, cid) -> do
|
forM_ regs $ \(uid, cid) -> do
|
||||||
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||||
void $ upsert
|
void $ upsert
|
||||||
(CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
|
(CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
|
||||||
[ CourseParticipantRegistration =. now
|
[ CourseParticipantRegistration =. now
|
||||||
|
|||||||
@ -151,7 +151,7 @@ encodeCsv hdr = do
|
|||||||
| otherwise
|
| otherwise
|
||||||
= encodeLazyByteString enc . decodeLazyByteString UTF8
|
= encodeLazyByteString enc . decodeLazyByteString UTF8
|
||||||
where enc = csvOpts ^. _csvFormat . _csvEncoding
|
where enc = csvOpts ^. _csvFormat . _csvEncoding
|
||||||
fmap (encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy . recode'
|
C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr
|
||||||
|
|
||||||
timestampCsv :: ( MonadHandler m
|
timestampCsv :: ( MonadHandler m
|
||||||
, HandlerSite m ~ UniWorX
|
, HandlerSite m ~ UniWorX
|
||||||
|
|||||||
@ -175,7 +175,7 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM
|
|||||||
]
|
]
|
||||||
, do
|
, do
|
||||||
guard $ uncurry (/=) amPm
|
guard $ uncurry (/=) amPm
|
||||||
guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm]
|
guard . not $ all (all Char.isLower) [fst amPm, snd amPm]
|
||||||
Just
|
Just
|
||||||
[ DateTimeFormat "%I:%M %P"
|
[ DateTimeFormat "%I:%M %P"
|
||||||
, DateTimeFormat "%I:%M:%S %P"
|
, DateTimeFormat "%I:%M:%S %P"
|
||||||
|
|||||||
@ -367,7 +367,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
|||||||
wordMap = Map.fromListWith (+) wordLengths
|
wordMap = Map.fromListWith (+) wordLengths
|
||||||
|
|
||||||
wordIx :: Iso' wordId Int
|
wordIx :: Iso' wordId Int
|
||||||
wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords
|
wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords
|
||||||
in ix'
|
in ix'
|
||||||
)
|
)
|
||||||
(collapsedWords Array.!)
|
(collapsedWords Array.!)
|
||||||
|
|||||||
@ -34,7 +34,7 @@ sourceFile FileReference{..} = do
|
|||||||
-> maybeT (throwM SourceFilesContentUnavailable) $ do
|
-> maybeT (throwM SourceFilesContentUnavailable) $ do
|
||||||
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
|
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
|
||||||
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
|
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
|
||||||
fmap Just . (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
|
fmap Just . hoistMaybe <=< runAppMinio . runMaybeT $ do
|
||||||
objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
|
objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
|
||||||
lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
|
lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
|
||||||
| fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent
|
| fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent
|
||||||
|
|||||||
@ -22,7 +22,7 @@ import Handler.Utils.I18n
|
|||||||
import Handler.Utils.Files
|
import Handler.Utils.Files
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Data.Char (chr, ord)
|
import Data.Char ( chr, ord, isDigit )
|
||||||
import qualified Data.Char as Char
|
import qualified Data.Char as Char
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
@ -55,8 +55,6 @@ import Data.Aeson.Text (encodeToLazyText)
|
|||||||
import qualified Text.Email.Validate as Email
|
import qualified Text.Email.Validate as Email
|
||||||
|
|
||||||
import Data.Text.Lens (unpacked)
|
import Data.Text.Lens (unpacked)
|
||||||
|
|
||||||
import Data.Char (isDigit)
|
|
||||||
import Text.Blaze (toMarkup)
|
import Text.Blaze (toMarkup)
|
||||||
|
|
||||||
import Handler.Utils.Form.MassInput
|
import Handler.Utils.Form.MassInput
|
||||||
@ -64,6 +62,8 @@ import Handler.Utils.Form.MassInput
|
|||||||
import qualified Data.Binary as Binary
|
import qualified Data.Binary as Binary
|
||||||
import qualified Data.ByteString.Base64.URL as Base64
|
import qualified Data.ByteString.Base64.URL as Base64
|
||||||
|
|
||||||
|
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||||
|
|
||||||
|
|
||||||
----------------------------
|
----------------------------
|
||||||
-- Buttons (new version ) --
|
-- Buttons (new version ) --
|
||||||
@ -289,11 +289,11 @@ multiActionOpts' minp acts mActsOpts fs defAction csrf = do
|
|||||||
actsOpts <- liftHandler mActsOpts
|
actsOpts <- liftHandler mActsOpts
|
||||||
let actsOpts' = OptionList
|
let actsOpts' = OptionList
|
||||||
{ olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
|
{ olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
|
||||||
, olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
|
, olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts
|
||||||
}
|
}
|
||||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
|
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
|
||||||
|
|
||||||
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
||||||
actExternal = fmap optionExternalValue . actOption
|
actExternal = fmap optionExternalValue . actOption
|
||||||
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
||||||
|
|
||||||
@ -400,10 +400,10 @@ explainedMultiAction' :: forall action a.
|
|||||||
explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
|
explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
|
||||||
(actsOpts, actsReadExternal) <- liftHandler mActsOpts
|
(actsOpts, actsReadExternal) <- liftHandler mActsOpts
|
||||||
let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
|
let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
|
||||||
actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal
|
actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal
|
||||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
|
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
|
||||||
|
|
||||||
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
||||||
actExternal = fmap optionExternalValue . actOption
|
actExternal = fmap optionExternalValue . actOption
|
||||||
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
||||||
|
|
||||||
@ -463,7 +463,7 @@ pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
|
|||||||
pointsField = pointsFieldMinMax (Just 0) Nothing
|
pointsField = pointsFieldMinMax (Just 0) Nothing
|
||||||
|
|
||||||
pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
|
pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
|
||||||
pointsFieldMax limit = pointsFieldMinMax (Just 0) limit
|
pointsFieldMax = pointsFieldMinMax (Just 0)
|
||||||
|
|
||||||
pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
|
pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
|
||||||
pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
|
pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
|
||||||
@ -795,7 +795,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
|
|||||||
|
|
||||||
let errors
|
let errors
|
||||||
| anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
|
| anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
|
||||||
| FormSuccess bounds' <- sequence $ map (view _1) bounds
|
| FormSuccess bounds' <- mapM (view _1) bounds
|
||||||
, not $ monotone bounds'
|
, not $ monotone bounds'
|
||||||
= [mr MsgPointsMustBeMonotonic]
|
= [mr MsgPointsMustBeMonotonic]
|
||||||
| otherwise
|
| otherwise
|
||||||
@ -967,7 +967,7 @@ genericFileField mkOpts = Field{..}
|
|||||||
.| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
|
.| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
|
||||||
.| C.filter (\(fTitle, _) ->
|
.| C.filter (\(fTitle, _) ->
|
||||||
fieldMultiple
|
fieldMultiple
|
||||||
|| ( (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals)
|
|| ( bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals)
|
||||||
&& null files
|
&& null files
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
@ -1091,7 +1091,7 @@ fileUploadForm isReq mkFs = \case
|
|||||||
UploadAny{..}
|
UploadAny{..}
|
||||||
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
|
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
|
||||||
UploadSpecific{..}
|
UploadSpecific{..}
|
||||||
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
|
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles)
|
||||||
where
|
where
|
||||||
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
|
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
|
||||||
specificFileForm spec@UploadSpecificFile{..}
|
specificFileForm spec@UploadSpecificFile{..}
|
||||||
@ -1445,7 +1445,7 @@ examOccurrenceField :: ( MonadHandler m
|
|||||||
=> ExamId
|
=> ExamId
|
||||||
-> Field m ExamOccurrenceId
|
-> Field m ExamOccurrenceId
|
||||||
examOccurrenceField eid
|
examOccurrenceField eid
|
||||||
= hoistField liftHandler . selectField . (fmap $ fmap entityKey)
|
= hoistField liftHandler . selectField . fmap (fmap entityKey)
|
||||||
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
|
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
|
||||||
|
|
||||||
|
|
||||||
@ -1553,7 +1553,7 @@ multiUserField onlySuggested suggestions = Field{..}
|
|||||||
whenIsJust suggestions $ \suggestions' -> do
|
whenIsJust suggestions $ \suggestions' -> do
|
||||||
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
||||||
user <- suggestions'
|
user <- suggestions'
|
||||||
return $ ( E.case_
|
return ( E.case_
|
||||||
[ E.when_ (unique UserDisplayEmail user)
|
[ E.when_ (unique UserDisplayEmail user)
|
||||||
E.then_ (user E.^. UserDisplayEmail)
|
E.then_ (user E.^. UserDisplayEmail)
|
||||||
, E.when_ (unique UserEmail user)
|
, E.when_ (unique UserEmail user)
|
||||||
@ -1768,7 +1768,7 @@ examField :: forall m.
|
|||||||
, HandlerSite m ~ UniWorX
|
, HandlerSite m ~ UniWorX
|
||||||
)
|
)
|
||||||
=> Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId
|
=> Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId
|
||||||
examField optMsg cId = hoistField liftHandler . selectField' optMsg . (fmap $ fmap entityKey) $
|
examField optMsg cId = hoistField liftHandler . selectField' optMsg . fmap (fmap entityKey) $
|
||||||
optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName
|
optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -37,6 +37,8 @@ import Text.Hamlet (hamletFile)
|
|||||||
|
|
||||||
import Algebra.Lattice.Ordered (Ordered(..))
|
import Algebra.Lattice.Ordered (Ordered(..))
|
||||||
|
|
||||||
|
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||||
|
|
||||||
|
|
||||||
$(mapM tupleBoxCoord [2..4])
|
$(mapM tupleBoxCoord [2..4])
|
||||||
|
|
||||||
@ -149,7 +151,7 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
|
|||||||
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
|
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
|
||||||
|
|
||||||
|
|
||||||
type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> (BoxCoord liveliness) -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> BoxCoord liveliness -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
||||||
|
|
||||||
|
|
||||||
miDeleteList :: MassInputDelete ListLength
|
miDeleteList :: MassInputDelete ListLength
|
||||||
@ -330,9 +332,9 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
|||||||
guard $ isn't _FormMissing btnRes
|
guard $ isn't _FormMissing btnRes
|
||||||
res
|
res
|
||||||
miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
|
miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
|
||||||
addRes'' <- miAdd' & mapped . _Just . _1 %~ wBtnRes
|
addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
|
||||||
addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
|
addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
|
||||||
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
|
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
|
||||||
case remDims of
|
case remDims of
|
||||||
[] -> return dimRes'
|
[] -> return dimRes'
|
||||||
((_, BoxDimension dim) : _) -> do
|
((_, BoxDimension dim) : _) -> do
|
||||||
@ -373,7 +375,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
|||||||
delShapeUpdate
|
delShapeUpdate
|
||||||
| [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
|
| [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate
|
delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
|
||||||
|
|
||||||
|
|
||||||
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
|
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
|
||||||
@ -490,7 +492,7 @@ massInputList :: forall handler cellResult ident msg.
|
|||||||
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
|
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
|
||||||
massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
|
massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
|
||||||
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
|
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
|
||||||
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
|
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
|
||||||
, miCell = \pos () iRes nudge csrf ->
|
, miCell = \pos () iRes nudge csrf ->
|
||||||
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
|
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
|
||||||
, miDelete = miDeleteList
|
, miDelete = miDeleteList
|
||||||
@ -544,7 +546,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
|
|||||||
miAdd :: ListPosition -> Natural
|
miAdd :: ListPosition -> Natural
|
||||||
-> (Text -> Text) -> FieldView UniWorX
|
-> (Text -> Text) -> FieldView UniWorX
|
||||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
|
||||||
|
|
||||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||||
@ -622,7 +624,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
|
|||||||
miAdd :: ListPosition -> Natural
|
miAdd :: ListPosition -> Natural
|
||||||
-> (Text -> Text) -> FieldView UniWorX
|
-> (Text -> Text) -> FieldView UniWorX
|
||||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
|
||||||
|
|
||||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||||
|
|||||||
@ -30,7 +30,7 @@ tupleBoxCoord tupleDim = do
|
|||||||
|
|
||||||
instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
|
instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
|
||||||
[ funD 'boxDimensions
|
[ funD 'boxDimensions
|
||||||
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
|
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) $ map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(fieldLenses !! field) . dim) boxDimensions|]) [0..pred tupleDim]) []
|
||||||
]
|
]
|
||||||
, funD 'boxOrigin
|
, funD 'boxOrigin
|
||||||
[ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
|
[ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
|
||||||
|
|||||||
@ -58,7 +58,7 @@ i18nWidgetFilesAvailable' basename = do
|
|||||||
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
|
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
|
||||||
fileKinds :: Map Text [Text]
|
fileKinds :: Map Text [Text]
|
||||||
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
|
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
|
||||||
toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds'
|
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
|
||||||
|
|
||||||
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
|
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
|
||||||
|
|
||||||
|
|||||||
@ -274,7 +274,7 @@ sourceInvitations :: forall junction m backend.
|
|||||||
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
||||||
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
||||||
where
|
where
|
||||||
decode (Entity _ (Invitation{invitationEmail, invitationData}))
|
decode (Entity _ Invitation{invitationEmail, invitationData})
|
||||||
= case fromJSON invitationData of
|
= case fromJSON invitationData of
|
||||||
JSON.Success dbData -> return (invitationEmail, dbData)
|
JSON.Success dbData -> return (invitationEmail, dbData)
|
||||||
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
|
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
|
||||||
|
|||||||
@ -389,9 +389,9 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lif
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
startAct <- liftIO newEmptyTMVarIO
|
startAct <- liftIO newEmptyTMVarIO
|
||||||
act' <- async $ do
|
act' <- async $ do
|
||||||
$logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
|
$logDebugS "liftAsyncTimeout" "Waiting for confirmation..."
|
||||||
atomically $ takeTMVar startAct
|
atomically $ takeTMVar startAct
|
||||||
$logDebugS "liftAsyncTimeout" $ "Confirmed."
|
$logDebugS "liftAsyncTimeout" "Confirmed."
|
||||||
act
|
act
|
||||||
act'' <- atomically $ do
|
act'' <- atomically $ do
|
||||||
hm <- readTVar memcachedAsync
|
hm <- readTVar memcachedAsync
|
||||||
|
|||||||
@ -29,8 +29,6 @@ import qualified Data.YAML.Event as YAML.Event
|
|||||||
import qualified Data.YAML.Token as YAML (Encoding(..))
|
import qualified Data.YAML.Token as YAML (Encoding(..))
|
||||||
import Data.YAML.Aeson () -- ToYAML Value
|
import Data.YAML.Aeson () -- ToYAML Value
|
||||||
|
|
||||||
import Data.List (elemIndex)
|
|
||||||
|
|
||||||
import Control.Monad.Trans.State.Lazy (evalState)
|
import Control.Monad.Trans.State.Lazy (evalState)
|
||||||
|
|
||||||
import qualified System.FilePath.Cryptographic as Explicit
|
import qualified System.FilePath.Cryptographic as Explicit
|
||||||
|
|||||||
@ -169,7 +169,7 @@ planSubmissions sid restriction = do
|
|||||||
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
|
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
|
||||||
oldSubmissionData = Map.withoutKeys submissionData targetSubmissions
|
oldSubmissionData = Map.withoutKeys submissionData targetSubmissions
|
||||||
|
|
||||||
whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing ->
|
whenIsJust (fromNullable . (`Set.difference` targetSubmissions) =<< restriction) $ \missing ->
|
||||||
throwM $ SubmissionsNotFound missing
|
throwM $ SubmissionsNotFound missing
|
||||||
|
|
||||||
let
|
let
|
||||||
@ -236,7 +236,7 @@ planSubmissions sid restriction = do
|
|||||||
| otherwise
|
| otherwise
|
||||||
= Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
|
= Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
|
||||||
|
|
||||||
when (not $ null acceptableCorrectors) $ do
|
unless (null acceptableCorrectors) $ do
|
||||||
deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
|
deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
|
||||||
let
|
let
|
||||||
bestCorrectors :: Set UserId
|
bestCorrectors :: Set UserId
|
||||||
@ -570,7 +570,7 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
sinkSubmission' :: SubmissionId
|
sinkSubmission' :: SubmissionId
|
||||||
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
|
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
|
||||||
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||||||
Left file@(FileReference{..}) -> do
|
Left file@FileReference{..} -> do
|
||||||
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
|
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
|
||||||
|
|
||||||
alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
|
alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
|
||||||
@ -587,7 +587,7 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
, submissionFileIsUpdate sf == isUpdate
|
, submissionFileIsUpdate sf == isUpdate
|
||||||
]
|
]
|
||||||
underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
|
underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
|
||||||
, submissionFileIsUpdate sf == False
|
, not (submissionFileIsUpdate sf)
|
||||||
]
|
]
|
||||||
anyChanges
|
anyChanges
|
||||||
| not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
|
| not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
|
||||||
@ -654,7 +654,7 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
--
|
--
|
||||||
-- 'fileModified' is simply stored and never inspected while
|
-- 'fileModified' is simply stored and never inspected while
|
||||||
-- 'submissionChanged' is always set to @now@.
|
-- 'submissionChanged' is always set to @now@.
|
||||||
let anyChanges = any (\f -> f submission submission') $
|
let anyChanges = any (\f -> f submission submission')
|
||||||
[ (/=) `on` submissionRatingPoints
|
[ (/=) `on` submissionRatingPoints
|
||||||
, (/=) `on` submissionRatingComment
|
, (/=) `on` submissionRatingComment
|
||||||
, (/=) `on` submissionRatingDone
|
, (/=) `on` submissionRatingDone
|
||||||
@ -671,7 +671,7 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
|
when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
|
||||||
tellSt mempty { sinkSubmissionNotifyRating = Any True }
|
tellSt mempty { sinkSubmissionNotifyRating = Any True }
|
||||||
lift $ replace submissionId submission'
|
lift $ replace submissionId submission'
|
||||||
sheetId <- lift $ getSheetId
|
sheetId <- lift getSheetId
|
||||||
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
|
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
|
||||||
where
|
where
|
||||||
a /~ b = not $ a ~~ b
|
a /~ b = not $ a ~~ b
|
||||||
@ -695,14 +695,14 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
|
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
|
||||||
touchSubmission = do
|
touchSubmission = do
|
||||||
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
||||||
when (not alreadyTouched) $ do
|
unless alreadyTouched $ do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
case isUpdate of
|
if
|
||||||
False -> lift . insert_ $ SubmissionEdit userId now submissionId
|
| isUpdate -> do
|
||||||
True -> do
|
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
||||||
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
when (is _Just submissionRatingTime) $
|
||||||
when (is _Just submissionRatingTime) $
|
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
||||||
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
| otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
|
||||||
tellSt $ mempty{ sinkSubmissionTouched = Any True }
|
tellSt $ mempty{ sinkSubmissionTouched = Any True }
|
||||||
|
|
||||||
getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
|
getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
|
||||||
@ -716,15 +716,36 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
finalize SubmissionSinkState{..} = do
|
finalize SubmissionSinkState{..} = do
|
||||||
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
||||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
||||||
when (not isUpdate) $
|
unless isUpdate $
|
||||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
||||||
E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
|
E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
|
||||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||||||
|
|
||||||
return sf
|
return sf
|
||||||
|
|
||||||
case isUpdate of
|
if
|
||||||
False -> do
|
| isUpdate -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
|
||||||
|
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
||||||
|
|
||||||
|
if
|
||||||
|
| not shadowing -> do
|
||||||
|
delete sfId
|
||||||
|
audit $ TransactionSubmissionFileDelete sfId submissionId
|
||||||
|
| submissionFileIsUpdate -> do
|
||||||
|
update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
||||||
|
audit $ TransactionSubmissionFileEdit sfId submissionId
|
||||||
|
| otherwise -> do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
sfId' <- insert $ SubmissionFile
|
||||||
|
{ submissionFileSubmission = submissionId
|
||||||
|
, submissionFileTitle
|
||||||
|
, submissionFileModified = now
|
||||||
|
, submissionFileContent = Nothing
|
||||||
|
, submissionFileIsUpdate = True
|
||||||
|
, submissionFileIsDeletion = True
|
||||||
|
}
|
||||||
|
audit $ TransactionSubmissionFileEdit sfId' submissionId
|
||||||
|
| otherwise -> do
|
||||||
shadowed <- selectKeysList
|
shadowed <- selectKeysList
|
||||||
[ SubmissionFileSubmission ==. submissionId
|
[ SubmissionFileSubmission ==. submissionId
|
||||||
, SubmissionFileIsUpdate ==. False
|
, SubmissionFileIsUpdate ==. False
|
||||||
@ -733,27 +754,6 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
forM_ shadowed $ \sfId' -> do
|
forM_ shadowed $ \sfId' -> do
|
||||||
delete sfId'
|
delete sfId'
|
||||||
audit $ TransactionSubmissionFileDelete sfId' submissionId
|
audit $ TransactionSubmissionFileDelete sfId' submissionId
|
||||||
True -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
|
|
||||||
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
|
||||||
|
|
||||||
if
|
|
||||||
| not shadowing -> do
|
|
||||||
delete sfId
|
|
||||||
audit $ TransactionSubmissionFileDelete sfId submissionId
|
|
||||||
| submissionFileIsUpdate -> do
|
|
||||||
update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
|
||||||
audit $ TransactionSubmissionFileEdit sfId submissionId
|
|
||||||
| otherwise -> do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
sfId' <- insert $ SubmissionFile
|
|
||||||
{ submissionFileSubmission = submissionId
|
|
||||||
, submissionFileTitle
|
|
||||||
, submissionFileModified = now
|
|
||||||
, submissionFileContent = Nothing
|
|
||||||
, submissionFileIsUpdate = True
|
|
||||||
, submissionFileIsDeletion = True
|
|
||||||
}
|
|
||||||
audit $ TransactionSubmissionFileEdit sfId' submissionId
|
|
||||||
|
|
||||||
if
|
if
|
||||||
| isUpdate
|
| isUpdate
|
||||||
@ -829,7 +829,7 @@ sinkMultiSubmission userId isUpdate = do
|
|||||||
| otherwise = return Nothing
|
| otherwise = return Nothing
|
||||||
Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
|
Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
|
||||||
return (msId, fp)
|
return (msId, fp)
|
||||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
(msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
||||||
case msId of
|
case msId of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
|
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
|
||||||
@ -838,7 +838,7 @@ sinkMultiSubmission userId isUpdate = do
|
|||||||
cID <- encrypt sId
|
cID <- encrypt sId
|
||||||
lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
|
lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
|
||||||
feed sId $ Left f{ fileReferenceTitle = fileTitle' }
|
feed sId $ Left f{ fileReferenceTitle = fileTitle' }
|
||||||
when (not $ null ignoredFiles) $ do
|
unless (null ignoredFiles) $ do
|
||||||
mr <- (toHtml .) <$> getMessageRender
|
mr <- (toHtml .) <$> getMessageRender
|
||||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||||
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
|
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
|
||||||
@ -899,7 +899,7 @@ submissionDeleteRoute drRecords = DeleteRoute
|
|||||||
uid <- maybeAuthId
|
uid <- maybeAuthId
|
||||||
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
|
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
|
||||||
if
|
if
|
||||||
| length subUsers >= 1
|
| not $ null subUsers
|
||||||
, maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
|
, maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
|
||||||
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
|
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
|
||||||
| otherwise
|
| otherwise
|
||||||
|
|||||||
@ -302,8 +302,8 @@ sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryN
|
|||||||
colApplicationId :: OpticColonnade CourseApplicationId
|
colApplicationId :: OpticColonnade CourseApplicationId
|
||||||
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
||||||
where
|
where
|
||||||
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
|
header = Sortable Nothing $ i18nCell MsgCourseApplicationId
|
||||||
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
|
body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId
|
||||||
|
|
||||||
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
||||||
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
||||||
|
|||||||
@ -92,7 +92,7 @@ import Colonnade.Encode hiding (row)
|
|||||||
|
|
||||||
import Text.Hamlet (hamletFile)
|
import Text.Hamlet (hamletFile)
|
||||||
|
|
||||||
import Data.List (elemIndex, inits)
|
import Data.List (inits)
|
||||||
|
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
|
|
||||||
|
|||||||
@ -106,11 +106,11 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
|
|||||||
for ldapData $ upsertCampusUser UpsertCampusUser
|
for ldapData $ upsertCampusUser UpsertCampusUser
|
||||||
|
|
||||||
if
|
if
|
||||||
| x@(Entity pid _) : [] <- users'
|
| [x@(Entity pid _)] <- users'
|
||||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
, Just True == matchesMatriculation x || didLdap
|
||||||
-> return $ Just pid
|
-> return $ Just pid
|
||||||
| x@(Entity pid _) : x' : _ <- users'
|
| x@(Entity pid _) : x' : _ <- users'
|
||||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
, Just True == matchesMatriculation x || didLdap
|
||||||
, GT <- x `closeness` x'
|
, GT <- x `closeness` x'
|
||||||
-> return $ Just pid
|
-> return $ Just pid
|
||||||
| not didLdap
|
| not didLdap
|
||||||
|
|||||||
@ -60,6 +60,7 @@ import GHC.Exts as Import (IsList)
|
|||||||
import Data.Ix as Import (Ix)
|
import Data.Ix as Import (Ix)
|
||||||
|
|
||||||
import Data.Hashable as Import
|
import Data.Hashable as Import
|
||||||
|
import Data.List as Import (elemIndex)
|
||||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||||
import Data.Semigroup as Import (Min(..), Max(..))
|
import Data.Semigroup as Import (Min(..), Max(..))
|
||||||
@ -78,6 +79,8 @@ import Database.Persist.Sql as Import (SqlReadBackend, SqlReadT, SqlWriteT, IsSq
|
|||||||
|
|
||||||
import Ldap.Client.Pool as Import
|
import Ldap.Client.Pool as Import
|
||||||
|
|
||||||
|
import Control.Monad as Import (zipWithM)
|
||||||
|
|
||||||
import System.Random as Import (Random(..))
|
import System.Random as Import (Random(..))
|
||||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||||
|
|
||||||
|
|||||||
@ -492,7 +492,7 @@ jLocked jId act = do
|
|||||||
liftIO . atomically $ writeTVar hasLock True
|
liftIO . atomically $ writeTVar hasLock True
|
||||||
return val
|
return val
|
||||||
|
|
||||||
unlock = whenM (liftIO . atomically $ readTVar hasLock) $
|
unlock = whenM (readTVarIO hasLock) $
|
||||||
runDB . setSerializable $
|
runDB . setSerializable $
|
||||||
update jId [ QueuedJobLockInstance =. Nothing
|
update jId [ QueuedJobLockInstance =. Nothing
|
||||||
, QueuedJobLockTime =. Nothing
|
, QueuedJobLockTime =. Nothing
|
||||||
|
|||||||
@ -231,7 +231,7 @@ instance Exception MailException
|
|||||||
|
|
||||||
class Yesod site => YesodMail site where
|
class Yesod site => YesodMail site where
|
||||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||||
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
|
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
||||||
|
|
||||||
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||||
mailObjectIdDomain = pack <$> liftIO getHostName
|
mailObjectIdDomain = pack <$> liftIO getHostName
|
||||||
|
|||||||
@ -105,17 +105,17 @@ requiresMigration :: forall m.
|
|||||||
=> ReaderT SqlBackend m Bool
|
=> ReaderT SqlBackend m Bool
|
||||||
requiresMigration = mapReaderT (exceptT return return) $ do
|
requiresMigration = mapReaderT (exceptT return return) $ do
|
||||||
initial <- either id (map snd) <$> parseMigration initialMigration
|
initial <- either id (map snd) <$> parseMigration initialMigration
|
||||||
when (not $ null initial) $ do
|
unless (null initial) $ do
|
||||||
$logInfoS "Migration" $ intercalate "; " initial
|
$logInfoS "Migration" $ intercalate "; " initial
|
||||||
throwError True
|
throwError True
|
||||||
|
|
||||||
customs <- mapReaderT lift $ getMissingMigrations @_ @m
|
customs <- mapReaderT lift $ getMissingMigrations @_ @m
|
||||||
when (not $ Map.null customs) $ do
|
unless (Map.null customs) $ do
|
||||||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||||||
throwError True
|
throwError True
|
||||||
|
|
||||||
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
||||||
when (not $ null automatic) $ do
|
unless (null automatic) $ do
|
||||||
$logInfoS "Migration" $ intercalate "; " automatic
|
$logInfoS "Migration" $ intercalate "; " automatic
|
||||||
throwError True
|
throwError True
|
||||||
|
|
||||||
@ -188,7 +188,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
other -> error $ "Could not parse theme: " <> show other
|
other -> error $ "Could not parse theme: " <> show other
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
|
||||||
, whenM (tableExists "sheet") $ -- Better JSON encoding
|
, whenM (tableExists "sheet") -- Better JSON encoding
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
|
ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
|
||||||
ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
|
ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
|
||||||
@ -265,13 +265,13 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
_other -> error "Empty userDisplayName found"
|
_other -> error "Empty userDisplayName found"
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
||||||
, whenM (tableExists "sheet") $
|
, whenM (tableExists "sheet")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
|
||||||
, whenM (columnExists "user" "plugin") $
|
, whenM (columnExists "user" "plugin")
|
||||||
-- <> is standard sql for /=
|
-- <> is standard sql for /=
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
|
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
|
||||||
@ -280,7 +280,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
|
||||||
, whenM (tableExists "user") $
|
, whenM (tableExists "user")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
|
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
|
||||||
|]
|
|]
|
||||||
@ -291,13 +291,13 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
|
forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
|
||||||
, whenM (tableExists "cluster_config") $
|
, whenM (tableExists "cluster_config")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
|
UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
|
||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|]
|
||||||
, whenM (tableExists "sheet") $
|
, whenM (tableExists "sheet")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
|
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
|
||||||
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
|
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
|
||||||
@ -315,10 +315,10 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
|
||||||
, do
|
, do
|
||||||
whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||||
whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
|
whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||||
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||||
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
|
whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
|
||||||
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
|
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
|
||||||
@ -388,7 +388,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
|
ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
|
||||||
|]
|
|]
|
||||||
|
|
||||||
whenM (tableExists "user") $
|
whenM (tableExists "user")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
|
UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
|
||||||
|]
|
|]
|
||||||
@ -572,13 +572,13 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|]
|
||||||
, whenM (tableExists "exam") $
|
, whenM (tableExists "exam")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
|
UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
|
||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
|
||||||
, whenM (tableExists "course_favourite") $
|
, whenM (tableExists "course_favourite")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
|
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
|
||||||
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
||||||
@ -596,7 +596,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
_other -> error "Cannot reconstruct course_participant.allocated"
|
_other -> error "Cannot reconstruct course_participant.allocated"
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
|
||||||
, whenM (tableExists "allocation") $
|
, whenM (tableExists "allocation")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL);
|
CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL);
|
||||||
INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null));
|
INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null));
|
||||||
@ -605,7 +605,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
|
||||||
, whenM (tableExists "user") $
|
, whenM (tableExists "user")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
|
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
|
||||||
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
|
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
|
||||||
@ -617,7 +617,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
tableDropEmpty "exam_part_corrector"
|
tableDropEmpty "exam_part_corrector"
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
|
||||||
, whenM (tableExists "study_features") $
|
, whenM (tableExists "study_features")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
|
ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
|
||||||
UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
|
UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
|
||||||
@ -625,7 +625,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|]
|
||||||
, whenM (tableExists "exam") $
|
, whenM (tableExists "exam")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
|
UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
|
||||||
ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
|
ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
|
||||||
@ -640,7 +640,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
|
in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|]
|
||||||
, whenM (tableExists "exam") $
|
, whenM (tableExists "exam")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
|
ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
|
||||||
UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
||||||
@ -650,7 +650,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
, ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|]
|
, ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|]
|
||||||
, whenM (tableExists "external_exam") $
|
, whenM (tableExists "external_exam")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
|
ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
|
||||||
UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
||||||
@ -849,7 +849,7 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log";
|
ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log";
|
||||||
|]
|
|]
|
||||||
|
|
||||||
whenM (tableExists "session_file") $
|
whenM (tableExists "session_file")
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
|
ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
|
||||||
UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");
|
UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");
|
||||||
|
|||||||
@ -59,6 +59,8 @@ import qualified Data.Foldable
|
|||||||
|
|
||||||
import Data.Aeson (genericToJSON, genericParseJSON)
|
import Data.Aeson (genericToJSON, genericParseJSON)
|
||||||
|
|
||||||
|
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||||
|
|
||||||
|
|
||||||
data ExamResult' res = ExamAttended { examResult :: res }
|
data ExamResult' res = ExamAttended { examResult :: res }
|
||||||
| ExamNoShow
|
| ExamNoShow
|
||||||
@ -170,7 +172,7 @@ derivePersistFieldJSON ''ExamOccurrenceRule
|
|||||||
makePrisms ''ExamOccurrenceRule
|
makePrisms ''ExamOccurrenceRule
|
||||||
|
|
||||||
examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
|
examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
|
||||||
examOccurrenceRuleAutomatic x = or $ map ($ x)
|
examOccurrenceRuleAutomatic x = any ($ x)
|
||||||
[ is _ExamRoomSurname
|
[ is _ExamRoomSurname
|
||||||
, is _ExamRoomMatriculation
|
, is _ExamRoomMatriculation
|
||||||
, is _ExamRoomRandom
|
, is _ExamRoomRandom
|
||||||
|
|||||||
@ -152,7 +152,7 @@ instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
|
|||||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
||||||
|
|
||||||
instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
|
instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
|
||||||
toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
|
toPathPiece = Text.unwords . map (Text.intercalate "AND" . map toPathPiece . otoList) . otoList . dnfTerms
|
||||||
fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
|
fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
|
||||||
|
|
||||||
type AuthLiteral = PredLiteral AuthTag
|
type AuthLiteral = PredLiteral AuthTag
|
||||||
|
|||||||
@ -23,7 +23,7 @@ import qualified Data.Text as Text
|
|||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
|
||||||
import Data.List (elemIndex, genericIndex)
|
import Data.List (genericIndex)
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Data.Text.Metrics (damerauLevenshtein)
|
import Data.Text.Metrics (damerauLevenshtein)
|
||||||
|
|
||||||
@ -137,7 +137,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
|
|||||||
|
|
||||||
pseudonymWords :: Fold Text PseudonymWord
|
pseudonymWords :: Fold Text PseudonymWord
|
||||||
pseudonymWords = folding
|
pseudonymWords = folding
|
||||||
$ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
$ \(CI.mk -> input) -> maybe [] (map (view _2)) . listToMaybe . groupBy ((==) `on` view _1) . sortOn (view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||||
where
|
where
|
||||||
distance = damerauLevenshtein `on` CI.foldedCase
|
distance = damerauLevenshtein `on` CI.foldedCase
|
||||||
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
||||||
|
|||||||
@ -142,7 +142,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do
|
|||||||
[ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) []
|
[ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) []
|
||||||
| fName <- Set.toList fileNames
|
| fName <- Set.toList fileNames
|
||||||
]
|
]
|
||||||
, funD 'fromPathMultiPiece $
|
, funD 'fromPathMultiPiece
|
||||||
[ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
|
[ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|||||||
@ -51,6 +51,7 @@ import Control.Lens as Utils (none)
|
|||||||
import Control.Lens.Extras (is)
|
import Control.Lens.Extras (is)
|
||||||
import Data.Set.Lens
|
import Data.Set.Lens
|
||||||
|
|
||||||
|
import Control.Monad (zipWithM)
|
||||||
import Control.Arrow as Utils ((>>>))
|
import Control.Arrow as Utils ((>>>))
|
||||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||||
import Control.Monad.Except (MonadError(..))
|
import Control.Monad.Except (MonadError(..))
|
||||||
@ -703,7 +704,7 @@ shortCircuitM sc binOp mx my = do
|
|||||||
x <- mx
|
x <- mx
|
||||||
if
|
if
|
||||||
| sc x -> return x
|
| sc x -> return x
|
||||||
| otherwise -> binOp <$> pure x <*> my
|
| otherwise -> binOp x <$> my
|
||||||
|
|
||||||
|
|
||||||
guardM :: MonadPlus m => m Bool -> m ()
|
guardM :: MonadPlus m => m Bool -> m ()
|
||||||
@ -1170,8 +1171,7 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
|
|||||||
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
|
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
|
||||||
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
|
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
|
||||||
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
|
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
|
||||||
fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
|
fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
||||||
zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
|
||||||
where
|
where
|
||||||
uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
|
uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
|
||||||
uc = unsafeCoerce
|
uc = unsafeCoerce
|
||||||
|
|||||||
@ -20,7 +20,7 @@ import Control.Monad.Writer (tell)
|
|||||||
|
|
||||||
import Control.Monad.ST
|
import Control.Monad.ST
|
||||||
|
|
||||||
import Data.List ((!!), elemIndex)
|
import Data.List ((!!))
|
||||||
|
|
||||||
|
|
||||||
type CourseIndex = Int
|
type CourseIndex = Int
|
||||||
@ -127,11 +127,11 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
|
|||||||
(newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
(newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||||
|
|
||||||
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
|
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
|
||||||
isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
|
isUnstableWith cn' (stO, cnO) = Just True == (do
|
||||||
c' <- matchingCourse st cn'
|
c' <- matchingCourse st cn'
|
||||||
rMe <- courseRating c' (st, cn')
|
rMe <- courseRating c' (st, cn')
|
||||||
rOther <- courseRating c' (stO, cnO)
|
rOther <- courseRating c' (stO, cnO)
|
||||||
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))
|
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO)))
|
||||||
|
|
||||||
if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
|
if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
|
||||||
-> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
|
-> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
|
||||||
|
|||||||
@ -46,7 +46,7 @@ getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
|||||||
|
|
||||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
|
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
|
||||||
=> Key val -> ReaderT backend m (Entity val)
|
=> Key val -> ReaderT backend m (Entity val)
|
||||||
getEntity404 k = Entity <$> pure k <*> get404 k
|
getEntity404 k = Entity k <$> get404 k
|
||||||
|
|
||||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||||
=> Unique record -> ReaderT backend m Bool
|
=> Unique record -> ReaderT backend m Bool
|
||||||
|
|||||||
@ -718,9 +718,9 @@ selectField' optMsg mkOpts = Field{..}
|
|||||||
let
|
let
|
||||||
rendered = case val of
|
rendered = case val of
|
||||||
Left _ -> ""
|
Left _ -> ""
|
||||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions
|
||||||
|
|
||||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
isSel Nothing = rendered `notElem` map optionExternalValue olOptions
|
||||||
isSel (Just opt) = rendered == optionExternalValue opt
|
isSel (Just opt) = rendered == optionExternalValue opt
|
||||||
[whamlet|
|
[whamlet|
|
||||||
$newline never
|
$newline never
|
||||||
@ -757,9 +757,9 @@ radioField' optMsg mkOpts = Field{..}
|
|||||||
let
|
let
|
||||||
rendered = case val of
|
rendered = case val of
|
||||||
Left _ -> ""
|
Left _ -> ""
|
||||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions
|
||||||
|
|
||||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
isSel Nothing = rendered `notElem` map optionExternalValue olOptions
|
||||||
isSel (Just opt) = rendered == optionExternalValue opt
|
isSel (Just opt) = rendered == optionExternalValue opt
|
||||||
[whamlet|
|
[whamlet|
|
||||||
$newline never
|
$newline never
|
||||||
@ -800,9 +800,9 @@ radioGroupField optMsg mkOpts = Field{..}
|
|||||||
let
|
let
|
||||||
rendered = case val of
|
rendered = case val of
|
||||||
Left _ -> ""
|
Left _ -> ""
|
||||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions
|
||||||
|
|
||||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
isSel Nothing = rendered `notElem` map optionExternalValue olOptions
|
||||||
isSel (Just opt) = rendered == optionExternalValue opt
|
isSel (Just opt) = rendered == optionExternalValue opt
|
||||||
[whamlet|
|
[whamlet|
|
||||||
$newline never
|
$newline never
|
||||||
@ -885,9 +885,7 @@ renderFieldViews :: ( RenderMessage site AFormMessage
|
|||||||
)
|
)
|
||||||
=> FormLayout -> [FieldView site] -> WidgetT site IO ()
|
=> FormLayout -> [FieldView site] -> WidgetT site IO ()
|
||||||
renderFieldViews layout
|
renderFieldViews layout
|
||||||
= join
|
= view _1 <=< generateFormPost
|
||||||
. fmap (view _1)
|
|
||||||
. generateFormPost
|
|
||||||
. lmap (const mempty)
|
. lmap (const mempty)
|
||||||
. renderWForm layout
|
. renderWForm layout
|
||||||
. (FormSuccess () <$)
|
. (FormSuccess () <$)
|
||||||
@ -1168,21 +1166,21 @@ mreq :: forall m a.
|
|||||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||||
)
|
)
|
||||||
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> MForm m (FormResult a, FieldView (HandlerSite m))
|
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> MForm m (FormResult a, FieldView (HandlerSite m))
|
||||||
mreq f fs@FieldSettings{..} mdef = mreqMsg f fs (ValueRequired fsLabel) mdef
|
mreq f fs@FieldSettings{..} = mreqMsg f fs $ ValueRequired fsLabel
|
||||||
|
|
||||||
wreq :: forall m a.
|
wreq :: forall m a.
|
||||||
( MonadHandler m
|
( MonadHandler m
|
||||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||||
)
|
)
|
||||||
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> WForm m (FormResult a)
|
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> WForm m (FormResult a)
|
||||||
wreq f fs@FieldSettings{..} mdef = wreqMsg f fs (ValueRequired fsLabel) mdef
|
wreq f fs@FieldSettings{..} = wreqMsg f fs $ ValueRequired fsLabel
|
||||||
|
|
||||||
areq :: forall m a.
|
areq :: forall m a.
|
||||||
( MonadHandler m
|
( MonadHandler m
|
||||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||||
)
|
)
|
||||||
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> AForm m a
|
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> AForm m a
|
||||||
areq f fs@FieldSettings{..} mdef = areqMsg f fs (ValueRequired fsLabel) mdef
|
areq f fs@FieldSettings{..} = areqMsg f fs $ ValueRequired fsLabel
|
||||||
|
|
||||||
|
|
||||||
mforced :: (site ~ HandlerSite m, MonadHandler m)
|
mforced :: (site ~ HandlerSite m, MonadHandler m)
|
||||||
|
|||||||
@ -24,6 +24,8 @@ import qualified Network.HTTP.Types as HTTP
|
|||||||
|
|
||||||
import Yesod.Core.Types (HandlerData(..), GHState(..))
|
import Yesod.Core.Types (HandlerData(..), GHState(..))
|
||||||
|
|
||||||
|
{-# ANN module ("HLint: ignore Use even" :: String) #-}
|
||||||
|
|
||||||
|
|
||||||
histogramBuckets :: Rational -- ^ min
|
histogramBuckets :: Rational -- ^ min
|
||||||
-> Rational -- ^ max
|
-> Rational -- ^ max
|
||||||
|
|||||||
@ -50,7 +50,7 @@ normalizeOccurrences initial
|
|||||||
| otherwise
|
| otherwise
|
||||||
= Nothing
|
= Nothing
|
||||||
merge _ = Nothing
|
merge _ = Nothing
|
||||||
merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a
|
merges <- views _occurrencesScheduled $ mapMaybe (\b -> (b, ) <$> merge b) . Set.toList . Set.delete a
|
||||||
case merges of
|
case merges of
|
||||||
[] -> return ()
|
[] -> return ()
|
||||||
((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
|
((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
|
||||||
|
|||||||
@ -111,7 +111,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql
|
|||||||
runTransactionM MemcachedSqlStorage{..} = flip runSqlPool mcdSqlConnPool
|
runTransactionM MemcachedSqlStorage{..} = flip runSqlPool mcdSqlConnPool
|
||||||
|
|
||||||
getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do
|
getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do
|
||||||
encSession <- catchIfExceptT (\_ -> Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
||||||
|
|
||||||
guardExceptT (BS.length encSession >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
guardExceptT (BS.length encSession >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
||||||
Just MemcachedSqlStorageAEADCiphertextTooShort
|
Just MemcachedSqlStorageAEADCiphertextTooShort
|
||||||
@ -161,7 +161,7 @@ replaceSession' isReplace s@MemcachedSqlStorage{..} seNewSession@(review memcach
|
|||||||
whenIsJust mOld $ \seExistingSession ->
|
whenIsJust mOld $ \seExistingSession ->
|
||||||
throwM @_ @(StorageException (MemcachedSqlStorage sess)) $ SessionAlreadyExists{..}
|
throwM @_ @(StorageException (MemcachedSqlStorage sess)) $ SessionAlreadyExists{..}
|
||||||
|
|
||||||
nonce <- liftIO $ AEAD.newNonce
|
nonce <- liftIO AEAD.newNonce
|
||||||
let encSession = Saltine.encode nonce <> AEAD.aead mcdSqlMemcachedKey nonce encoded encSessId
|
let encSession = Saltine.encode nonce <> AEAD.aead mcdSqlMemcachedKey nonce encoded encSessId
|
||||||
encSessId = LBS.toStrict $ Binary.encode sessId
|
encSessId = LBS.toStrict $ Binary.encode sessId
|
||||||
handleFailure
|
handleFailure
|
||||||
|
|||||||
@ -151,6 +151,7 @@ extra-deps:
|
|||||||
- unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
|
- unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
|
||||||
- uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
|
- uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
|
||||||
- wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
- wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
||||||
|
- hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||||
|
|
||||||
resolver: nightly-2020-08-08
|
resolver: nightly-2020-08-08
|
||||||
allow-newer: true
|
allow-newer: true
|
||||||
|
|||||||
@ -150,6 +150,20 @@ packages:
|
|||||||
subdir: colonnade
|
subdir: colonnade
|
||||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git
|
git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git
|
||||||
commit: f8170266ab25b533576e96715bedffc5aa4f19fa
|
commit: f8170266ab25b533576e96715bedffc5aa4f19fa
|
||||||
|
- completed:
|
||||||
|
cabal-file:
|
||||||
|
size: 9845
|
||||||
|
sha256: 674630347209bc5f7984e8e9d93293510489921f2d2d6092ad1c9b8c61b6560a
|
||||||
|
name: minio-hs
|
||||||
|
version: 1.5.2
|
||||||
|
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
|
||||||
|
pantry-tree:
|
||||||
|
size: 4560
|
||||||
|
sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
|
||||||
|
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
|
||||||
|
original:
|
||||||
|
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
|
||||||
|
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
|
||||||
- completed:
|
- completed:
|
||||||
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||||
pantry-tree:
|
pantry-tree:
|
||||||
@ -367,6 +381,13 @@ packages:
|
|||||||
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
|
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
|
||||||
original:
|
original:
|
||||||
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
||||||
|
- completed:
|
||||||
|
hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||||
|
pantry-tree:
|
||||||
|
size: 442
|
||||||
|
sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea
|
||||||
|
original:
|
||||||
|
hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||||
snapshots:
|
snapshots:
|
||||||
- completed:
|
- completed:
|
||||||
size: 524392
|
size: 524392
|
||||||
|
|||||||
Reference in New Issue
Block a user