Merge branch 'master' into 702-Enter-auf-CCommR-abfangen
This commit is contained in:
Gregor Kleen
commit
fd7843e342
22
CHANGELOG.md
22
CHANGELOG.md
@ -2,6 +2,28 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [25.13.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.12.1...v25.13.0) (2021-06-03)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **participants:** basic funktions added ([b96327b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b96327b18dafcd020c94bb84c6aafffb53544076))
|
||||
* **participants:** corrections ([fd11121](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fd111215447aff817399db379a4ca8e90eb73cff))
|
||||
* **participants:** corrections 2 ([d6ce0c4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d6ce0c47d92fac76ccdc59805fcdbd3ad932d3e3))
|
||||
* **participants:** first finished verson ([0a3fd23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0a3fd23e22a81b3636fb3ac224dce52df3f752f2))
|
||||
* **participants:** second version, Intersection added ([02354f0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02354f0998e61c236bc982848b9d709c927690f5))
|
||||
* **participants:** small Name-change ([6f3243d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6f3243d90bdc137e7f2ea9fe8e271f1cdc32dfbd))
|
||||
* **participants:** small Name-change ([eced778](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/eced7781ae346e285b7f3949917f23883b4dfaa8))
|
||||
* **submission-list:** bulk download submission originals ([d7f2d11](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d7f2d113929f9dc11291d6db916c8944ae158c3b)), closes [#707](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/707)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* better pathPieceJoined ([adcd5d5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/adcd5d5aee3d541fbf65a532b81d86f236575b7b))
|
||||
* valid binary ci instance ([8cfdd28](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8cfdd286517e0a9ca99dd31b9d220560adc6c93d))
|
||||
* **auth:** properly restrict various auth by school ([6f04a6b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6f04a6b693e99b573efcc94023dab0be4d6d83bb))
|
||||
* **memcached:** don't 500 upon hitting item size limit ([d79a539](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d79a539f71e8250f677ac4e0b42c9ffd4de50af5))
|
||||
|
||||
## [25.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.12.0...v25.12.1) (2021-05-19)
|
||||
|
||||
|
||||
|
||||
18
hoogle.sh
Executable file
18
hoogle.sh
Executable file
@ -0,0 +1,18 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
set -e
|
||||
|
||||
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
|
||||
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-doc
|
||||
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
|
||||
}
|
||||
|
||||
if [[ -d .stack-work-doc ]]; then
|
||||
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
|
||||
mv -v .stack-work-doc .stack-work
|
||||
trap move-back EXIT
|
||||
fi
|
||||
|
||||
stack hoogle -- ${@:-server --local --port $((${PORT_OFFSET:-0} + 8081))}
|
||||
@ -5,4 +5,7 @@ ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName !id
|
||||
ParticipantsIntersectCourses: Kurse
|
||||
CourseParticipantsRegisteredWithoutField n@Int: #{n} #{pluralDE n "Teilnehmeri:in wurde ohne assoziiertes Studienfach" "Teilnehmer:innen wurden ohne assoziierte Studienfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
ParticipantsCsvSheetName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)} Kursteilnehmer:innen
|
||||
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer:innen
|
||||
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer:innen
|
||||
ParticipantsIntersectNotOne: Schnitt
|
||||
AllUsersUnion: Vereinigung aller Teilnehmer:innen
|
||||
AllUsersIntersection: Schnitt aller Teilneher:innen
|
||||
@ -6,3 +6,6 @@ ParticipantsIntersectCourses: Courses
|
||||
CourseParticipantsRegisteredWithoutField n: #{n} #{pluralEN n "participant was" "participants were"} registered without #{pluralEN n "an associated field of study" "associated fields of study"}, because #{pluralEN n "it" "they"} could not be determined uniquely.
|
||||
ParticipantsCsvSheetName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)} Participants
|
||||
CourseParticipants n: Currently #{n} course #{pluralEN n "participant" "participants"}
|
||||
ParticipantsIntersectNotOne: Intersection
|
||||
AllUsersUnion: Union of all participants
|
||||
AllUsersIntersection: Intersection of all participants
|
||||
@ -190,4 +190,6 @@ Deficit: Defizit
|
||||
SubmissionDoneNever: Nie
|
||||
SubmissionDoneByFile: Je nach Bewertungsdatei
|
||||
SubmissionDoneAlways: Immer
|
||||
SheetGroupNoGroups: Keine Gruppenabgabe
|
||||
SheetGroupNoGroups: Keine Gruppenabgabe
|
||||
|
||||
CorrDownloadVersion !ident-ok: Version
|
||||
@ -189,4 +189,6 @@ Deficit: Deficit
|
||||
SubmissionDoneNever: Never
|
||||
SubmissionDoneByFile: According to correction file
|
||||
SubmissionDoneAlways: Always
|
||||
SheetGroupNoGroups: No group submission
|
||||
SheetGroupNoGroups: No group submission
|
||||
|
||||
CorrDownloadVersion !ident-ok: Version
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "25.12.1",
|
||||
"version": "25.13.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "25.12.1",
|
||||
"version": "25.13.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 25.12.1
|
||||
version: 25.13.0
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
@ -63,6 +63,7 @@ dependencies:
|
||||
- cryptoids-class
|
||||
- binary
|
||||
- binary-instances
|
||||
- binary-orphans
|
||||
- mtl
|
||||
- esqueleto >=3.1.0
|
||||
- mime-types
|
||||
|
||||
@ -707,4 +707,4 @@ addPWEntry :: User
|
||||
addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
|
||||
PWHashConf{..} <- getsYesod $ view _appAuthPWHash
|
||||
(AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
|
||||
void $ insert User{..}
|
||||
void $ insert User{..}
|
||||
@ -31,6 +31,9 @@ import qualified Data.Csv as Csv
|
||||
import Utils.Persist
|
||||
import Data.Proxy
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
instance PersistField (CI Text) where
|
||||
toPersistValue ciText = PersistLiteralEscaped . Text.encodeUtf8 $ CI.original ciText
|
||||
@ -108,3 +111,7 @@ instance Csv.ToField s => Csv.ToField (CI s) where
|
||||
|
||||
instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
|
||||
parseField = fmap CI.mk . Csv.parseField
|
||||
|
||||
instance (CI.FoldCase s, Binary s) => Binary (CI s) where
|
||||
get = CI.mk <$> Binary.get
|
||||
put = Binary.put . CI.original
|
||||
|
||||
@ -13,7 +13,7 @@ import Database.Persist.Sql
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
import Data.Binary.Instances ()
|
||||
import Data.Binary.Instances.Time as Import ()
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
@ -12,7 +12,7 @@ import Database.Persist.Types
|
||||
import Data.Time.Calendar.Instances ()
|
||||
import Data.Time.LocalTime.Instances ()
|
||||
import Data.Time.Clock.Instances ()
|
||||
import Data.Binary.Instances ()
|
||||
import Data.Binary.Instances.Time as Import ()
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
|
||||
@ -538,7 +538,7 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d
|
||||
-- Schools: access only to school admins
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
|
||||
isAdmin <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAdmin
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
@ -608,8 +608,8 @@ tagAccessPredicate AuthExamOffice = cacheAPSchoolFunction SchoolExamOffice (Just
|
||||
return Authorized
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice)
|
||||
isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
|
||||
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedSchoolExamOffice)
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
|
||||
@ -64,10 +64,11 @@ queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
|
||||
type UserTableData = DBRow ( Entity User
|
||||
, UserTableStudyFeatures
|
||||
, Entity AllocationUser
|
||||
, Int -- ^ Applied
|
||||
, Int -- ^ Assigned
|
||||
, Int -- ^ Vetoed
|
||||
, Int
|
||||
, Int
|
||||
, Int
|
||||
)
|
||||
-- ^ `Int`s are applied, assigned, vetoed in that order
|
||||
|
||||
resultUser :: Lens' UserTableData (Entity User)
|
||||
resultUser = _dbrOutput . _1
|
||||
|
||||
@ -109,9 +109,11 @@ postParticipantsIntersectR = do
|
||||
intersections = flip Map.fromSet coursePairs $ \(lCid, uCid)
|
||||
-> Set.size $ Map.findWithDefault Set.empty lCid courseUsers `Set.intersection` Map.findWithDefault Set.empty uCid courseUsers
|
||||
selfIntersections = Map.mapKeysMonotonic (\cid -> (cid, cid)) $ Set.size <$> courseUsers
|
||||
intersections' = Map.union intersections selfIntersections
|
||||
|
||||
return (courses, intersections')
|
||||
intersections' = Map.union intersections selfIntersections
|
||||
let allUsersUnion = Set.size . Set.unions $ Map.elems courseUsers
|
||||
let mapIntersect = mapIntersectNotOne courseUsers
|
||||
let allUsersIntersection = Set.size . setIntersections $ Map.elems courseUsers
|
||||
return (courses, intersections', mapIntersect, allUsersUnion, allUsersIntersection)
|
||||
|
||||
let
|
||||
symmIntersection intersections lCid uCid = fromMaybe 0 $ intersections !? (lCid, uCid) <|> intersections !? (uCid, lCid)
|
||||
|
||||
@ -65,12 +65,7 @@ subArchiveSource tid ssh csh shn cID sfType = maybeT_ $ do
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
case sfType of
|
||||
SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
|
||||
return sf
|
||||
_other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal)
|
||||
E.selectSource (E.from $ submissionFileQuery submissionID sfType) .| Conduit.map (Left . entityVal)
|
||||
|
||||
when (sfType == SubmissionCorrected) $
|
||||
maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating
|
||||
@ -96,4 +91,4 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
|
||||
when (null subs) $ do
|
||||
addMessageI Info MsgNoOpenSubmissions
|
||||
redirect CorrectionsR
|
||||
submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs
|
||||
submissionMultiArchive SubmissionDownloadAnonymous SubmissionCorrected $ Set.fromList subs
|
||||
|
||||
@ -442,7 +442,7 @@ instance Finite ActionCorrections
|
||||
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ActionCorrections id
|
||||
|
||||
data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous
|
||||
data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous SubmissionFileType
|
||||
| CorrSetCorrectorData (Maybe UserId)
|
||||
| CorrAutoSetCorrectorData SheetId
|
||||
| CorrDeleteData
|
||||
@ -491,11 +491,11 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
||||
|
||||
formResult actionRes $ \case
|
||||
(CorrDownloadData nonAnonymous, subs) -> do
|
||||
(CorrDownloadData nonAnonymous sft, subs) -> do
|
||||
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
setContentDisposition' $ Just ((addExtension `on` unpack) (mr MsgSubmissionArchiveName) extensionZip)
|
||||
sendResponse =<< submissionMultiArchive nonAnonymous ids
|
||||
sendResponse =<< submissionMultiArchive nonAnonymous sft ids
|
||||
(CorrSetCorrectorData (Just uid), subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
now <- liftIO getCurrentTime
|
||||
@ -616,7 +616,9 @@ type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionC
|
||||
|
||||
downloadAction, deleteAction :: ActionCorrections'
|
||||
downloadAction = ( CorrDownload
|
||||
, CorrDownloadData <$> apopt (selectField optionsFinite) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just SubmissionDownloadAnonymous)
|
||||
, CorrDownloadData
|
||||
<$> apopt (selectField optionsFinite) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just SubmissionDownloadAnonymous)
|
||||
<*> apopt (selectField optionsFinite) (fslI MsgCorrDownloadVersion) (Just SubmissionCorrected)
|
||||
)
|
||||
deleteAction = ( CorrDelete
|
||||
, pure CorrDeleteData
|
||||
|
||||
@ -241,7 +241,7 @@ memcachedBySet mExp (Binary.encode -> k) v = do
|
||||
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
|
||||
aad = memcachedAAD cKey mExpiry
|
||||
mCiphertext = AEAD.aead memcachedKey mNonce decrypted aad
|
||||
liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) memcachedConn
|
||||
liftIO . handle (\(_ :: Memcached.MemcachedException) -> return ()) $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) memcachedConn
|
||||
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
|
||||
|
||||
mLocal <- getsYesod appMemcachedLocal
|
||||
|
||||
@ -97,9 +97,8 @@ writeSubmissionPlan newSubmissionData = do
|
||||
-- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet!
|
||||
-- May throw an exception if there are no suitable correctors
|
||||
planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
|
||||
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
|
||||
-> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational)
|
||||
-- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
|
||||
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
|
||||
-> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational) -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
|
||||
planSubmissions sid restriction = do
|
||||
Sheet{..} <- getJust sid
|
||||
correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
@ -186,21 +185,30 @@ planSubmissions sid restriction = do
|
||||
|
||||
-- | How many additional submission should the given corrector be assigned, if possible?
|
||||
calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
|
||||
calculateDeficit corrector submissionState = (* byDeficit corrLoad) . getSum $ foldMap Sum deficitBySheet
|
||||
calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
|
||||
where
|
||||
deficitWeight :: SubmissionId -> (Maybe UserId, Map UserId _, SheetId) -> Rational
|
||||
deficitWeight subId (_, _, shId)
|
||||
| Just restr' <- restriction = prop $ subId `Set.member` restr'
|
||||
| otherwise = prop $ shId == sid
|
||||
where prop = bool (byDeficit corrLoad) 1
|
||||
|
||||
sumDeficitWeight :: Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
|
||||
sumDeficitWeight = getSum . ifoldMap (\subId x -> Sum $ deficitWeight subId x)
|
||||
|
||||
corrLoad = Map.findWithDefault mempty corrector sheetCorrectors
|
||||
|
||||
sheetSizes :: Map SheetId Integer
|
||||
sheetSizes :: Map SheetId Rational
|
||||
-- ^ Number of assigned submissions (to anyone) per sheet
|
||||
sheetSizes = Map.map getSum . Map.fromListWith mappend $ do
|
||||
(_, (Just _, _, sheetId)) <- Map.toList submissionState
|
||||
return (sheetId, Sum 1)
|
||||
(subId, x@(Just _, _, sheetId)) <- Map.toList submissionState
|
||||
return (sheetId, Sum $ deficitWeight subId x)
|
||||
|
||||
deficitBySheet :: Map SheetId Rational
|
||||
-- ^ Deficite of @corrector@ per sheet
|
||||
-- ^ Deficit of @corrector@ per sheet
|
||||
deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
|
||||
let assigned :: Rational
|
||||
assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
|
||||
assigned = sumDeficitWeight $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
|
||||
proportionSum :: Rational
|
||||
proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId
|
||||
where corrProportion (_, CorrectorExcused) = mempty
|
||||
@ -217,10 +225,10 @@ planSubmissions sid restriction = do
|
||||
tutCounts <- byTutorial
|
||||
guard $ not tutCounts
|
||||
guard $ corrState /= CorrectorExcused
|
||||
return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
|
||||
return . negate . sumDeficitWeight $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
|
||||
, fromMaybe 0 $ do
|
||||
guard $ corrState /= CorrectorExcused
|
||||
return . negate $ relativeProportion byProportion * fromIntegral sheetSize
|
||||
return . negate $ relativeProportion byProportion * sheetSize
|
||||
]
|
||||
| otherwise
|
||||
= assigned
|
||||
@ -260,20 +268,26 @@ planSubmissions sid restriction = do
|
||||
maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> ConduitT () DBFile (YesodDB UniWorX) ()
|
||||
submissionFileSource subId = E.selectSource (E.from $ submissionFileQuery subId)
|
||||
.| C.map entityVal
|
||||
.| sourceFiles'
|
||||
submissionFileSource :: SubmissionId -> SubmissionFileType -> ConduitT () DBFile (YesodDB UniWorX) ()
|
||||
submissionFileSource subId sft = E.selectSource (E.from $ submissionFileQuery subId sft)
|
||||
.| C.map entityVal
|
||||
.| sourceFiles'
|
||||
|
||||
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile)
|
||||
submissionFileQuery :: SubmissionId -> SubmissionFileType
|
||||
-> E.SqlExpr (Entity SubmissionFile)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity SubmissionFile))
|
||||
submissionFileQuery submissionID sf = E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
||||
submissionFileQuery submissionID sft sf = E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.where_ . E.not_ . E.exists . E.from $ \sf' ->
|
||||
E.where_ $ sf' E.^. SubmissionFileIsDeletion
|
||||
E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission
|
||||
E.&&. sf' E.^. SubmissionFileTitle E.==. sf E.^. SubmissionFileTitle
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
case sft of
|
||||
SubmissionOriginal ->
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
||||
E.||. sf E.^. SubmissionFileIsDeletion
|
||||
SubmissionCorrected -> do
|
||||
E.where_ . E.not_ . E.exists . E.from $ \sf' ->
|
||||
E.where_ $ sf' E.^. SubmissionFileIsDeletion
|
||||
E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission
|
||||
E.&&. sf' E.^. SubmissionFileTitle E.==. sf E.^. SubmissionFileTitle
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
return sf
|
||||
|
||||
data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous
|
||||
@ -287,8 +301,8 @@ nullaryPathPiece ''SubmissionDownloadAnonymous $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''SubmissionDownloadAnonymous id
|
||||
makePrisms ''SubmissionDownloadAnonymous
|
||||
|
||||
submissionMultiArchive :: SubmissionDownloadAnonymous -> Set SubmissionId -> Handler TypedContent
|
||||
submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
submissionMultiArchive :: SubmissionDownloadAnonymous -> SubmissionFileType -> Set SubmissionId -> Handler TypedContent
|
||||
submissionMultiArchive anonymous sft (Set.toList -> ids) = do
|
||||
(dbrunner, cleanup) <- getDBRunner
|
||||
|
||||
ratedSubmissions <- runDBRunner dbrunner $ do
|
||||
@ -376,7 +390,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
|
||||
fileEntitySource = do
|
||||
yieldM $ ratingFile cID rating
|
||||
submissionFileSource submissionID
|
||||
submissionFileSource submissionID sft
|
||||
|
||||
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
|
||||
|
||||
|
||||
@ -136,9 +136,10 @@ type WorkflowWorkflowData = DBRow
|
||||
, Entity WorkflowWorkflow
|
||||
, Maybe (Entity WorkflowInstance)
|
||||
, Maybe (Entity WorkflowInstanceDescription)
|
||||
, Maybe WorkflowWorkflowActionData -- ^ Last Action
|
||||
, Maybe WorkflowWorkflowActionData
|
||||
, [Entity User]
|
||||
)
|
||||
-- ^ @Maybe `WorkflowWorkflowActionData`@ corresponds to last action
|
||||
|
||||
type WorkflowWorkflowActionData = ( Maybe Text
|
||||
, UTCTime
|
||||
|
||||
@ -73,7 +73,16 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Min(..), Max(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..), Ap(..))
|
||||
import Data.Binary as Import (Binary)
|
||||
import Data.Binary.Instances as Import ()
|
||||
|
||||
import Data.Binary.Orphans as Import ()
|
||||
import Data.Binary.Instances.Aeson as Import ()
|
||||
import Data.Binary.Instances.Hashable as Import ()
|
||||
import Data.Binary.Instances.Scientific as Import ()
|
||||
import Data.Binary.Instances.Tagged as Import ()
|
||||
import Data.Binary.Instances.Text as Import ()
|
||||
import Data.Binary.Instances.Time as Import ()
|
||||
import Data.Binary.Instances.UnorderedContainers as Import ()
|
||||
import Data.Binary.Instances.Vector as Import ()
|
||||
|
||||
import Data.Dynamic as Import (Dynamic)
|
||||
import Data.Dynamic.Lens as Import
|
||||
|
||||
@ -214,7 +214,7 @@ data JobCtl = JobCtlFlush
|
||||
| JobCtlQueue Job
|
||||
| JobCtlGenerateHealthReport HealthCheck
|
||||
| JobCtlTest
|
||||
| JobCtlSleep Micro -- | For debugging
|
||||
| JobCtlSleep Micro -- ^ For debugging
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Hashable, NFData)
|
||||
|
||||
|
||||
@ -31,9 +31,7 @@ import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
|
||||
|
||||
instance Universe SubmissionFileType
|
||||
instance Finite SubmissionFileType
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
|
||||
|
||||
|
||||
25
src/Utils.hs
25
src/Utils.hs
@ -41,6 +41,7 @@ import Utils.HttpConditional as Utils
|
||||
import Utils.Persist as Utils
|
||||
import Utils.ARC as Utils
|
||||
import Utils.LRU as Utils
|
||||
import Utils.Set as Utils
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup(..))
|
||||
|
||||
@ -562,32 +563,10 @@ withoutSubsequenceBy cmp = go []
|
||||
| x `cmp` y = go acc a' b
|
||||
| otherwise = go (y:acc) a b
|
||||
|
||||
|
||||
----------
|
||||
-- Sets --
|
||||
----------
|
||||
|
||||
-- | Intersection of multiple sets. Returns empty set for empty input list
|
||||
setIntersections :: Ord a => [Set a] -> Set a
|
||||
setIntersections [] = Set.empty
|
||||
setIntersections (h:t) = foldl' Set.intersection h t
|
||||
|
||||
setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
|
||||
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
||||
|
||||
-- | Symmetric difference of two sets.
|
||||
setSymmDiff :: Ord a => Set a -> Set a -> Set a
|
||||
setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x)
|
||||
|
||||
setProduct :: Set a -> Set b -> Set (a, b)
|
||||
-- ^ Depends on the valid internal structure of the given sets
|
||||
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
|
||||
|
||||
setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
|
||||
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
|
||||
|
||||
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
|
||||
setFromFunc = Set.fromList . flip filter universeF
|
||||
-- all functions that used to be here are now in Utils.Set
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
|
||||
@ -52,11 +52,11 @@ recodeCsv encOpts toUser act = fromMaybe act $ do
|
||||
inp <- C.sinkLazy
|
||||
inp' <- recode inp
|
||||
sourceLazy inp' .| act
|
||||
-- | FormatXlsx <- fmt -> do
|
||||
-- inp <- C.sinkLazy
|
||||
-- archive <- throwLeft $ Zip.toArchiveOrFail inp
|
||||
-- archive' <- traverseOf (_zEntries . traverse . _Entrty . _3) recode archive
|
||||
-- sourceLazy (Zip.fromArchive inp') .| act
|
||||
-- -- | FormatXlsx <- fmt -> do
|
||||
-- -- inp <- C.sinkLazy
|
||||
-- -- archive <- throwLeft $ Zip.toArchiveOrFail inp
|
||||
-- -- archive' <- traverseOf (_zEntries . traverse . _Entrty . _3) recode archive
|
||||
-- -- sourceLazy (Zip.fromArchive inp') .| act
|
||||
| otherwise -> act
|
||||
where
|
||||
|
||||
|
||||
@ -9,6 +9,7 @@ module Utils.PathPiece
|
||||
, pathPieceJSON, pathPieceJSONKey
|
||||
, pathPieceBinary
|
||||
, pathPieceHttpApiData
|
||||
, pathPieceJoined
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -43,6 +44,9 @@ import Data.Generics.Product.Types
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
import Data.ByteString.Lazy.Base32
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
|
||||
mkFiniteFromPathPiece finiteType = do
|
||||
@ -94,6 +98,45 @@ finitePathPiece finiteType verbs = do
|
||||
[ clause [] (normalB $ return finExp) [] ]
|
||||
]
|
||||
|
||||
pathPieceJoined :: Text -> Prism' Text [Text]
|
||||
pathPieceJoined sep = prism' joinPP splitPP
|
||||
where
|
||||
b32Prefix = "b32."
|
||||
|
||||
textable :: [Text] -> Bool
|
||||
textable ts = maybe False (not . (b32Prefix `Text.isPrefixOf`)) (ts ^? _head)
|
||||
&& all (textable' . Text.splitOn sep) ts
|
||||
where textable' ts' = not (all Text.null ts')
|
||||
&& maybe False (not . Text.null) (ts' ^? _last)
|
||||
&& maybe False (not . Text.null) (ts' ^? _head)
|
||||
&& not (consecutiveNulls ts')
|
||||
&& all textable'' ts'
|
||||
textable'' t = none (`Text.isSuffixOf` t) [ Text.dropEnd i sep | i <- [0..(Text.length sep - 1)]]
|
||||
&& none (`Text.isPrefixOf` t) [ Text.drop i sep | i <- [0..(Text.length sep - 1)]]
|
||||
consecutiveNulls (x1:x2:xs) | Text.null x1, Text.null x2 = True
|
||||
| otherwise = consecutiveNulls $ x2 : xs
|
||||
consecutiveNulls _ = False
|
||||
|
||||
joinPP :: [Text] -> Text
|
||||
joinPP ts | textable ts
|
||||
= Text.intercalate sep $ map (Text.replace sep (sep <> sep)) ts
|
||||
| otherwise
|
||||
= b32Prefix <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode ts)
|
||||
splitPP :: Text -> Maybe [Text]
|
||||
splitPP t | Just b <- Text.stripPrefix b32Prefix t
|
||||
= if | Right bin <- decodeBase32 . fromStrict $ encodeUtf8 b
|
||||
, Right (onull -> True, _, ts) <- Binary.decodeOrFail bin
|
||||
-> Just ts
|
||||
| otherwise
|
||||
-> Nothing
|
||||
| otherwise = assertM' textable . go [] $ Text.splitOn sep t
|
||||
where go :: [Text] -> [Text] -> [Text]
|
||||
go acc [] = acc
|
||||
go acc (x1:x2:x3:xs) | Text.null x2 = go acc $ (x1 <> sep <> x3) : xs
|
||||
go acc (x:xs) = x : go acc xs
|
||||
|
||||
assertM' p x = x <$ guard (p x)
|
||||
|
||||
derivePathPiece :: Name -> (Text -> Text) -> Text -> DecsQ
|
||||
derivePathPiece adt mangle joinPP = do
|
||||
let mangle' = TH.lift . mangle . pack . nameBase
|
||||
@ -102,16 +145,16 @@ derivePathPiece adt mangle joinPP = do
|
||||
let
|
||||
toClause ConstructorInfo{..} = do
|
||||
vars <- mapM (const $ newName "x") constructorFields
|
||||
clause [conP constructorName $ map varP vars] (normalB [e|Text.intercalate joinPP $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) []
|
||||
clause [conP constructorName $ map varP vars] (normalB [e|review (pathPieceJoined joinPP) $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) []
|
||||
fromClause = do
|
||||
constrName <- newName "c"
|
||||
argsName <- newName "args"
|
||||
clause [viewP [e|Text.splitOn joinPP|] $ infixP (varP constrName) '(:) (varP argsName)]
|
||||
clause [viewP [e|preview (pathPieceJoined joinPP)|] $ conP 'Just [infixP (varP constrName) '(:) (varP argsName)]]
|
||||
(normalB [e|HashMap.lookup $(varE constrName) $(varE mapName) >>= ($ $(varE argsName))|])
|
||||
[]
|
||||
finDecs =
|
||||
[ pragInlD mapName NoInline FunLike AllPhases
|
||||
, sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|]
|
||||
, sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $typ)|]
|
||||
, funD mapName
|
||||
[ clause [] (normalB finClause) [] ]
|
||||
]
|
||||
@ -139,7 +182,7 @@ derivePathPiece adt mangle joinPP = do
|
||||
tvarName (PlainTV n) = n
|
||||
tvarName (KindedTV n _) = n
|
||||
sequence . (finDecs ++ ) . pure $
|
||||
instanceD (cxt iCxt) [t|PathPiece $(typ)|]
|
||||
instanceD (cxt iCxt) [t|PathPiece $typ|]
|
||||
[ funD 'toPathPiece
|
||||
(map toClause datatypeCons)
|
||||
, funD 'fromPathPiece
|
||||
@ -194,13 +237,13 @@ tuplePathPiece tupleDim = do
|
||||
|
||||
t <- newName "t"
|
||||
|
||||
instanceD tCxt [t|PathPiece $(tupleType)|]
|
||||
instanceD tCxt [t|PathPiece $tupleType|]
|
||||
[ funD 'toPathPiece
|
||||
[ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
|
||||
[ clause [tupP $ map varP xs] (normalB [e|review (pathPieceJoined tupleSeparator) $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
|
||||
]
|
||||
, funD 'fromPathPiece
|
||||
[ clause [varP t] (normalB . doE $ concat
|
||||
[ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
|
||||
[ pure $ bindS (listP $ map varP xs) [e|preview (pathPieceJoined tupleSeparator) $(varE t)|]
|
||||
, [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
|
||||
, pure $ noBindS [e|return $(tupE $ map varE xs')|]
|
||||
]) []
|
||||
|
||||
64
src/Utils/Set.hs
Normal file
64
src/Utils/Set.hs
Normal file
@ -0,0 +1,64 @@
|
||||
module Utils.Set
|
||||
( setIntersectNotOne
|
||||
, setIntersections
|
||||
, setMapMaybe
|
||||
, setSymmDiff
|
||||
, setProduct
|
||||
, setPartitionEithers
|
||||
, setFromFunc
|
||||
, mapIntersectNotOne
|
||||
) where
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map.Strict()
|
||||
import qualified Data.Map as Map
|
||||
import ClassyPrelude
|
||||
import Data.Universe
|
||||
import Control.Lens.Prism
|
||||
import Control.Lens
|
||||
|
||||
|
||||
-- | cardinal number of an intersection of a set and a list of sets
|
||||
setIntersectNotOne :: Ord a => Set a -> [Set a] -> Int
|
||||
setIntersectNotOne _ [] = 0
|
||||
setIntersectNotOne k r = Set.size $ Set.intersection k others where others = Set.unions r
|
||||
|
||||
----------------------------------------
|
||||
-- Functions for Handler.Participants --
|
||||
----------------------------------------
|
||||
|
||||
-- | extracts from a map a list of values (sets) without one specific entry (a)
|
||||
getAllElemsWithoutOne :: (Ord a) => Map a (Set b) -> a -> [Set b]
|
||||
getAllElemsWithoutOne m cid = Map.elems $ Map.delete cid m
|
||||
|
||||
-- | transforms values (sets) of a map to integers. The number gives information about how many entreis are not only in this one
|
||||
mapIntersectNotOne :: forall a b. (Ord a, Ord b) => Map a (Set b) -> Map a Int
|
||||
mapIntersectNotOne m = Map.mapWithKey f m where
|
||||
f :: a -> Set b -> Int
|
||||
f k _ = setIntersectNotOne (Map.findWithDefault Set.empty k m) (getAllElemsWithoutOne m k)
|
||||
|
||||
--------------------------
|
||||
-- Functions from Utils --
|
||||
--------------------------
|
||||
|
||||
-- | Intersection of multiple sets. Returns empty set for empty input list
|
||||
setIntersections :: Ord a => [Set a] -> Set a
|
||||
setIntersections [] = Set.empty
|
||||
setIntersections (h:t) = foldl' Set.intersection h t
|
||||
|
||||
setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
|
||||
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
||||
|
||||
-- | Symmetric difference of two sets.
|
||||
setSymmDiff :: Ord a => Set a -> Set a -> Set a
|
||||
setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x)
|
||||
|
||||
setProduct :: Set a -> Set b -> Set (a, b)
|
||||
-- ^ Depends on the valid internal structure of the given sets
|
||||
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
|
||||
|
||||
setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
|
||||
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
|
||||
|
||||
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
|
||||
setFromFunc = Set.fromList . flip filter universeF
|
||||
@ -98,6 +98,9 @@ extra-deps:
|
||||
- hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
- network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
|
||||
|
||||
- process-extras-0.7.4@sha256:4e79289131415796c181889c4a226ebab7fc3b0d27b164f65e1aad123ae9b9e3,1759
|
||||
- ListLike-4.7.4@sha256:613b2967df738010e8f6f6b7c47d615f6fe42081f68eba7f946d5de7552aa8a4,3778
|
||||
|
||||
resolver: nightly-2021-01-11
|
||||
compiler: ghc-8.10.4
|
||||
allow-newer: true
|
||||
|
||||
@ -534,6 +534,20 @@ packages:
|
||||
sha256: 97b797944cf068eb5fde620e005e253818f03068b2c20e9cfdd3aaa6cafcb678
|
||||
original:
|
||||
hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
|
||||
- completed:
|
||||
hackage: process-extras-0.7.4@sha256:4e79289131415796c181889c4a226ebab7fc3b0d27b164f65e1aad123ae9b9e3,1759
|
||||
pantry-tree:
|
||||
size: 1092
|
||||
sha256: ee89d385c9e822144698633b39f378904e42667aaca0d6ab577d7dea2b452c92
|
||||
original:
|
||||
hackage: process-extras-0.7.4@sha256:4e79289131415796c181889c4a226ebab7fc3b0d27b164f65e1aad123ae9b9e3,1759
|
||||
- completed:
|
||||
hackage: ListLike-4.7.4@sha256:613b2967df738010e8f6f6b7c47d615f6fe42081f68eba7f946d5de7552aa8a4,3778
|
||||
pantry-tree:
|
||||
size: 1854
|
||||
sha256: 50e22178b0713d0c8367ee6bc9f3b5026422b4b285837bdf9f4173a14db1e8bf
|
||||
original:
|
||||
hackage: ListLike-4.7.4@sha256:613b2967df738010e8f6f6b7c47d615f6fe42081f68eba7f946d5de7552aa8a4,3778
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 562265
|
||||
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Es kann nun eingestellt werden, ob, beim Download mehrerer Abgaben, die (wmgl.) korrigierte oder die originale Version heruntergeladen werden soll.
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
When bulk downloading submissions there now is a setting to choose between the original and corrected versions.
|
||||
@ -1,7 +1,7 @@
|
||||
$newline never
|
||||
<section>
|
||||
^{formWidget}
|
||||
$maybe (courses, intersections) <- intersectionsRes
|
||||
$maybe (courses, intersections, mapIntersect, allUsersUnion, allUsersIntersection) <- intersectionsRes
|
||||
<section>
|
||||
<div .scrolltable .scrolltable--bordered>
|
||||
<table .table .table--hover .table--condensed>
|
||||
@ -11,6 +11,8 @@ $maybe (courses, intersections) <- intersectionsRes
|
||||
$forall Entity _ Course{courseTerm, courseSchool, courseShorthand} <- courses
|
||||
<th .table__th .text--center>
|
||||
#{courseTerm}-#{courseSchool}-#{courseShorthand}
|
||||
<th .table__th .text--center>
|
||||
_{MsgParticipantsIntersectNotOne}
|
||||
<tbody>
|
||||
$forall (l, Entity lCid Course{courseTerm, courseSchool, courseShorthand}) <- lIxed courses
|
||||
<tr .table__row>
|
||||
@ -24,3 +26,12 @@ $maybe (courses, intersections) <- intersectionsRes
|
||||
<td .table__td .text--center :uCid == lCid:.table__td--automatic :uCid /= lCid:.heated :uCid /= lCid:style="--hotness: #{toPathPiece (intersectionHotness intersections lCid uCid)}">
|
||||
$if showNumber n lCid uCid
|
||||
#{n}
|
||||
$maybe num <- Map.lookup lCid mapIntersect
|
||||
<td .table__td .text--center .table__td--automatic>
|
||||
#{num}
|
||||
<p>
|
||||
_{MsgAllUsersUnion}: #
|
||||
#{allUsersUnion}
|
||||
<p>
|
||||
_{MsgAllUsersIntersection}: #
|
||||
#{allUsersIntersection}
|
||||
@ -217,8 +217,28 @@ spec = withApp . describe "Submission distribution" $ do
|
||||
| otherwise -> return ()
|
||||
)
|
||||
(\result -> do
|
||||
let secondResult = Map.map (Set.size . Set.filter (views _2 (== Just 1))) result
|
||||
let secondResult = Map.map (Set.size . Set.filter (views _2 (== Just 2))) result
|
||||
allEqual [] = True
|
||||
allEqual ((_, c) : xs) = all (\(_, c') -> c == c') xs
|
||||
secondResult `shouldSatisfy` allEqual . Map.toList
|
||||
)
|
||||
it "allows disabling deficit consideration with unequal proportions" $
|
||||
distributionExample
|
||||
(return . replicate 2 $ (550, [Just (Load Nothing 1 0), Just (Load Nothing 10 0)]))
|
||||
(\n subs corrs -> if
|
||||
| n < 2
|
||||
, Entity _ SheetCorrector{ sheetCorrectorUser = corrId } : _ <- corrs
|
||||
-> forM_ subs $ \(Entity subId _) ->
|
||||
update subId [SubmissionRatingBy =. Just corrId]
|
||||
| otherwise -> return ()
|
||||
)
|
||||
(\result -> do
|
||||
let secondResult = Map.map (Set.size . Set.filter (views _2 (== Just 2))) result
|
||||
secondResultNorm = imap go secondResult
|
||||
where go Nothing x = fromIntegral x
|
||||
go (Just SheetCorrector{..}) x = fromIntegral x / prop
|
||||
where prop = byProportion sheetCorrectorLoad
|
||||
allEqual [] = True
|
||||
allEqual ((_, c) : xs) = all (\(_, c') -> c == c') xs
|
||||
secondResultNorm `shouldSatisfy` allEqual . Map.toList
|
||||
)
|
||||
|
||||
18
test/Utils/PathPieceSpec.hs
Normal file
18
test/Utils/PathPieceSpec.hs
Normal file
@ -0,0 +1,18 @@
|
||||
module Utils.PathPieceSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "pathPieceJoined" $ do
|
||||
it "is a prism" . property $ \(NonEmpty (pack -> joinPP)) -> isPrism $ pathPieceJoined joinPP
|
||||
it "behaves as expected on some examples" $ do
|
||||
let test xs t = do
|
||||
review (pathPieceJoined "--") xs `shouldBe` t
|
||||
preview (pathPieceJoined "--") t `shouldBe` Just xs
|
||||
test ["foo", "bar"] "foo--bar"
|
||||
test ["foo--bar", "baz"] "foo----bar--baz"
|
||||
test ["baz", "foo--bar"] "baz--foo----bar"
|
||||
test ["baz--quux", "foo--bar"] "baz----quux--foo----bar"
|
||||
Loading…
Reference in New Issue
Block a user