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

refactor: hlint

Browse Source
This commit is contained in:
Gregor Kleen 2020-08-10 21:59:16 +02:00
parent 7512420131
commit 0fcb65f9fa
212 changed files with 983 additions and 962 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -46,7 +46,7 @@ sqlInTuple arity = do
xsV <- newName "xs"
let
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs)
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]

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

@ -24,7 +24,7 @@ persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
persistDirectoryWith settings dir = do
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
fn <- MaybeT . return . fromNullable $ takeFileName fp
guard . not $ head fn == '.'
guard $ head fn /= '.'
guard . not $ head fn == '#' && last fn == '#'
lift $ do

73
src/Foundation.hs
View File

@ -15,7 +15,8 @@ import Foundation.Routes as Foundation
import Import.NoFoundation hiding (embedFile)
import Database.Persist.Sql (runSqlPool)
import Database.Persist.Sql
( runSqlPool, transactionUndo, SqlReadBackend(..) )
import Text.Hamlet (hamletFile)
import Yesod.Auth.Message
@ -105,7 +106,6 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
import Web.Cookie
import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild))
import Database.Persist.Sql (transactionUndo, SqlReadBackend(..))
import qualified Control.Retry as Retry
import GHC.IO.Exception (IOErrorType(OtherError))
@ -635,7 +635,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid
guard $ maybe False (== authId) submissionRatingBy
guard $ Just authId == submissionRatingBy
return Authorized
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
@ -742,7 +742,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
-> guard $ visible
&& NTop (Just cTime) <= NTop examDeregisterUntil
ERegisterOccR occn -> do
occId <- (>>= hoistMaybe) . $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
if
| (registration >>= examRegistrationOccurrence . entityVal) == Just occId
-> guard $ visible
@ -879,7 +879,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
cTime <- NTop . Just <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime
return Authorized
@ -887,7 +887,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
cTime <- NTop . Just <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime
return Authorized
@ -895,7 +895,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
cTime <- NTop . Just <$> liftIO getCurrentTime
guard $ NTop courseNewsVisibleFrom <= cTime
return Authorized
@ -1195,7 +1195,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
when onlyActive $
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-- participant has at least one submission
when (not onlyActive) $
unless onlyActive $
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
@ -1205,7 +1205,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is member of a submissionGroup
when (not onlyActive) $
unless onlyActive $
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
@ -1222,7 +1222,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a tutorial user
when (not onlyActive) $
unless onlyActive $
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
@ -1254,7 +1254,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant has an exam result for this course
when (not onlyActive) $
unless onlyActive $
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
@ -1263,7 +1263,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is registered for an exam for this course
when (not onlyActive) $
unless onlyActive $
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
@ -1271,8 +1271,6 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return ()
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
@ -1628,10 +1626,10 @@ instance Yesod UniWorX where
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
SessionStorageMemcachedSql sqlStore
-> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
SessionStorageAcid acidStore
| appServerSessionAcidFallback
-> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
_other
-> return Nothing
where
@ -1664,7 +1662,7 @@ instance Yesod UniWorX where
notForBearer' (SessionBackend load)
= let load' req
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
, any (is _Just) $ map W.extractBearerAuth aHdrs
, any (is _Just . W.extractBearerAuth) aHdrs
= return (mempty, const $ return [])
| otherwise
= load req
@ -1893,7 +1891,7 @@ updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
updateFavourites cData = void . runMaybeT $ do
$logDebugS "updateFavourites" "Updating favourites"
now <- liftIO $ getCurrentTime
now <- liftIO getCurrentTime
uid <- MaybeT $ liftHandler maybeAuthId
mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
User{userMaxFavourites} <- MaybeT $ get uid
@ -2403,7 +2401,7 @@ instance YesodBreadcrumbs UniWorX where
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
mr <- getMessageRender
Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
cid <- decrypt cID
@ -3578,14 +3576,13 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return
case muid of
Nothing -> return False
(Just uid) -> do
ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return ok
, navType = NavTypeLink { navModal = False }
, navQuick' = navQuick NavQuickViewPageActionSecondary
, navForceActive = False
@ -4373,19 +4370,19 @@ pageHeading UsersR
= Just $ i18nHeading MsgUsers
pageHeading (AdminUserR _)
= Just $ i18nHeading MsgAdminUserHeading
pageHeading (AdminTestR)
= Just $ [whamlet|Internal Code Demonstration Page|]
pageHeading (AdminErrMsgR)
pageHeading AdminTestR
= Just [whamlet|Internal Code Demonstration Page|]
pageHeading AdminErrMsgR
= Just $ i18nHeading MsgErrMsgHeading
pageHeading (InfoR)
pageHeading InfoR
= Just $ i18nHeading MsgInfoHeading
pageHeading (LegalR)
pageHeading LegalR
= Just $ i18nHeading MsgLegalHeading
pageHeading (VersionR)
pageHeading VersionR
= Just $ i18nHeading MsgVersionHeading
pageHeading (HelpR)
pageHeading HelpR
= Just $ i18nHeading MsgHelpRequest
pageHeading ProfileR
@ -4408,8 +4405,8 @@ pageHeading (TermSchoolCourseListR tid ssh)
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school
pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseListR
= Just $ i18nHeading MsgCourseListTitle
pageHeading CourseNewR
= Just $ i18nHeading MsgCourseNewHeading
pageHeading (CourseR tid ssh csh CShowR)
@ -4608,7 +4605,7 @@ runSqlPoolRetry action pool = do
runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
runDBRead action = do
$logDebugS "YesodPersist" "runDBRead"
runSqlPoolRetry (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
-- How to run database actions.
instance YesodPersist UniWorX where
@ -4622,7 +4619,7 @@ instance YesodPersist UniWorX where
| dryRun = action <* transactionUndo
| otherwise = action
runSqlPoolRetry action' =<< appConnPool <$> getYesod
runSqlPoolRetry action' . appConnPool =<< getYesod
instance YesodPersistRunner UniWorX where
getDBRunner = do
@ -4852,7 +4849,7 @@ upsertCampusUser plugin ldapData = do
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
let matchingFeatures = case knownParents of
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
tell $ Set.singleton (subterm, Just studyFeaturesField)
if
@ -4911,12 +4908,12 @@ upsertCampusUser plugin ldapData = do
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
oldFs <- selectKeysList
([ StudyFeaturesUser ==. studyFeaturesUser
[ StudyFeaturesUser ==. studyFeaturesUser
, StudyFeaturesDegree ==. studyFeaturesDegree
, StudyFeaturesField ==. studyFeaturesField
, StudyFeaturesType ==. studyFeaturesType
, StudyFeaturesSemester ==. studyFeaturesSemester
])
]
[]
case oldFs of
[oldF] -> update oldF
@ -4933,7 +4930,7 @@ upsertCampusUser plugin ldapData = do
associateUserSchoolsByTerms userId
let
userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
userAssociatedSchools' = do
(k, v) <- ldapData
guard $ k == ldapUserSchoolAssociation
@ -4946,7 +4943,7 @@ upsertCampusUser plugin ldapData = do
forM_ ss $ \frag -> void . runMaybeT $ do
let
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
return schoolLdap
@ -5092,7 +5089,7 @@ instance YesodAuth UniWorX where
_other
-> acceptExisting
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
, dummyLogin <$ guard appAuthDummyLogin

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
return $ TestDownloadOptions
<$> pure randomSeed
<*> maxSizeRes
randomSeed
<$> maxSizeRes
<*> pure (2^20)
<*> 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)
instance Exception ApplicationFormException
applicationForm :: (Maybe AllocationId)
applicationForm :: Maybe AllocationId
-> CourseId
-> UserId
-> 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]
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
course <- getJust cid
(fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
(fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
@ -105,7 +105,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
(True , True , True , Nothing)
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
(True , True , True , Just _ )
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
(True , True , False, _ )
@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
let appFilesInfo = (,) <$> hasFiles <*> appCID
filesLinkView <- if
| fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
-> let filesLinkField = Field{..}
where
fieldParse _ _ = return $ Right Nothing
@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
-> return Nothing
filesWarningView <- if
| fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
| Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
| otherwise
-> return Nothing
@ -174,15 +174,15 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
in if
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
-> return $ (FormSuccess Nothing, Nothing)
-> return (FormSuccess Nothing, Nothing)
| otherwise
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
(vetoRes, vetoView) <- if
| afmLecturer
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
| otherwise
-> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
-> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
(pointsRes, pointsView) <- if
| afmLecturer
@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
, courseApplicationRatingTime = guardOn rated now
}
runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
audit $ TransactionCourseApplicationEdit cid uid appId
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction

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

@ -134,7 +134,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
, not $ Set.null existing
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
| otherwise
-> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
addView' = $(widgetFile "course/lecturerMassInput/add")
return (addRes'', addView')
@ -194,9 +194,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
_allIOtherCases -> do
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
return ( Just . toMidnight . termStart . entityVal <$> mbLastTerm
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm )
let
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
@ -238,7 +238,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
let
userAdmin = not $ null adminSchools
mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
allocationForm' =
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
@ -260,8 +260,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template)
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
(cfCourseId =<< template)
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
-- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
@ -322,7 +322,7 @@ validateCourse = do
guardValidation MsgCourseRegistrationEndMustBeAfterStart
$ NTop cfRegFrom <= NTop cfRegTo
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
$ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
$ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
unless userAdmin $
guardValidation MsgCourseUserMustBeLecturer
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
@ -521,7 +521,7 @@ courseEditHandler miButtonAction mbCourseForm = do
insert_ $ CourseEdit aid now cid
let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
upsertAllocationCourse cid $ cfAllocation res

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

@ -34,7 +34,7 @@ postCNEditR tid ssh csh cID = do
, courseNewsLastEdit = now
}
let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
addMessageI Success MsgCourseNewsEdited
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]

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

@ -96,7 +96,7 @@ participantInvitationConfig = InvitationConfig{..}
now <- liftIO getCurrentTime
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
res <- act -- insertUnique

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

@ -112,7 +112,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
let appFilesInfo = (,) <$> hasFiles <*> appCID
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
let filesLinkField = Field{..}
where
fieldParse _ _ = return $ Right Nothing
@ -130,7 +130,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|]
in void $ wforced filesLinkField (fslI filesMsg) Nothing
when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive

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

@ -110,9 +110,8 @@ getCShowR tid ssh csh = do
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
cID <- encrypt cid :: Handler CryptoUUIDCourse
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
<$> pure alloc
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
<$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
regForm <- if
| is _Just mbAid -> do
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)

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

@ -197,7 +197,7 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
_other -> mempty
@ -387,33 +387,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, sortUserSex (to queryUser . to (E.^. UserSex))
, single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
, single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
, single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
, single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
, single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
, single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
, single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
, single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
E.subSelectMaybe . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
, single ("tutorials" , SortColumn $ queryUser >>> \user ->
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
return . E.min_ $ tutorial E.^. TutorialName
)
, single $ ("exams" , SortColumn $ queryUser >>> \user ->
, single ("exams" , SortColumn $ queryUser >>> \user ->
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.&&. exam E.^. ExamCourse E.==. E.val cid
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
return . E.min_ $ exam E.^. ExamName
)
, single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
, single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
, mconcat
[ single ( SortingKey $ "sheet-" <> sheetName
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@ -433,38 +433,38 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ fltrUserMatriclenr queryUser
, single $ fltrUserNameEmail queryUser
, fltrUserSex (to queryUser . to (E.^. UserSex))
, single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
, single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
, single $ ("field" , FilterColumn $ E.anyFilter
, single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
, single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
, single ("field" , FilterColumn $ E.anyFilter
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
] )
, single $ ("degree" , FilterColumn $ E.anyFilter
, single ("degree" , FilterColumn $ E.anyFilter
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
] )
, single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
, single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
)
, single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
, single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
)
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
, single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
]
where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $
@ -615,7 +615,7 @@ postCUsersR tid ssh csh = do
hasExams = not $ null exams
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
examOccActs = examOccurrencesPerExam
& (map (bimap entityKey hoistMaybe))
& map (bimap entityKey hoistMaybe)
& Map.fromListWith (<>)
& imap (\k v -> case v of
[] -> pure (k, Nothing)

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)
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
<*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
<* aformSection MsgExamFormCorrection
<*> examCorrectorsForm (efCorrectors <$> template)
<* aformSection MsgExamFormParts
@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let
addRes'
| otherwise
= addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList oldDat
, not $ Set.null existing
@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
(res, formWidget) <- examPartForm' nudge Nothing csrf
let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
| any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
| any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
-> FormFailure [mr MsgExamPartAlreadyExists]
| otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
@ -336,10 +336,10 @@ validateExam = do
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)

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

@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
sumRegisteredCount = sumOf (folded . _3) occurrences
noBonus = fromMaybe False $ do
noBonus = (Just True ==) $ do
guardM $ bonusOnlyPassed <$> examBonusRule
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
sumPoints = fmap getSum . mconcat $ catMaybes
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
$(widgetFile "exam-show")

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

@ -597,7 +597,7 @@ postEUsersR tid ssh csh examn = do
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
when (is _Just examGradingRule) $
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
when (not $ null examParts) $
unless (null examParts) $
tell =<< optionsF [ ExamUserSetPartResult ]
when doBonus $
tell =<< optionsF [ ExamUserSetBonus ]
@ -651,7 +651,7 @@ postEUsersR tid ssh csh examn = do
(isPart, uid) <- lift $ guessUser' dbCsvNew
if
| isPart -> do
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
when (newFeatures /= oldFeatures) $
@ -693,7 +693,7 @@ postEUsersR tid ssh csh examn = do
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
newResults = sequence (csvEUserExamPartResults dbCsvNew)
<|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
<|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
newBonus, oldBonus :: Maybe Points
newBonus = join (csvEUserBonus dbCsvNew)

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_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed'
open examClosed' = E.maybe E.true (E.>. E.val now) examClosed'
return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
@ -150,11 +150,9 @@ getEOExamsR = do
case (exam, course, externalExam) of
(Just exam', Just course', Nothing) ->
(,,)
<$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
(Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
(Nothing, Nothing, Just externalExam') ->
(,,)
<$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
(Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
_other -> return $ error "Got exam & externalExam in same result"

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

@ -78,7 +78,7 @@ postEOFieldsR = do
oldFields <- runDB $ do
fields <- E.select . E.from $ \examOfficeField -> do
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields

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

@ -116,7 +116,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
return True
when saveOkay $
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
(FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
,(sfActiveFrom =<< template, MsgSheetActiveFrom)

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

@ -88,7 +88,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
<*> correctorForm (maybe mempty sfCorrectors template)
where
validateSheet :: FormValidator SheetForm Handler ()
validateSheet = do
@ -113,7 +113,7 @@ correctorForm loads' = wFormToAForm $ do
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads
let
@ -124,7 +124,7 @@ correctorForm loads' = wFormToAForm $ do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
return user
miAdd :: ListPosition
@ -150,7 +150,7 @@ correctorForm loads' = wFormToAForm $ do
miCell _ userIdent initRes nudge csrf = do
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
let
res :: FormResult (CorrectorState, Load)
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)

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 Crypto.KDF.HKDF as HKDF
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
data StorageKeyType
= SKTExamCorrect

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

@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do
MsgRenderer mr <- getMsgRenderer
case results of
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
pointsForm = case sheetType of
NotGraded
-> pure Nothing

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

@ -104,7 +104,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
submittorsForm' = maybeT submittorsForm $ do
restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor
submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
guard $ Map.size dat > 1
-- User may drop from submission only if it already exists; no directly creating submissions for other people
guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid
guard $ Just (Right uid) /= dat !? delPos || isJust msmid
miDeleteList dat delPos
@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do
return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
corrector <- fmap join $ traverse getEntity submissionRatingBy
corrector <- join <$> traverse getEntity submissionRatingBy
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)

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

@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
)
@ -201,7 +201,7 @@ colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (Form
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
@ -398,11 +398,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
criteria' = map CI.mk . unpack <$> Set.toList criteria
in any (\c -> c `isInfixOf` cid) criteria'
in any (`isInfixOf` cid) criteria'
)
]
, dbtFilterUI = fromMaybe mempty dbtFilterUI
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
, dbtParams
, dbtIdent = "corrections" :: Text
, dbtCsvEncode = noCsvEncode
@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
-- return (tableRes, statistics)
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
<&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
formResult actionRes $ \case
@ -610,7 +610,7 @@ assignAction selId = ( CorrSetCorrector
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
E.distinct $ return user

10
src/Handler/SystemMessage.hs
View File

@ -57,9 +57,8 @@ postMessageR cID = do
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
$ (,)
<$> fmap (Entity tId)
( SystemMessageTranslation
<$> pure systemMessageTranslationMessage
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
( SystemMessageTranslation systemMessageTranslationMessage
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
)
@ -71,9 +70,8 @@ postMessageR cID = do
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
$ SystemMessageTranslation
<$> pure smId
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
$ SystemMessageTranslation smId
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing

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
let
addRes'
| otherwise
= addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList oldDat
, not $ Set.null existing

6
src/Handler/Users.hs
View File

@ -74,7 +74,7 @@ getUsersR = postUsersR
postUsersR = do
MsgRenderer mr <- getMsgRenderer
let
dbtColonnade = mconcat $
dbtColonnade = mconcat
[ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid)
@ -233,7 +233,7 @@ postUsersR = do
formResult allUsersRes $ \case
AllUsersLdapSync -> do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
addMessageI Success $ MsgSynchroniseLdapAllUsersQueued
addMessageI Success MsgSynchroniseLdapAllUsersQueued
redirect UsersR
let allUsersWgt' = wrapForm allUsersWgt def
{ formSubmit = FormNoSubmit
@ -569,7 +569,7 @@ functionInvitationConfig = InvitationConfig{..}
itStartsAt = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ())
invitationInsertHook _ _ _ _ _ = id
invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
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 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 Data.Vector.Lens (vector)
import qualified Data.Set as Set
@ -201,7 +201,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
withNumericGrade :: Rational -> Rational
withNumericGrade
| 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
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
in (+) numericGrade
@ -244,7 +244,7 @@ doAllocation :: AllocationId
-> DB ()
doAllocation allocId now regs =
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
(CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
[ CourseParticipantRegistration =. now

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

@ -151,7 +151,7 @@ encodeCsv hdr = do
| otherwise
= encodeLazyByteString enc . decodeLazyByteString UTF8
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
, HandlerSite m ~ UniWorX

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

@ -175,7 +175,7 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM
]
, do
guard $ uncurry (/=) amPm
guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm]
guard . not $ all (all Char.isLower) [fst amPm, snd amPm]
Just
[ DateTimeFormat "%I:%M %P"
, DateTimeFormat "%I:%M:%S %P"

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

@ -367,7 +367,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
wordMap = Map.fromListWith (+) wordLengths
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'
)
(collapsedWords Array.!)

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

@ -34,7 +34,7 @@ sourceFile FileReference{..} = do
-> maybeT (throwM SourceFilesContentUnavailable) $ do
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
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
lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
| fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent

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

@ -22,7 +22,7 @@ import Handler.Utils.I18n
import Handler.Utils.Files
import Import
import Data.Char (chr, ord)
import Data.Char ( chr, ord, isDigit )
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
@ -55,8 +55,6 @@ import Data.Aeson.Text (encodeToLazyText)
import qualified Text.Email.Validate as Email
import Data.Text.Lens (unpacked)
import Data.Char (isDigit)
import Text.Blaze (toMarkup)
import Handler.Utils.Form.MassInput
@ -64,6 +62,8 @@ import Handler.Utils.Form.MassInput
import qualified Data.Binary as Binary
import qualified Data.ByteString.Base64.URL as Base64
{-# ANN module ("HLint: ignore Use const" :: String) #-}
----------------------------
-- Buttons (new version ) --
@ -289,11 +289,11 @@ multiActionOpts' minp acts mActsOpts fs defAction csrf = do
actsOpts <- liftHandler mActsOpts
let actsOpts' = OptionList
{ 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
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
actExternal = fmap optionExternalValue . actOption
actMessage = fmap (SomeMessage . optionDisplay) . actOption
@ -400,10 +400,10 @@ explainedMultiAction' :: forall action a.
explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
(actsOpts, actsReadExternal) <- liftHandler mActsOpts
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
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
actExternal = fmap optionExternalValue . actOption
actMessage = fmap (SomeMessage . optionDisplay) . actOption
@ -463,7 +463,7 @@ pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
pointsField = pointsFieldMinMax (Just 0) Nothing
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 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
| anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
| FormSuccess bounds' <- sequence $ map (view _1) bounds
| FormSuccess bounds' <- mapM (view _1) bounds
, not $ monotone bounds'
= [mr MsgPointsMustBeMonotonic]
| otherwise
@ -967,7 +967,7 @@ genericFileField mkOpts = Field{..}
.| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
.| C.filter (\(fTitle, _) ->
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
)
)
@ -1091,7 +1091,7 @@ fileUploadForm isReq mkFs = \case
UploadAny{..}
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
UploadSpecific{..}
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles)
where
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
specificFileForm spec@UploadSpecificFile{..}
@ -1445,7 +1445,7 @@ examOccurrenceField :: ( MonadHandler m
=> ExamId
-> Field m ExamOccurrenceId
examOccurrenceField eid
= hoistField liftHandler . selectField . (fmap $ fmap entityKey)
= hoistField liftHandler . selectField . fmap (fmap entityKey)
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
@ -1553,7 +1553,7 @@ multiUserField onlySuggested suggestions = Field{..}
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
user <- suggestions'
return $ ( E.case_
return ( E.case_
[ E.when_ (unique UserDisplayEmail user)
E.then_ (user E.^. UserDisplayEmail)
, E.when_ (unique UserEmail user)
@ -1768,7 +1768,7 @@ examField :: forall m.
, HandlerSite m ~ UniWorX
)
=> 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

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

@ -37,6 +37,8 @@ import Text.Hamlet (hamletFile)
import Algebra.Lattice.Ordered (Ordered(..))
{-# ANN module ("HLint: ignore Use const" :: String) #-}
$(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)
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
@ -330,9 +332,9 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
guard $ isn't _FormMissing btnRes
res
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)
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
[] -> return dimRes'
((_, BoxDimension dim) : _) -> do
@ -373,7 +375,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
delShapeUpdate
| [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
| 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
@ -490,7 +492,7 @@ massInputList :: forall handler cellResult ident msg.
-> (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
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 ->
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
, miDelete = miDeleteList
@ -544,7 +546,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
miAdd :: ListPosition -> Natural
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
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 f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@ -622,7 +624,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
miAdd :: ListPosition -> Natural
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
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 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)
[ 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
[ 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
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' ]
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

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

@ -274,7 +274,7 @@ sourceInvitations :: forall junction m backend.
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
where
decode (Entity _ (Invitation{invitationEmail, invitationData}))
decode (Entity _ Invitation{invitationEmail, invitationData})
= case fromJSON invitationData of
JSON.Success dbData -> return (invitationEmail, dbData)
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
startAct <- liftIO newEmptyTMVarIO
act' <- async $ do
$logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
$logDebugS "liftAsyncTimeout" "Waiting for confirmation..."
atomically $ takeTMVar startAct
$logDebugS "liftAsyncTimeout" $ "Confirmed."
$logDebugS "liftAsyncTimeout" "Confirmed."
act
act'' <- atomically $ do
hm <- readTVar memcachedAsync

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 Data.YAML.Aeson () -- ToYAML Value
import Data.List (elemIndex)
import Control.Monad.Trans.State.Lazy (evalState)
import qualified System.FilePath.Cryptographic as Explicit

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

@ -169,7 +169,7 @@ planSubmissions sid restriction = do
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys 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
let
@ -236,7 +236,7 @@ planSubmissions sid restriction = do
| otherwise
= 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
let
bestCorrectors :: Set UserId
@ -570,7 +570,7 @@ sinkSubmission userId mExists isUpdate = do
sinkSubmission' :: SubmissionId
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
Left file@(FileReference{..}) -> do
Left file@FileReference{..} -> do
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
@ -587,7 +587,7 @@ sinkSubmission userId mExists isUpdate = do
, submissionFileIsUpdate sf == isUpdate
]
underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
, submissionFileIsUpdate sf == False
, not (submissionFileIsUpdate sf)
]
anyChanges
| not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
@ -654,7 +654,7 @@ sinkSubmission userId mExists isUpdate = do
--
-- 'fileModified' is simply stored and never inspected while
-- 'submissionChanged' is always set to @now@.
let anyChanges = any (\f -> f submission submission') $
let anyChanges = any (\f -> f submission submission')
[ (/=) `on` submissionRatingPoints
, (/=) `on` submissionRatingComment
, (/=) `on` submissionRatingDone
@ -671,7 +671,7 @@ sinkSubmission userId mExists isUpdate = do
when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
tellSt mempty { sinkSubmissionNotifyRating = Any True }
lift $ replace submissionId submission'
sheetId <- lift $ getSheetId
sheetId <- lift getSheetId
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
where
a /~ b = not $ a ~~ b
@ -695,14 +695,14 @@ sinkSubmission userId mExists isUpdate = do
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
touchSubmission = do
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
when (not alreadyTouched) $ do
unless alreadyTouched $ do
now <- liftIO getCurrentTime
case isUpdate of
False -> lift . insert_ $ SubmissionEdit userId now submissionId
True -> do
Submission{submissionRatingTime} <- lift $ getJust submissionId
when (is _Just submissionRatingTime) $
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
if
| isUpdate -> do
Submission{submissionRatingTime} <- lift $ getJust submissionId
when (is _Just submissionRatingTime) $
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
| otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
tellSt $ mempty{ sinkSubmissionTouched = Any True }
getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
@ -716,15 +716,36 @@ sinkSubmission userId mExists isUpdate = do
finalize SubmissionSinkState{..} = do
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
when (not isUpdate) $
unless isUpdate $
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
return sf
case isUpdate of
False -> do
if
| 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
[ SubmissionFileSubmission ==. submissionId
, SubmissionFileIsUpdate ==. False
@ -733,27 +754,6 @@ sinkSubmission userId mExists isUpdate = do
forM_ shadowed $ \sfId' -> do
delete sfId'
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
| isUpdate
@ -829,7 +829,7 @@ sinkMultiSubmission userId isUpdate = do
| 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) ]
return (msId, fp)
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
(msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
case msId of
Nothing -> do
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
@ -838,7 +838,7 @@ sinkMultiSubmission userId isUpdate = do
cID <- encrypt sId
lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
feed sId $ Left f{ fileReferenceTitle = fileTitle' }
when (not $ null ignoredFiles) $ do
unless (null ignoredFiles) $ do
mr <- (toHtml .) <$> getMessageRender
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
@ -899,7 +899,7 @@ submissionDeleteRoute drRecords = DeleteRoute
uid <- maybeAuthId
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
if
| length subUsers >= 1
| not $ null subUsers
, maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
| 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 resultId = Colonnade.singleton (fromSortable header) body
where
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
header = Sortable Nothing $ i18nCell MsgCourseApplicationId
body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body

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

@ -92,7 +92,7 @@ import Colonnade.Encode hiding (row)
import Text.Hamlet (hamletFile)
import Data.List (elemIndex, inits)
import Data.List (inits)
import Data.Maybe (fromJust)

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

@ -106,11 +106,11 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
for ldapData $ upsertCampusUser UpsertCampusUser
if
| x@(Entity pid _) : [] <- users'
, fromMaybe False (matchesMatriculation x) || didLdap
| [x@(Entity pid _)] <- users'
, Just True == matchesMatriculation x || didLdap
-> return $ Just pid
| x@(Entity pid _) : x' : _ <- users'
, fromMaybe False (matchesMatriculation x) || didLdap
, Just True == matchesMatriculation x || didLdap
, GT <- x `closeness` x'
-> return $ Just pid
| 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.Hashable as Import
import Data.List as Import (elemIndex)
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
import Data.Text.Encoding.Error as Import(UnicodeException(..))
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 Control.Monad as Import (zipWithM)
import System.Random as Import (Random(..))
import Control.Monad.Random.Class as Import (MonadRandom(..))

2
src/Jobs.hs
View File

@ -492,7 +492,7 @@ jLocked jId act = do
liftIO . atomically $ writeTVar hasLock True
return val
unlock = whenM (liftIO . atomically $ readTVar hasLock) $
unlock = whenM (readTVarIO hasLock) $
runDB . setSerializable $
update jId [ QueuedJobLockInstance =. Nothing
, QueuedJobLockTime =. Nothing

2
src/Mail.hs
View File

@ -231,7 +231,7 @@ instance Exception MailException
class Yesod site => YesodMail site where
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 = pack <$> liftIO getHostName

46
src/Model/Migration.hs
View File

@ -105,17 +105,17 @@ requiresMigration :: forall m.
=> ReaderT SqlBackend m Bool
requiresMigration = mapReaderT (exceptT return return) $ do
initial <- either id (map snd) <$> parseMigration initialMigration
when (not $ null initial) $ do
unless (null initial) $ do
$logInfoS "Migration" $ intercalate "; " initial
throwError True
customs <- mapReaderT lift $ getMissingMigrations @_ @m
when (not $ Map.null customs) $ do
unless (Map.null customs) $ do
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
throwError True
automatic <- either id (map snd) <$> parseMigration migrateAll'
when (not $ null automatic) $ do
unless (null automatic) $ do
$logInfoS "Migration" $ intercalate "; " automatic
throwError True
@ -188,7 +188,7 @@ customMigrations = Map.fromListWith (>>)
other -> error $ "Could not parse theme: " <> show other
)
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
, whenM (tableExists "sheet") $ -- Better JSON encoding
, whenM (tableExists "sheet") -- Better JSON encoding
[executeQQ|
ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
@ -265,13 +265,13 @@ customMigrations = Map.fromListWith (>>)
_other -> error "Empty userDisplayName found"
)
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
, whenM (tableExists "sheet") $
, whenM (tableExists "sheet")
[executeQQ|
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|]
, whenM (columnExists "user" "plugin") $
, whenM (columnExists "user" "plugin")
-- <> is standard sql for /=
[executeQQ|
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
@ -280,7 +280,7 @@ customMigrations = Map.fromListWith (>>)
|]
)
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
, whenM (tableExists "user") $
, whenM (tableExists "user")
[executeQQ|
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]
)
, ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
, whenM (tableExists "cluster_config") $
, whenM (tableExists "cluster_config")
[executeQQ|
UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
|]
)
, ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|]
, whenM (tableExists "sheet") $
, whenM (tableExists "sheet")
[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', 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|]
, do
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_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_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_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" = '' |]
)
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
, 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;
|]
whenM (tableExists "user") $
whenM (tableExists "user")
[executeQQ|
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|]
, whenM (tableExists "exam") $
, whenM (tableExists "exam")
[executeQQ|
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|]
, whenM (tableExists "course_favourite") $
, whenM (tableExists "course_favourite")
[executeQQ|
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
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"
)
, ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
, whenM (tableExists "allocation") $
, whenM (tableExists "allocation")
[executeQQ|
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));
@ -605,7 +605,7 @@ customMigrations = Map.fromListWith (>>)
|]
)
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
, whenM (tableExists "user") $
, whenM (tableExists "user")
[executeQQ|
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
@ -617,7 +617,7 @@ customMigrations = Map.fromListWith (>>)
tableDropEmpty "exam_part_corrector"
)
, ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
, whenM (tableExists "study_features") $
, whenM (tableExists "study_features")
[executeQQ|
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);
@ -625,7 +625,7 @@ customMigrations = Map.fromListWith (>>)
|]
)
, ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|]
, whenM (tableExists "exam") $
, whenM (tableExists "exam")
[executeQQ|
UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS 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};|]
)
, ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|]
, whenM (tableExists "exam") $
, whenM (tableExists "exam")
[executeQQ|
ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
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|]
, whenM (tableExists "external_exam") $
, whenM (tableExists "external_exam")
[executeQQ|
ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
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";
|]
whenM (tableExists "session_file") $
whenM (tableExists "session_file")
[executeQQ|
ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
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)
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
data ExamResult' res = ExamAttended { examResult :: res }
| ExamNoShow
@ -170,7 +172,7 @@ derivePersistFieldJSON ''ExamOccurrenceRule
makePrisms ''ExamOccurrenceRule
examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
examOccurrenceRuleAutomatic x = or $ map ($ x)
examOccurrenceRuleAutomatic x = any ($ x)
[ is _ExamRoomSurname
, is _ExamRoomMatriculation
, is _ExamRoomRandom

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

@ -152,7 +152,7 @@ instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
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
type AuthLiteral = PredLiteral AuthTag

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

@ -23,7 +23,7 @@ import qualified Data.Text as Text
import qualified Data.Set as Set
import Data.List (elemIndex, genericIndex)
import Data.List (genericIndex)
import Data.Bits
import Data.Text.Metrics (damerauLevenshtein)
@ -137,7 +137,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
pseudonymWords :: Fold Text PseudonymWord
pseudonymWords = folding
$ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
$ \(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
distance = damerauLevenshtein `on` CI.foldedCase
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1

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) []
| fName <- Set.toList fileNames
]
, funD 'fromPathMultiPiece $
, funD 'fromPathMultiPiece
[ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
]
]

6
src/Utils.hs
View File

@ -51,6 +51,7 @@ import Control.Lens as Utils (none)
import Control.Lens.Extras (is)
import Data.Set.Lens
import Control.Monad (zipWithM)
import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
@ -703,7 +704,7 @@ shortCircuitM sc binOp mx my = do
x <- mx
if
| sc x -> return x
| otherwise -> binOp <$> pure x <*> my
| otherwise -> binOp x <$> my
guardM :: MonadPlus m => m Bool -> m ()
@ -1170,8 +1171,7 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
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 ->
fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
where
uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
uc = unsafeCoerce

6
src/Utils/Allocation.hs
View File

@ -20,7 +20,7 @@ import Control.Monad.Writer (tell)
import Control.Monad.ST
import Data.List ((!!), elemIndex)
import Data.List ((!!))
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
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
isUnstableWith cn' (stO, cnO) = Just True == (do
c' <- matchingCourse st cn'
rMe <- courseRating c' (st, cn')
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
-> 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)
=> 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)
=> Unique record -> ReaderT backend m Bool

22
src/Utils/Form.hs
View File

@ -718,9 +718,9 @@ selectField' optMsg mkOpts = Field{..}
let
rendered = case val of
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
[whamlet|
$newline never
@ -757,9 +757,9 @@ radioField' optMsg mkOpts = Field{..}
let
rendered = case val of
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
[whamlet|
$newline never
@ -800,9 +800,9 @@ radioGroupField optMsg mkOpts = Field{..}
let
rendered = case val of
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
[whamlet|
$newline never
@ -885,9 +885,7 @@ renderFieldViews :: ( RenderMessage site AFormMessage
)
=> FormLayout -> [FieldView site] -> WidgetT site IO ()
renderFieldViews layout
= join
. fmap (view _1)
. generateFormPost
= view _1 <=< generateFormPost
. lmap (const mempty)
. renderWForm layout
. (FormSuccess () <$)
@ -1168,21 +1166,21 @@ mreq :: forall m a.
, RenderMessage (HandlerSite m) (ValueRequired (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.
( MonadHandler m
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
)
=> 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.
( MonadHandler m
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
)
=> 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)

2
src/Utils/Metrics.hs
View File

@ -24,6 +24,8 @@ import qualified Network.HTTP.Types as HTTP
import Yesod.Core.Types (HandlerData(..), GHState(..))
{-# ANN module ("HLint: ignore Use even" :: String) #-}
histogramBuckets :: Rational -- ^ min
-> Rational -- ^ max

2
src/Utils/Occurrences.hs
View File

@ -50,7 +50,7 @@ normalizeOccurrences initial
| otherwise
= 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
[] -> return ()
((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)

4
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
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) $
Just MemcachedSqlStorageAEADCiphertextTooShort
@ -161,7 +161,7 @@ replaceSession' isReplace s@MemcachedSqlStorage{..} seNewSession@(review memcach
whenIsJust mOld $ \seExistingSession ->
throwM @_ @(StorageException (MemcachedSqlStorage sess)) $ SessionAlreadyExists{..}
nonce <- liftIO $ AEAD.newNonce
nonce <- liftIO AEAD.newNonce
let encSession = Saltine.encode nonce <> AEAD.aead mcdSqlMemcachedKey nonce encoded encSessId
encSessId = LBS.toStrict $ Binary.encode sessId
handleFailure

1
stack.yaml
View File

@ -151,6 +151,7 @@ extra-deps:
- 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

21
stack.yaml.lock
View File

@ -150,6 +150,20 @@ packages:
subdir: colonnade
git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git
commit: f8170266ab25b533576e96715bedffc5aa4f19fa
- completed:
cabal-file:
size: 9845
sha256: 674630347209bc5f7984e8e9d93293510489921f2d2d6092ad1c9b8c61b6560a
name: minio-hs
version: 1.5.2
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
pantry-tree:
size: 4560
sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
original:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
- completed:
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
pantry-tree:
@ -367,6 +381,13 @@ packages:
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:
- completed:
size: 524392