fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'version-bumps' into 'master'

Browse Source 
Version bumps to GHC 8.10.x

See merge request uni2work/uni2work!20
This commit is contained in:
Gregor Kleen 2020-08-11 11:38:17 +02:00
commit a0412b073b
217 changed files with 1284 additions and 1240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
load/Load.hs
View File

@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral
instance PathPiece DiffTime where instance PathPiece DiffTime where
toPathPiece = toPathPiece . MkFixed @E12 . diffTimeToPicoseconds toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds
fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps

7
package.yaml
View File

@ -253,7 +253,7 @@ executables:
uniworx: uniworx:
main: main.hs main: main.hs
source-dirs: app source-dirs: app
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T -xn"
dependencies: dependencies:
- uniworx - uniworx
when: when:
@ -278,7 +278,7 @@ executables:
ghc-options: ghc-options:
- -main-is Load - -main-is Load
- -threaded - -threaded
- -rtsopts "-with-rtsopts=-N -T" - -rtsopts "-with-rtsopts=-N -T -xn"
source-dirs: load source-dirs: load
dependencies: dependencies:
- uniworx - uniworx
@ -313,8 +313,7 @@ tests:
ghc-options: ghc-options:
- -fno-warn-orphans - -fno-warn-orphans
- -threaded - -threaded
- -rtsopts - -rtsopts "-with-rtsopts=-N -xn"
- -with-rtsopts=-N
hlint: hlint:
main: Hlint.hs main: Hlint.hs
other-modules: [] other-modules: []

3
src/Application.hs
View File

@ -101,6 +101,8 @@ import qualified Network.Minio as Minio
import Web.ServerSession.Core (StorageException(..)) import Web.ServerSession.Core (StorageException(..))
import GHC.RTS.Flags (getRTSFlags)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.) -- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.News import Handler.News
@ -200,6 +202,7 @@ makeFoundation appSettings'@AppSettings{..} = do
runAppLoggingT tempFoundation $ do runAppLoggingT tempFoundation $ do
$logInfoS "InstanceID" $ UUID.toText appInstanceID $logInfoS "InstanceID" $ UUID.toText appInstanceID
$logDebugS "Configuration" $ tshow appSettings' $logDebugS "Configuration" $ tshow appSettings'
$logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
smtpPool <- for appSmtpConf $ \c -> do smtpPool <- for appSmtpConf $ \c -> do
$logDebugS "setup" "SMTP-Pool" $logDebugS "setup" "SMTP-Pool"

4
src/Data/CaseInsensitive/Instances.hs
View File

@ -77,8 +77,8 @@ instance ToWidget site a => ToWidget site (CI a) where
instance RenderMessage site a => RenderMessage site (CI a) where instance RenderMessage site a => RenderMessage site (CI a) where
renderMessage f ls msg = renderMessage f ls $ CI.original msg renderMessage f ls msg = renderMessage f ls $ CI.original msg
instance Lift t => Lift (CI t) where instance (CI.FoldCase t, Lift t) => Lift (CI t) where
lift (CI.original -> orig) = [e|CI.mk $(lift orig)|] liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||]
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where

2
src/Database/Esqueleto/Utils/TH.hs
View File

@ -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)|])|]

2
src/Database/Persist/TH/Directory.hs
View File

@ -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

105
src/Foundation.hs
View File

@ -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
@ -106,7 +107,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))
@ -651,7 +651,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
@ -746,20 +746,6 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthSubmissionGroup r r -> $unsupportedAuthPredicate AuthSubmissionGroup r
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
case allocation of
Nothing -> return ()
Just Allocation{..} -> do
cTime <- liftIO getCurrentTime
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
return Authorized
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@ -783,7 +769,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
@ -920,7 +906,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
@ -928,7 +914,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
@ -936,7 +922,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
@ -1247,7 +1233,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
@ -1257,7 +1243,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
@ -1274,7 +1260,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
@ -1306,7 +1292,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
@ -1315,7 +1301,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
@ -1323,8 +1309,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
@ -1666,8 +1650,8 @@ wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> m Bool -> m Bool
wouldHaveReadAccessToIff assumptions route = and2M (fmap not $ hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
wouldHaveWriteAccessToIff assumptions route = and2M (fmap not $ hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route
-- | Conditional redirect that hides the URL if the user is not authorized for the route -- | Conditional redirect that hides the URL if the user is not authorized for the route
redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
@ -1728,10 +1712,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
@ -1764,7 +1748,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
@ -1993,7 +1977,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
@ -2207,7 +2191,7 @@ siteLayout' headingOverride widget = do
-> let route = navRoute' -> let route = navRoute'
ident = navIdent ident = navIdent
in $(widgetFile "widgets/navbar/item") in $(widgetFile "widgets/navbar/item")
NavPageActionPrimary{ navLink = navLink@NavLink{..}, .. } NavPageActionPrimary{ navLink = navLink@NavLink{..} }
-> let pWidget -> let pWidget
| NavTypeLink{..} <- navType | NavTypeLink{..} <- navType
, navModal , navModal
@ -2226,7 +2210,7 @@ siteLayout' headingOverride widget = do
sWidgets = navChildren' sWidgets = navChildren'
& map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, [])) & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
in $(widgetFile "widgets/pageaction/primary-wrapper") in $(widgetFile "widgets/pageaction/primary-wrapper")
NavPageActionSecondary{ navLink = navLink@NavLink{..}, .. } NavPageActionSecondary{ navLink = navLink@NavLink{..} }
| NavTypeLink{..} <- navType | NavTypeLink{..} <- navType
, navModal , navModal
-> customModal Modal -> customModal Modal
@ -2514,7 +2498,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
@ -3692,14 +3676,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
@ -4513,19 +4496,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
@ -4548,8 +4531,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)
@ -4661,25 +4644,25 @@ routeNormalizers =
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
ncSheet = maybeOrig $ \route -> do ncSheet = maybeOrig $ \route -> do
CSheetR tid ssh csh shn _ <- return route CSheetR tid ssh csh shn _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
caseChanged shn sheetName caseChanged shn sheetName
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
ncMaterial = maybeOrig $ \route -> do ncMaterial = maybeOrig $ \route -> do
CMaterialR tid ssh csh mnm _ <- return route CMaterialR tid ssh csh mnm _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
caseChanged mnm materialName caseChanged mnm materialName
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
ncTutorial = maybeOrig $ \route -> do ncTutorial = maybeOrig $ \route -> do
CTutorialR tid ssh csh tutn _ <- return route CTutorialR tid ssh csh tutn _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
caseChanged tutn tutorialName caseChanged tutn tutorialName
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
ncExam = maybeOrig $ \route -> do ncExam = maybeOrig $ \route -> do
CExamR tid ssh csh examn _ <- return route CExamR tid ssh csh examn _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
caseChanged examn examName caseChanged examn examName
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
@ -4748,7 +4731,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
@ -4762,7 +4745,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
@ -4992,7 +4975,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
@ -5051,12 +5034,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
@ -5073,7 +5056,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
@ -5086,7 +5069,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
@ -5221,7 +5204,7 @@ instance YesodAuth UniWorX where
_other -> return res _other -> return res
$logDebugS "auth" $ tshow Creds{..} $logDebugS "auth" $ tshow Creds{..}
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod UniWorX{..} <- getYesod
flip catches excHandlers $ case appLdapPool of flip catches excHandlers $ case appLdapPool of
Just ldapPool Just ldapPool
@ -5232,7 +5215,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

4
src/Handler/Admin/Test/Download.hs
View File

@ -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

18
src/Handler/Allocation/Application.hs
View File

@ -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

23
src/Handler/Course/Edit.hs
View File

@ -139,7 +139,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')
@ -199,10 +199,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing) (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,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 (Just now) return ( Just $ Just now
, (Just . toMidnight . termStart . entityVal) <$> mbLastTerm , 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)
@ -243,7 +244,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
@ -265,8 +266,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)
@ -333,7 +334,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
@ -538,7 +539,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
@ -556,7 +557,7 @@ courseEditHandler miButtonAction mbCourseForm = do
upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse cid cfAllocation = do upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
Course{..} <- getJust cid Course{} <- getJust cid
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)

4
src/Handler/Course/News/Edit.hs
View File

@ -33,8 +33,8 @@ postCNEditR tid ssh csh cID = do
, courseNewsSummary = cnfSummary , courseNewsSummary = cnfSummary
, 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}|]

4
src/Handler/Course/ParticipantInvite.hs
View File

@ -92,11 +92,11 @@ participantInvitationConfig = InvitationConfig{..}
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
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

6
src/Handler/Course/Register.hs
View File

@ -118,7 +118,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
@ -136,7 +136,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
@ -288,7 +288,7 @@ deregisterParticipant :: UserId -> CourseId -> DB ()
deregisterParticipant uid cid = do deregisterParticipant uid cid = do
deleteApplications uid cid deleteApplications uid cid
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity partId CourseParticipant{..}) -> do forM_ part $ \(Entity partId CourseParticipant{}) -> do
update partId [CourseParticipantState =. CourseParticipantInactive False] update partId [CourseParticipantState =. CourseParticipantInactive False]
audit $ TransactionCourseParticipantDeleted cid uid audit $ TransactionCourseParticipantDeleted cid uid

5
src/Handler/Course/Show.hs
View File

@ -112,9 +112,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)

2
src/Handler/Course/User.hs
View File

@ -115,7 +115,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
, formSubmit = FormAutoSubmit , formSubmit = FormAutoSubmit
, formAnchor = Just registrationFieldFrag , formAnchor = Just registrationFieldFrag
} }
for_ mRegistration $ \(Entity pId CourseParticipant{..}) -> for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
formResult regFieldRes $ \courseParticipantField' -> do formResult regFieldRes $ \courseParticipantField' -> do
lift . runDB $ do lift . runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ] update pId [ CourseParticipantField =. courseParticipantField' ]

60
src/Handler/Course/Users.hs
View File

@ -199,7 +199,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
@ -404,33 +404,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
@ -450,28 +450,28 @@ 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
@ -480,15 +480,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
) )
-- , ("course-registration", error "TODO") -- TODO -- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", 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))
, single $ ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. sheet E.^. SheetName E.==. E.val shn
) )
] ]
where single = uncurry Map.singleton where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $ dbtFilterUI mPrev = mconcat $
@ -652,7 +652,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)

2
src/Handler/Exam/Correct.hs
View File

@ -113,7 +113,7 @@ postECorrectR tid ssh csh examn = do
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
response <- runDB . exceptT (<$ transactionUndo) return $ do response <- runDB . exceptT (<$ transactionUndo) return $ do
Entity eId Exam{..} <- lift $ fetchExam tid ssh csh examn Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
euid <- traverse decrypt ciqUser euid <- traverse decrypt ciqUser
guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $ guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $

12
src/Handler/Exam/Form.hs
View File

@ -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)

5
src/Handler/Exam/List.hs
View File

@ -81,10 +81,9 @@ mkExamTable (Entity cid Course{..}) = do
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do getCExamListR tid ssh csh = do
(Entity _ Course{..}, examTable) <- runDB $ do examTable <- runDB $ do
c <- getBy404 $ TermSchoolCourseShort tid ssh csh c <- getBy404 $ TermSchoolCourseShort tid ssh csh
(_, examTable) <- mkExamTable c view _2 <$> mkExamTable c
return (c, examTable)
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading

14
src/Handler/Exam/Register.hs
View File

@ -36,9 +36,9 @@ instance Button UniWorX ButtonExamRegister where
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postERegisterR tid ssh csh examn = do postERegisterR tid ssh csh examn = do
Entity uid User{..} <- requireAuth uid <- requireAuthId
Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn Entity eId Exam{} <- runDB $ fetchExam tid ssh csh examn
((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister] ((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister]
@ -63,11 +63,11 @@ postERegisterR tid ssh csh examn = do
postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html
postERegisterOccR tid ssh csh examn occn = do postERegisterOccR tid ssh csh examn occn = do
Entity uid User{..} <- requireAuth uid <- requireAuthId
(Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do (eId, occId) <- runDB $ do
eexam@(Entity eId _) <- fetchExam tid ssh csh examn Entity eId _ <- fetchExam tid ssh csh examn
occ <- getBy404 $ UniqueExamOccurrence eId occn occ <- getKeyBy404 $ UniqueExamOccurrence eId occn
return (eexam, occ) return (eId, occ)
((btnResult, _), _) <- runFormPost buttonForm ((btnResult, _), _) <- runFormPost buttonForm

6
src/Handler/Exam/Show.hs
View File

@ -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")

6
src/Handler/Exam/Users.hs
View File

@ -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)

8
src/Handler/ExamOffice/Exams.hs
View File

@ -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"

2
src/Handler/ExamOffice/Fields.hs
View File

@ -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

6
src/Handler/Sheet/Edit.hs
View File

@ -86,7 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetAutoDistribute = sfAutoDistribute , sheetAutoDistribute = sfAutoDistribute
, sheetAnonymousCorrection = sfAnonymousCorrection , sheetAnonymousCorrection = sfAnonymousCorrection
, sheetRequireExamRegistration = sfRequireExamRegistration , sheetRequireExamRegistration = sfRequireExamRegistration
, sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF , sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF
} }
mbsid <- dbAction newSheet mbsid <- dbAction newSheet
case mbsid of case mbsid of
@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
runConduit $ runConduit $
maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
.| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF) .| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF)
insert_ $ SheetEdit aid actTime sid insert_ $ SheetEdit aid actTime sid
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
-- Sanity checks generating warnings only, but not errors! -- Sanity checks generating warnings only, but not errors!
@ -127,7 +127,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)

8
src/Handler/Sheet/Form.hs
View File

@ -97,7 +97,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
makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
makeSheetPersonalisedFilesForm template' = do makeSheetPersonalisedFilesForm template' = do
@ -162,7 +162,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
@ -173,7 +173,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
@ -199,7 +199,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)

2
src/Handler/Sheet/List.hs
View File

@ -69,7 +69,7 @@ getSheetListR tid ssh csh = do
, sortable Nothing (i18nCell MsgSubmission) , sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
Nothing -> mempty Nothing -> mempty
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{})) ->
let mkCid = encrypt sid -- TODO: executed twice let mkCid = encrypt sid -- TODO: executed twice
mkRoute = do mkRoute = do
cid' <- mkCid cid' <- mkCid

2
src/Handler/StorageKey.hs
View File

@ -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

2
src/Handler/Submission/Correction.hs
View File

@ -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

6
src/Handler/Submission/Helper.hs
View File

@ -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)

20
src/Handler/Submission/List.hs
View File

@ -122,7 +122,7 @@ colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnad
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } -> colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } ->
let let
csh = course ^. _2 csh = course ^. _2
tid = course ^. _3 tid = course ^. _3
@ -136,8 +136,8 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
| otherwise -> mempty | otherwise -> mempty
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } -> colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
| otherwise -> mempty | otherwise -> mempty
@ -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

10
src/Handler/SystemMessage.hs
View File

@ -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

2
src/Handler/Tutorial/Form.hs
View File

@ -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

2
src/Handler/Tutorial/List.hs
View File

@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI
getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialListR tid ssh csh = do getCTutorialListR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let let

2
src/Handler/Tutorial/New.hs
View File

@ -16,7 +16,7 @@ import Handler.Tutorial.TutorInvite
getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialNewR = postCTutorialNewR getCTutorialNewR = postCTutorialNewR
postCTutorialNewR tid ssh csh = do postCTutorialNewR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing

6
src/Handler/Users.hs
View File

@ -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

6
src/Handler/Utils/Allocation.hs
View File

@ -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

2
src/Handler/Utils/Csv.hs
View File

@ -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

2
src/Handler/Utils/DateTime.hs
View File

@ -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"

4
src/Handler/Utils/Exam.hs
View File

@ -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.!)
@ -477,7 +477,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
bestOption = case rule of bestOption = case rule of
ExamRoomSurname -> do ExamRoomSurname -> do
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
-- traceM $ show cost -- traceM $ show cost
return res return res
ExamRoomMatriculation -> do ExamRoomMatriculation -> do

2
src/Handler/Utils/Files.hs
View File

@ -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

34
src/Handler/Utils/Form.hs
View File

@ -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 ) --
@ -257,7 +257,7 @@ multiActionField :: forall action a.
-> FieldSettings UniWorX -> FieldSettings UniWorX
-> Maybe action -> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiActionField minp acts (actField, actExternal, actMessage) fs@FieldSettings{..} defAction csrf = do multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do
(actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction (actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
@ -285,15 +285,15 @@ multiActionOpts' :: forall action a.
-> FieldSettings UniWorX -> FieldSettings UniWorX
-> Maybe action -> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do 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
@ -397,13 +397,13 @@ explainedMultiAction' :: forall action a.
-> FieldSettings UniWorX -> FieldSettings UniWorX
-> Maybe action -> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
explainedMultiAction' minp acts mActsOpts fs@FieldSettings{..} 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

16
src/Handler/Utils/Form/MassInput.hs
View File

@ -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

2
src/Handler/Utils/Form/MassInput/TH.hs
View File

@ -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|]) []

2
src/Handler/Utils/I18n.hs
View File

@ -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

2
src/Handler/Utils/Invitations.hs
View File

@ -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

4
src/Handler/Utils/Memcached.hs
View File

@ -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

4
src/Handler/Utils/Rating.hs
View File

@ -31,7 +31,7 @@ import qualified Data.Char as Char
validateRating :: SheetType -> Rating' -> [RatingValidityException] validateRating :: SheetType -> Rating' -> [RatingValidityException]
validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } validateRating ratingSheetType Rating'{ ratingPoints=Just rp }
| rp < 0 | rp < 0
= [RatingNegative] = [RatingNegative]
| NotGraded <- ratingSheetType | NotGraded <- ratingSheetType
@ -93,7 +93,7 @@ ratingFile :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
) )
=> CryptoFileNameSubmission -> Rating -> m File => CryptoFileNameSubmission -> Rating -> m File
ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do
mr'@(MsgRenderer mr) <- getMsgRenderer mr'@(MsgRenderer mr) <- getMsgRenderer
dtFmt <- getDateTimeFormatter dtFmt <- getDateTimeFormatter
fileModified <- maybe (liftIO getCurrentTime) return ratingTime fileModified <- maybe (liftIO getCurrentTime) return ratingTime

2
src/Handler/Utils/Rating/Format.hs
View File

@ -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

82
src/Handler/Utils/Submission.hs
View File

@ -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
@ -320,7 +320,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
let let
fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) () fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
fileEntitySource' (rating, Entity submissionID Submission{..}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
cID <- encrypt submissionID cID <- encrypt submissionID
let let
@ -574,7 +574,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)
@ -591,7 +591,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 ]
@ -658,7 +658,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
@ -675,7 +675,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
@ -699,14 +699,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
@ -720,15 +720,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
@ -737,27 +758,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
@ -833,7 +833,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')
@ -842,7 +842,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
@ -903,7 +903,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

4
src/Handler/Utils/Table/Columns.hs
View File

@ -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

4
src/Handler/Utils/Table/Pagination.hs
View File

@ -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)
@ -450,7 +450,7 @@ instance Traversable DBRow where
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
instance Default (PSValidator m x) where instance Default (PSValidator m x) where
def = PSValidator $ \DBTable{..} -> \case def = PSValidator $ \DBTable{} -> \case
Nothing -> def Nothing -> def
Just pi -> swap . (\act -> execRWS act pi def) $ do Just pi -> swap . (\act -> execRWS act pi def) $ do
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })

6
src/Handler/Utils/Users.hs
View File

@ -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

3
src/Import/NoModel.hs
View File

@ -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(..))

2
src/Jobs.hs
View File

@ -493,7 +493,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

6
src/Jobs/Crontab.hs
View File

@ -27,7 +27,7 @@ import qualified Database.Esqueleto as E
determineCrontab :: DB (Crontab JobCtl) determineCrontab :: DB (Crontab JobCtl)
-- ^ Extract all future jobs from the database (sheet deadlines, ...) -- ^ Extract all future jobs from the database (sheet deadlines, ...)
determineCrontab = execWriterT $ do determineCrontab = execWriterT $ do
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod UniWorX{ appSettings' = AppSettings{..} } <- getYesod
case appJobFlushInterval of case appJobFlushInterval of
Just interval -> tell $ HashMap.singleton Just interval -> tell $ HashMap.singleton
@ -354,7 +354,7 @@ determineCrontab = execWriterT $ do
let let
externalExamJobs (Entity nExternalExam ExternalExam{..}) = do externalExamJobs nExternalExam = do
newestResult <- lift . E.select . E.from $ \externalExamResult -> do newestResult <- lift . E.select . E.from $ \externalExamResult -> do
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
@ -371,7 +371,7 @@ determineCrontab = execWriterT $ do
} }
_other -> return () _other -> return ()
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalExamJobs runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
let let
allocationJobs (Entity nAllocation Allocation{..}) = do allocationJobs (Entity nAllocation Allocation{..}) = do

4
src/Jobs/Handler/SendNotification/SubmissionEdited.hs
View File

@ -20,7 +20,7 @@ import qualified Data.Text as Text
dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler ()
dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}, Submission{..}, initiator, coSubmittors) <- liftHandler . runDB $ do (Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do
submission <- getJust nSubmission submission <- getJust nSubmission
sheet <- belongsToJust submissionSheet submission sheet <- belongsToJust submissionSheet submission
course <- belongsToJust sheetCourse sheet course <- belongsToJust sheetCourse sheet
@ -55,7 +55,7 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai
dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler ()
dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do
(User{..}, Course{..}, Sheet{..}, Submission{..}, coSubmittors) <- liftHandler . runDB $ do (User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do
submission <- getJust nSubmission submission <- getJust nSubmission
sheet <- belongsToJust submissionSheet submission sheet <- belongsToJust submissionSheet submission
course <- belongsToJust sheetCourse sheet course <- belongsToJust sheetCourse sheet

2
src/Jobs/Handler/SynchroniseLdap.hs
View File

@ -38,7 +38,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod UniWorX{..} <- getYesod
case appLdapPool of case appLdapPool of
Just ldapPool -> Just ldapPool ->
runDB . void . runMaybeT . handleExc $ do runDB . void . runMaybeT . handleExc $ do

2
src/Mail.hs
View File

@ -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

46
src/Model/Migration.hs
View File

@ -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");

4
src/Model/Types/Exam.hs
View 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

2
src/Model/Types/Security.hs
View File

@ -161,7 +161,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

4
src/Model/Types/Submission.hs
View File

@ -21,7 +21,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)
@ -118,7 +118,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

2
src/Settings.hs
View File

@ -420,7 +420,7 @@ instance FromJSON AppSettings where
Ldap.Plain host -> not $ null host Ldap.Plain host -> not $ null host
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
[ not $ null connectHost [ not $ null connectHost
, numConnection > 0 , numConnection > 0
, connectionIdleTime >= 0 , connectionIdleTime >= 0

2
src/Settings/WellKnownFiles/TH.hs
View File

@ -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)|]) []
] ]
] ]

14
src/Utils.hs
View File

@ -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(..))
@ -154,8 +155,8 @@ maybeAttribute a c (Just v) = [(a,c v)]
newtype PrettyValue = PrettyValue { unPrettyValue :: Value } newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
deriving (Eq, Read, Show, Generic, Typeable, Data) deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData) deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
instance ToContent PrettyValue where instance ToContent PrettyValue where
toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
@ -169,8 +170,8 @@ toPrettyJSON = PrettyValue . toJSON
newtype YamlValue = YamlValue { unYamlValue :: Value } newtype YamlValue = YamlValue { unYamlValue :: Value }
deriving (Eq, Read, Show, Generic, Typeable, Data) deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData) deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
instance ToContent YamlValue where instance ToContent YamlValue where
toContent = toContent . Yaml.encode toContent = toContent . Yaml.encode
@ -723,7 +724,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 ()
@ -1193,8 +1194,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

6
src/Utils/Allocation.hs
View File

@ -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

2
src/Utils/DB.hs
View File

@ -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

22
src/Utils/Form.hs
View File

@ -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)

2
src/Utils/Metrics.hs
View File

@ -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

2
src/Utils/Occurrences.hs
View File

@ -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)

8
src/Utils/TH.hs
View File

@ -71,10 +71,10 @@ curryN :: Int -> ExpQ
curryN n = do curryN n = do
fn <- newName "foo" fn <- newName "foo"
xs <- replicateM n $ newName "x" xs <- replicateM n $ newName "x"
let pat = map VarP (fn:xs) let pat = map varP (fn:xs)
let tup = TupE (map VarE xs) let tup = tupE (map varE xs)
let rhs = AppE (VarE fn) tup let rhs = appE (varE fn) tup
return $ LamE pat rhs lamE pat rhs
uncurryN :: Int -> ExpQ uncurryN :: Int -> ExpQ
uncurryN n = do uncurryN n = do

6
src/Web/ServerSession/Backend/Persistent/Memcached.hs
View File

@ -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
@ -137,7 +137,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql
deleteSession MemcachedSqlStorage{..} sessId deleteSession MemcachedSqlStorage{..} sessId
= liftIO . handleIf Memcached.isKeyNotFound (const $ return ()) $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached = liftIO . handleIf Memcached.isKeyNotFound (const $ return ()) $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached
deleteAllSessionsOfAuthId MemcachedSqlStorage{..} authId = do deleteAllSessionsOfAuthId MemcachedSqlStorage{} authId = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
( MemcachedSessionExpiration authId now ) ( MemcachedSessionExpiration authId now )
@ -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

4
src/Yesod/Core/Types/Instances.hs
View File

@ -57,6 +57,7 @@ newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a }
, MonadIO , MonadIO
, MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
, MonadResource, MonadHandler, MonadWidget , MonadResource, MonadHandler, MonadWidget
, MonadUnliftIO
) )
deriving newtype ( MFunctor, MMonad, MonadTrans ) deriving newtype ( MFunctor, MMonad, MonadTrans )
@ -67,9 +68,6 @@ instance MonadReader r m => MonadReader r (CachedMemoT k v m) where
reader = CachedMemoT . lift . reader reader = CachedMemoT . lift . reader
local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act
instance MonadUnliftIO m => MonadUnliftIO (CachedMemoT k v m) where
askUnliftIO = (\UnliftIO{..} -> UnliftIO $ \(CachedMemoT f) -> unliftIO f) <$> CachedMemoT askUnliftIO
-- | Uses `cachedBy` with a `Binary`-encoded @k@ -- | Uses `cachedBy` with a `Binary`-encoded @k@
instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where

153
stack.yaml
View File

@ -35,92 +35,123 @@ extra-deps:
subdirs: subdirs:
- colonnade - colonnade
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
# - colonnade-1.2.0.2 # # - colonnade-1.2.0.2
- hsass-0.8.0 # - hsass-0.8.0
- hlibsass-0.1.8.1 # - hlibsass-0.1.8.1
- tz-0.1.3.3 # - tz-0.1.3.3
# - zip-stream-0.2.0.1 # # - zip-stream-0.2.0.1
- uuid-crypto-1.4.0.0 # - uuid-crypto-1.4.0.0
- filepath-crypto-0.1.0.0 # - filepath-crypto-0.1.0.0
- cryptoids-0.5.1.0 # - cryptoids-0.5.1.0
- cryptoids-types-1.0.0 # - cryptoids-types-1.0.0
- cryptoids-class-0.0.0 # - cryptoids-class-0.0.0
- system-locale-0.3.0.0 # - system-locale-0.3.0.0
- hlint-test-0.1.0.0 # - hlint-test-0.1.0.0
- pkcs7-1.0.0.1 # - pkcs7-1.0.0.1
- systemd-2.2.0 # - systemd-2.2.0
# - directory-1.3.4.0 # # - directory-1.3.4.0
# - HaXml-1.25.5 # # - HaXml-1.25.5
# - persistent-2.10.4 # # - persistent-2.10.4
# - persistent-postgresql-2.10.1 # # - persistent-postgresql-2.10.1
# - persistent-template-2.7.3 # # - persistent-template-2.7.3
# - esqueleto-3.2.3 # # - esqueleto-3.2.3
- sandi-0.5 # - sandi-0.5
- storable-endian-0.2.6 # - storable-endian-0.2.6
# - universe-1.2 # # - universe-1.2
# - universe-base-1.1.1 # # - universe-base-1.1.1
# - universe-reverse-instances-1.1 # # - universe-reverse-instances-1.1
# - unliftio-pool-0.2.1.0 # # - unliftio-pool-0.2.1.0
# - universe-instances-extended-1.1.1 # # - universe-instances-extended-1.1.1
# - universe-some-1.2 # # - universe-some-1.2
# - some-1.0.0.3 # # - some-1.0.0.3
# - network-bsd-2.8.1.0 # # - network-bsd-2.8.1.0
# - persistent-qq-2.9.1 # # - persistent-qq-2.9.1
# - process-1.6.5.1 # # - process-1.6.5.1
# - generic-lens-1.2.0.0 # # - generic-lens-1.2.0.0
- prometheus-metrics-ghc-1.0.1 # - prometheus-metrics-ghc-1.0.1
- wai-middleware-prometheus-1.0.0 # - wai-middleware-prometheus-1.0.0
# - extended-reals-0.2.3.0 # # - extended-reals-0.2.3.0
- pandoc-2.9.2 # - pandoc-2.9.2
- doclayout-0.3 # - doclayout-0.3
- doctemplates-0.8.1 # - doctemplates-0.8.1
# - emojis-0.1 # # - emojis-0.1
# - hslua-module-system-0.2.1 # # - hslua-module-system-0.2.1
# - ipynb-0.1 # # - ipynb-0.1
# - jira-wiki-markup-1.0.0 # # - jira-wiki-markup-1.0.0
# - HsYAML-0.2.1.0 # # - HsYAML-0.2.1.0
# - cmark-gfm-0.2.1 # # - cmark-gfm-0.2.1
# - haddock-library-1.8.0 # # - haddock-library-1.8.0
# - pandoc-types-1.20 # # - pandoc-types-1.20
# - skylighting-0.8.3.2 # # - skylighting-0.8.3.2
# - skylighting-core-0.8.3.2 # # - skylighting-core-0.8.3.2
# - texmath-0.12.0.1 # # - texmath-0.12.0.1
- binary-instances-1 # - binary-instances-1
- acid-state-0.16.0 # - acid-state-0.16.0
- unidecode-0.1.0.4 # - unidecode-0.1.0.4
- token-bucket-0.1.0.1 # - token-bucket-0.1.0.1
- normaldistribution-1.1.0.3 # - normaldistribution-1.1.0.3
- unordered-containers-0.2.11.0 # - unordered-containers-0.2.11.0
- base64-bytestring-1.1.0.0 # - base64-bytestring-1.1.0.0
- base32-0.2.0.0
- ghc-byteorder-4.11.0.0.10
resolver: lts-15.12 - acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
- bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
- byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
- bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863
- commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
- commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
- commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167
- contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757
- cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570
- cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
- cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
- filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
- hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565
- hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899
- ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742
- natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411
- normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160
- pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933
- pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
- primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843
- primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
- prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233
- run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883
- sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
- system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
- token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
- tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088
- tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
- unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
- uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
- wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
- hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
resolver: nightly-2020-08-08
allow-newer: true allow-newer: true

310
stack.yaml.lock
View File

@ -158,211 +158,239 @@ packages:
version: 1.5.2 version: 1.5.2
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
pantry-tree: pantry-tree:
size: 4517 size: 4560
sha256: ef7c5960da571c6cb41337b0bd30740bac92b4781b375be704093fdadd17330d sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
original: original:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
- completed: - completed:
hackage: hsass-0.8.0@sha256:82d55fb2a10342accbc4fe80d263163f40a138d8636e275aa31ffa81b14abf01,2792 hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
pantry-tree: pantry-tree:
size: 1448 size: 13678
sha256: dc39ed0207b8b22d2713054421dbd5452baa9704df75bedf17f04f97a29f3d9a sha256: d57bcb2ad5e01fe7424abbcf9e58cf943027b5c4a8496d93625c57b6e1272274
original: original:
hackage: hsass-0.8.0 hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
- completed: - completed:
hackage: hlibsass-0.1.8.1@sha256:7005d0f3fee66e776300117f6bf31583bf310f58df6d7f552c8811bd406abfc8,2564 hackage: bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
pantry-tree: pantry-tree:
size: 8441 size: 844
sha256: c3c1fe56c35eed093772b9900d7038287b829d67960c6f96a82c9dc46b203db0 sha256: 5e6fd3de57a4d44257fb475433633939459e0294fafe79b21ff67aeb93a81591
original: original:
hackage: hlibsass-0.1.8.1 hackage: bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
- completed: - completed:
hackage: tz-0.1.3.3@sha256:b9de0c1b10825460ff14a237209a8bf7747f47979601d35621276556bf63d2ca,5086 hackage: byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
pantry-tree: pantry-tree:
size: 1180 size: 1095
sha256: ae6af45f3dba5a478ea9cc77c718f955fcc5c96f2dc0f4ede34c4a15a3e85ac1 sha256: 9ada4e1c418e8d9029edefdf664c64ff419ed1f02564e5a0dd28dd03e1e716a6
original: original:
hackage: tz-0.1.3.3 hackage: byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
- completed: - completed:
hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325 hackage: bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863
pantry-tree: pantry-tree:
size: 364 size: 1185
sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48 sha256: 3396c1b29577cff2491382d0b144fe586c75987e9ad28bc0cadbc88a97ee7315
original: original:
hackage: uuid-crypto-1.4.0.0 hackage: bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863
- completed: - completed:
hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593 hackage: commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
pantry-tree: pantry-tree:
size: 623 size: 1346
sha256: bce236365ebdc6e5c46f740876a6fb5ad688e8ee3b305933822ab027e5b5fd86 sha256: 991da6da60804286b9ea23a1522e18ceeabddfdf416787231db9fd047c163f53
original: original:
hackage: filepath-crypto-0.1.0.0 hackage: commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
- completed:
hackage: commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
pantry-tree:
size: 2927
sha256: 89e1ee05938d558834c397a3a22cdacc755a1941c144f4c1f3daf8a1ede943ce
original:
hackage: commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
- completed:
hackage: commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167
pantry-tree:
size: 326
sha256: aa88fb10bd382b8d942b51b2ad0b94f52a72a4e37c8085abc5c380964c7eeb7c
original:
hackage: commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167
- completed:
hackage: contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757
pantry-tree:
size: 442
sha256: 39ee8ba3b4725ed1057429cd1f613275bfecbc618f289559203bebb1ff4a259e
original:
hackage: contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757
- completed: - completed:
hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570 hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570
pantry-tree: pantry-tree:
size: 513 size: 513
sha256: 563e8d2b616ec3e0e7984d6b069095b6c3959065c0bb047fc8dd5809711a3e6b sha256: 563e8d2b616ec3e0e7984d6b069095b6c3959065c0bb047fc8dd5809711a3e6b
original: original:
hackage: cryptoids-0.5.1.0 hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570
- completed:
hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
pantry-tree:
size: 268
sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404
original:
hackage: cryptoids-types-1.0.0
- completed: - completed:
hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985 hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
pantry-tree: pantry-tree:
size: 359 size: 359
sha256: 6a5af7c785c230501fa6088ecf963c7de7463ab75b3f646510612f17dff69744 sha256: 6a5af7c785c230501fa6088ecf963c7de7463ab75b3f646510612f17dff69744
original: original:
hackage: cryptoids-class-0.0.0 hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
- completed: - completed:
hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
pantry-tree: pantry-tree:
size: 446 size: 268
sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373 sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404
original: original:
hackage: system-locale-0.3.0.0 hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
- completed: - completed:
hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
pantry-tree: pantry-tree:
size: 442 size: 623
sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea sha256: bce236365ebdc6e5c46f740876a6fb5ad688e8ee3b305933822ab027e5b5fd86
original: original:
hackage: hlint-test-0.1.0.0 hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
- completed: - completed:
hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 hackage: hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565
pantry-tree: pantry-tree:
size: 316 size: 11229
sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c sha256: 39b62f1f3f30c5a9e12f9c6a040d6863edb5ce81951452e649152a18145ee1bc
original: original:
hackage: pkcs7-1.0.0.1 hackage: hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565
- completed: - completed:
hackage: systemd-2.2.0@sha256:a41399ad921e3c90bb04219a66821631c17c94326961f9b6c71542abb042375f,1477 hackage: hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899
pantry-tree: pantry-tree:
size: 520 size: 1448
sha256: 188d4e07a62653b24091dc25c0222deb7a95037630d17a13327d269391050b7d sha256: b25aeb947cb4e0b550f8a6f226d06503ef0edcb54712ad9cdd4fb2b05bf16c7c
original: original:
hackage: systemd-2.2.0 hackage: hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899
- completed: - completed:
hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 hackage: ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742
pantry-tree: pantry-tree:
size: 3455 size: 1437
sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 sha256: c60e78361b92eebfa341027377787e39de5a16218ab605456cf4cf1de5f58b2a
original: original:
hackage: sandi-0.5 hackage: ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742
- completed: - completed:
hackage: storable-endian-0.2.6@sha256:cae7aac2bfe6037660b2cf294891867e69bcd74e739a3b3ea759e9ad99d6c889,801 hackage: natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411
pantry-tree: pantry-tree:
size: 223 size: 716
sha256: 6a8e43727f9b146238d4064fffc39d629f06622106922487fea922ec73aaee1e sha256: e1e5b16f53fe2a7378d38dcae5069dcc1c6e37f8e1473f091ae1f7d788b1c688
original: original:
hackage: storable-endian-0.2.6 hackage: natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411
- completed:
hackage: prometheus-metrics-ghc-1.0.1@sha256:d12cd520cbedff91bd193e0192056474723e953e69cdf817fb79494d110df390,1231
pantry-tree:
size: 293
sha256: b412f2835ee5791a7f4f634c416227b70bae50511666d9f68683e5e21b5c2821
original:
hackage: prometheus-metrics-ghc-1.0.1
- completed:
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
pantry-tree:
size: 307
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
original:
hackage: wai-middleware-prometheus-1.0.0
- completed:
hackage: pandoc-2.9.2@sha256:fa04b214c79328a4519093a5e82fe961a21179539165b98773a6f8bfb66bc662,36181
pantry-tree:
size: 88080
sha256: 95eeae57b3d00eb7fa1accacab31e032f4d535c8c2cb992891a20d694eb00339
original:
hackage: pandoc-2.9.2
- completed:
hackage: doclayout-0.3@sha256:06c03875b1645e6ab835c40f9b73fd959b6c4232c01d06f07debedfae46723f2,2059
pantry-tree:
size: 425
sha256: ed2fc2dd826fbba67cb8018979be437b215735fab90dcc49ad30b296f7005eed
original:
hackage: doclayout-0.3
- completed:
hackage: doctemplates-0.8.1@sha256:be34c3210d9ebbba1c10100e30d8c3ba3b6c34653ec2ed15f09e5d05055aa37d,3111
pantry-tree:
size: 2303
sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913
original:
hackage: doctemplates-0.8.1
- completed:
hackage: binary-instances-1@sha256:b17565598b8df3241f9b46fa8e3a3368ecc8e3f2eb175d7c28f319042a6f5c79,2613
pantry-tree:
size: 1035
sha256: 938ffc6990cac12681c657f7afa93737eecf335e6f0212d8c0b7c1ea3e0f40f4
original:
hackage: binary-instances-1
- completed:
hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190
pantry-tree:
size: 13678
sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
original:
hackage: acid-state-0.16.0
- completed:
hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
pantry-tree:
size: 492
sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283
original:
hackage: unidecode-0.1.0.4
- completed:
hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
pantry-tree:
size: 399
sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa
original:
hackage: token-bucket-0.1.0.1
- completed: - completed:
hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160
pantry-tree: pantry-tree:
size: 269 size: 269
sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c
original: original:
hackage: normaldistribution-1.1.0.3 hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160
- completed: - completed:
hackage: unordered-containers-0.2.11.0@sha256:ba70b8a9d7eebc2034bf92e5690b2dd71200e76aa9f3f93e0b6be3f27f244d18,4998 hackage: pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933
pantry-tree: pantry-tree:
size: 1416 size: 89646
sha256: d9b83f62373f509a441223f22f12e22e39b38ef3275dfca7c190a4795bebfed5 sha256: 08c8b20356152b9ee8161bacafda2dc1bed13d7db4cbf38ab040c1977b2d28d5
original: original:
hackage: unordered-containers-0.2.11.0 hackage: pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933
- completed: - completed:
hackage: base64-bytestring-1.1.0.0@sha256:190264fef9e65d9085f00ccda419137096d1dc94777c58272bc96821dc7f37c3,2334 hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
pantry-tree: pantry-tree:
size: 850 size: 316
sha256: 9ade5b5911df97c37b249b84f123297049f19578cae171c647bf47683633427c sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c
original: original:
hackage: base64-bytestring-1.1.0.0 hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
- completed: - completed:
hackage: base32-0.2.0.0@sha256:459f0ba6412d58adf1d6ab68d5dc68afddc9f65c69ad564c0a9643d5d8a7e96e,2608 hackage: primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843
pantry-tree: pantry-tree:
size: 1935 size: 368
sha256: 10c0a5a0a1d4c40b41f0190cf80b114fb527caf7458feec819d87ccfe41317cb sha256: 6dbc2fbfd70920a1de5a76d3715506edc0895c81a2f7b856d3abb027865d4605
original: original:
hackage: base32-0.2.0.0 hackage: primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843
- completed: - completed:
hackage: ghc-byteorder-4.11.0.0.10@sha256:5ee4a907279bfec27b0f9de7b8fba4cecfd34395a0235a7784494de70ad4e98f,1535 hackage: primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
pantry-tree: pantry-tree:
size: 169 size: 420
sha256: 54a4636f72c3b9eff7f081714cb1a7b809fc1f3b2e239caaf0d65d79aa9cb56f sha256: c882dca2a96b98d02b0d21875b651edb11ac67d90e736c0de7a92c410a19eb7f
original: original:
hackage: ghc-byteorder-4.11.0.0.10 hackage: primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
- completed:
hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233
pantry-tree:
size: 293
sha256: 0732085a4148b269bbc15eeb7ab422e65ac287878a42a7388a7b6e140ec740e5
original:
hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233
- completed:
hackage: run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883
pantry-tree:
size: 269
sha256: 06d5d7ecf185a26c15e48cda6c30e8865dae715c528a31466701272fae36d822
original:
hackage: run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883
- completed:
hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
pantry-tree:
size: 3455
sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350
original:
hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
- completed:
hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
pantry-tree:
size: 446
sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373
original:
hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
- completed:
hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
pantry-tree:
size: 399
sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa
original:
hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
- completed:
hackage: tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088
pantry-tree:
size: 320
sha256: 57009cc671ed8e43738be3bf7b1392461ad086083df633a2f4f9c7206a14a79c
original:
hackage: tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088
- completed:
hackage: tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
pantry-tree:
size: 1179
sha256: f6b8517eaaf3588afd1b3025fe6874a1ffff611001a803a26094c9cb40bc33f6
original:
hackage: tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
- completed:
hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
pantry-tree:
size: 492
sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283
original:
hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
- completed:
hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
pantry-tree:
size: 364
sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48
original:
hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
- completed:
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
pantry-tree:
size: 307
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
original:
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: 494635 size: 524392
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/12.yaml url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/8.yaml
sha256: a71c4293d8f461f455ff0d9815dfe4ab2f1adacd7e0bbc9a218f46ced8c4929a sha256: 21b78cd42414558e6e381666a51ab92b405f969ab1d675137fd55ef557edc9a4
original: lts-15.12 original: nightly-2020-08-08

2
test/Database/Fill.hs
View File

@ -43,7 +43,7 @@ insertFile residual fileTitle = do
fillDb :: DB () fillDb :: DB ()
fillDb = do fillDb = do
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)