diff --git a/CHANGELOG.md b/CHANGELOG.md index 724c4dbf5..15338d42b 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/hoogle.sh b/hoogle.sh new file mode 100755 index 000000000..e11f9a92e --- /dev/null +++ b/hoogle.sh @@ -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))} diff --git a/messages/uniworx/categories/courses/participants/de-de-formal.msg b/messages/uniworx/categories/courses/participants/de-de-formal.msg index ae957c977..023280fb6 100644 --- a/messages/uniworx/categories/courses/participants/de-de-formal.msg +++ b/messages/uniworx/categories/courses/participants/de-de-formal.msg @@ -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 \ No newline at end of file +CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer:innen +ParticipantsIntersectNotOne: Schnitt +AllUsersUnion: Vereinigung aller Teilnehmer:innen +AllUsersIntersection: Schnitt aller Teilneher:innen \ No newline at end of file diff --git a/messages/uniworx/categories/courses/participants/en-eu.msg b/messages/uniworx/categories/courses/participants/en-eu.msg index 59ea336fb..e67ae634c 100644 --- a/messages/uniworx/categories/courses/participants/en-eu.msg +++ b/messages/uniworx/categories/courses/participants/en-eu.msg @@ -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 \ No newline at end of file diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index d869d66fe..d094355da 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -190,4 +190,6 @@ Deficit: Defizit SubmissionDoneNever: Nie SubmissionDoneByFile: Je nach Bewertungsdatei SubmissionDoneAlways: Immer -SheetGroupNoGroups: Keine Gruppenabgabe \ No newline at end of file +SheetGroupNoGroups: Keine Gruppenabgabe + +CorrDownloadVersion !ident-ok: Version \ No newline at end of file diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index 107999eae..a10d9e8de 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -189,4 +189,6 @@ Deficit: Deficit SubmissionDoneNever: Never SubmissionDoneByFile: According to correction file SubmissionDoneAlways: Always -SheetGroupNoGroups: No group submission \ No newline at end of file +SheetGroupNoGroups: No group submission + +CorrDownloadVersion !ident-ok: Version \ No newline at end of file diff --git a/package-lock.json b/package-lock.json index 3cc3f0e9d..6ac7fdf93 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.12.1", + "version": "25.13.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d939cee45..46f59e42f 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.12.1", + "version": "25.13.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index d86b5fcea..e71e5531a 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Application.hs b/src/Application.hs index bcaf1edda..ab3bb8886 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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{..} \ No newline at end of file diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index eadbd421b..cdde140f5 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -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 diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 657a86800..24eb0902c 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -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 diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index cf05894f2..3c79521d1 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -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) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index ff547456f..a4ca5385a 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 56f517607..f5769f82f 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -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 diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index 70bd2383f..cbeb69ab2 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -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) diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 59adad1c1..897fcf7d1 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -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 diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index abae00689..c5296a64a 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -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 diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index de06f6103..593ddf14e 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 7ce366355..a2b329f2f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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 } diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index b29e0ff44..ae06a8083 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index c8854d786..951855d26 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 23402d381..ded70d4af 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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) diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 21fed7e4b..49dfd12ce 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 60fc69175..0ba53c9fc 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Csv/Mail.hs b/src/Utils/Csv/Mail.hs index d79c77331..86efb5073 100644 --- a/src/Utils/Csv/Mail.hs +++ b/src/Utils/Csv/Mail.hs @@ -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 diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index c47419799..e1aaa3a9b 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -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')|] ]) [] diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs new file mode 100644 index 000000000..01794701e --- /dev/null +++ b/src/Utils/Set.hs @@ -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 \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index f75ba5f9a..1d1e9b98b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock index c5af573fd..c8acf905a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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 diff --git a/templates/i18n/changelog/bulk-download-original-submissions.de-de-formal.hamlet b/templates/i18n/changelog/bulk-download-original-submissions.de-de-formal.hamlet new file mode 100644 index 000000000..5f3bbdf15 --- /dev/null +++ b/templates/i18n/changelog/bulk-download-original-submissions.de-de-formal.hamlet @@ -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. diff --git a/templates/i18n/changelog/bulk-download-original-submissions.en-eu.hamlet b/templates/i18n/changelog/bulk-download-original-submissions.en-eu.hamlet new file mode 100644 index 000000000..af6b24182 --- /dev/null +++ b/templates/i18n/changelog/bulk-download-original-submissions.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +When bulk downloading submissions there now is a setting to choose between the original and corrected versions. diff --git a/templates/participants-intersect.hamlet b/templates/participants-intersect.hamlet index 5e24254ed..eeaa544a0 100644 --- a/templates/participants-intersect.hamlet +++ b/templates/participants-intersect.hamlet @@ -1,7 +1,7 @@ $newline never
^{formWidget} -$maybe (courses, intersections) <- intersectionsRes +$maybe (courses, intersections, mapIntersect, allUsersUnion, allUsersIntersection) <- intersectionsRes
@@ -11,6 +11,8 @@ $maybe (courses, intersections) <- intersectionsRes $forall Entity _ Course{courseTerm, courseSchool, courseShorthand} <- courses $forall (l, Entity lCid Course{courseTerm, courseSchool, courseShorthand}) <- lIxed courses @@ -24,3 +26,12 @@ $maybe (courses, intersections) <- intersectionsRes
#{courseTerm}-#{courseSchool}-#{courseShorthand} + + _{MsgParticipantsIntersectNotOne}
$if showNumber n lCid uCid #{n} + $maybe num <- Map.lookup lCid mapIntersect + + #{num} +

+ _{MsgAllUsersUnion}: # + #{allUsersUnion} +

+ _{MsgAllUsersIntersection}: # + #{allUsersIntersection} \ No newline at end of file diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index 8cf5bb3a6..b0626592b 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -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 + ) diff --git a/test/Utils/PathPieceSpec.hs b/test/Utils/PathPieceSpec.hs new file mode 100644 index 000000000..9d66a3510 --- /dev/null +++ b/test/Utils/PathPieceSpec.hs @@ -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"