From f07ad82c1dd3d5a0f93ea7416fe4c5bdeef000ea Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 15 Oct 2018 15:02:44 +0200 Subject: [PATCH] Pseudonym submission creation --- messages/uniworx/de.msg | 17 +- routes | 1 + src/CryptoID.hs | 1 + src/Foundation.hs | 53 ++++++- src/Handler/Corrections.hs | 149 +++++++++++++++++- src/Handler/Utils/Form.hs | 9 ++ src/Model/Types.hs | 9 ++ src/Utils/Form.hs | 4 +- src/Utils/Message.hs | 22 ++- templates/corrections-create.hamlet | 2 + templates/default-layout.lucius | 3 + .../submissionCreateDuplicates.hamlet | 6 + .../messages/submissionCreateExisting.hamlet | 9 ++ templates/sheetShow.cassius | 2 - templates/standalone/modal.julius | 1 + templates/widgets/navbar.hamlet | 22 ++- templates/widgets/pageactionprime.hamlet | 14 +- 17 files changed, 300 insertions(+), 24 deletions(-) create mode 100644 templates/corrections-create.hamlet create mode 100644 templates/messages/submissionCreateDuplicates.hamlet create mode 100644 templates/messages/submissionCreateExisting.hamlet delete mode 100644 templates/sheetShow.cassius diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ab5dc2045..5be0e189a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -363,4 +363,19 @@ SheetFiles: Übungsblatt-Dateien NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen -NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben \ No newline at end of file +NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben + +CorrCreate: Abgaben erstellen +UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" +InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}" +UnknownPseudonym pseudonym@Text: Unbekanntes Pseudonym "#{pseudonym}" +CorrectionPseudonyms: Abgaben-Pseudonyme +CorrectionPseudonymsTip: Eine Abgabe pro Zeile, bei Gruppenabgaben mehrere Pseudonyme (komma-separiert) innerhalb einer Zeile +PseudonymSheet: Übungsblatt +CorrectionPseudonymSheet termDesc@Text csh@CourseShorthand shn@SheetName: #{termDesc} > #{csh} > #{shn} +SheetGroupTooLarge sheetGroupDesc@Text: Abgabegruppe zu groß: #{sheetGroupDesc} +SheetNoRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" sind nicht als Gruppe registriert +SheetAmbiguousRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" enthält Mitglieder aus verschiedenen registrierten Gruppen +SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt nicht vorgesehen (#{sheetGroupDesc}) +SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert: +SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: \ No newline at end of file diff --git a/routes b/routes index f30623faa..2e8f1dd75 100644 --- a/routes +++ b/routes @@ -86,6 +86,7 @@ /corrections CorrectionsR GET POST !corrector !lecturer /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer +/corrections/create CorrectionsCreateR GET POST !corrector !lecturer !/#UUID CryptoUUIDDispatchR GET !free -- just redirect diff --git a/src/CryptoID.hs b/src/CryptoID.hs index e2f6361cb..4dc744228 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -38,6 +38,7 @@ import qualified Data.CaseInsensitive as CI decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId + , ''SheetId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Foundation.hs b/src/Foundation.hs index 6dfa15ce7..a8ebf44b8 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -159,6 +159,7 @@ data MenuItem = MenuItem , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) + , menuItemModal :: Bool } menuItemAccessCallback :: MenuItem -> Handler Bool @@ -610,7 +611,7 @@ instance Yesod UniWorX where let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute - menuTypes <- filterM (menuItemAccessCallback . menuItem) menu + menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu isAuth <- isJust <$> maybeAuthId @@ -633,7 +634,7 @@ instance Yesod UniWorX where let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents - navItems = map snd3 favourites ++ map (menuItemRoute . menuItem) menuTypes + navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs in \r -> Just r == highR favouriteTerms :: [TermIdentifier] @@ -665,7 +666,7 @@ instance Yesod UniWorX where isPageActionPrime (PageActionSecondary _) = True isPageActionPrime _ = False hasPageActions :: Bool - hasPageActions = any isPageActionPrime menuTypes + hasPageActions = any (isPageActionPrime . fst) menuTypes pc <- widgetToPageContent $ do addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" @@ -798,54 +799,63 @@ defaultLinks = -- Define the menu items of the header. { menuItemLabel = "Home" , menuItemIcon = Just "home" , menuItemRoute = HomeR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Impressum" , menuItemIcon = Just "book" , menuItemRoute = VersionR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Profil" , menuItemIcon = Just "cogs" , menuItemRoute = ProfileR + , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemIcon = Just "sign-in-alt" , menuItemRoute = AuthR LoginR + , menuItemModal = True , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemIcon = Just "sign-out-alt" , menuItemRoute = AuthR LogoutR + , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem { menuItemLabel = "Kurse" , menuItemIcon = Just "calendar-alt" , menuItemRoute = CourseListR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Semester" , menuItemIcon = Just "graduation-cap" , menuItemRoute = TermShowR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Korrekturen" , menuItemIcon = Just "check" , menuItemRoute = CorrectionsR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "users" , menuItemRoute = UsersR + , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } ] @@ -871,6 +881,7 @@ pageActions (HomeR) = { menuItemLabel = "AdminDemo" , menuItemIcon = Just "screwdriver" , menuItemRoute = AdminTestR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -879,6 +890,7 @@ pageActions (ProfileR) = { menuItemLabel = "Gespeicherte Daten anzeigen" , menuItemIcon = Just "book" , menuItemRoute = ProfileDataR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -887,6 +899,7 @@ pageActions TermShowR = { menuItemLabel = "Neues Semester anlegen" , menuItemIcon = Nothing , menuItemRoute = TermEditR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -895,12 +908,14 @@ pageActions (TermCourseListR tid) = { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Semster editieren" , menuItemIcon = Nothing , menuItemRoute = TermEditExistR tid + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -909,6 +924,7 @@ pageActions (CourseListR) = { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -917,6 +933,7 @@ pageActions (CourseR tid ssh csh CShowR) = { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetListR + , menuItemModal = False , menuItemAccessCallback' = do --TODO always show for lecturer let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False) muid <- maybeAuthId @@ -933,24 +950,28 @@ pageActions (CourseR tid ssh csh CShowR) = { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh CCorrectionsR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Kurs editieren" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh CEditR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Neuen Kurs klonen" , menuItemIcon = Nothing , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh) + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -959,6 +980,7 @@ pageActions (CourseR tid ssh csh SheetListR) = { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -967,6 +989,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR + , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -977,6 +1000,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = { menuItemLabel = "Abgabe ansehen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR + , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -987,18 +1011,21 @@ pageActions (CSheetR tid ssh csh shn SShowR) = { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SCorrR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SSubsR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Blatt Editieren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SEditR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -1007,6 +1034,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SCorrR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -1015,6 +1043,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = { menuItemLabel = "Korrektur" , menuItemIcon = Nothing , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -1023,12 +1052,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SSubsR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Edit " <> (CI.original shn) , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SEditR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -1037,8 +1068,22 @@ pageActions (CorrectionsR) = { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsUploadR + , menuItemModal = True , menuItemAccessCallback' = return True } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben erstellen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsCreateR + , menuItemModal = True + , menuItemAccessCallback' = runDB $ do + uid <- liftHandlerT requireAuthId + [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + return E.countRows + return $ (count :: Int) /= 0 + } ] pageActions _ = [] @@ -1130,6 +1175,8 @@ pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload +pageHeading CorrectionsCreateR + = Just $ i18nHeading MsgCorrCreate -- TODO: add headings for more single course- and single term-pages pageHeading _ diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 5d676b63f..1db0c9b95 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -26,6 +26,8 @@ import Handler.Utils.Submission import Handler.Utils.Table.Cells -- import Handler.Utils.Zip +import Utils.Lens + import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) @@ -33,6 +35,8 @@ import qualified Data.Map as Map import qualified Data.Text as Text +import Data.Semigroup (Sum(..)) + -- import Data.Time -- import qualified Data.Text as T -- import Data.Function ((&)) @@ -46,7 +50,6 @@ import Colonnade hiding (fromMaybe, singleton, bool) import qualified Database.Esqueleto as E -- import qualified Database.Esqueleto.Internal.Sql as E -import Control.Lens -- import Control.Monad.Writer (MonadWriter(..), execWriterT) -- import Network.Mime @@ -60,6 +63,18 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import Control.Monad.Trans.State (State, StateT(..), runState) +import qualified Control.Monad.State.Class as State + +import Data.Foldable (foldrM) +import Data.Traversable (for) + type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) => @@ -543,3 +558,135 @@ postCorrectionsUploadR = do defaultLayout $ do $(widgetFile "corrections-upload") + +getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html +getCorrectionsCreateR = postCorrectionsCreateR +postCorrectionsCreateR = do + uid <- requireAuthId + let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid + E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] + return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName) + mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) + mkOptList opts = do + opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts + MsgRenderer mr <- getMsgRenderer + return . mkOptionList $ do + (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts' + let tid' = mr $ ShortTermIdentifier (unTermKey tid) + return Option + { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn + , optionInternalValue = sid + , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet) + } + ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) + <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing + <*> areq (checkMMap textToList textFromList textareaField) (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing + <* submitButton + + case pseudonymRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess (sid, pss) -> do + runDB $ do + Sheet{..} <- get404 sid + (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) + forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText + now <- liftIO getCurrentTime + let + sps' :: [[SheetPseudonym]] + duplicate :: Set Pseudonym + ( sps' + , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate + ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do + known <- State.gets $ Map.member sheetPseudonymPseudonym + State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) + return $ bool (p :) id known ps + submission = Submission + { submissionSheet = sid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Just uid + , submissionRatingAssigned = Just now + , submissionRatingTime = Nothing + } + when (not $ null duplicate) + $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") + existingSubUsers <- E.select . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') + return submissionUser + when (not $ null existingSubUsers) $ do + (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers + $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") + let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' + forM_ sps'' $ \spGroup + -> let + sheetGroupDesc = Text.intercalate ", " $ map (review pseudonymText . sheetPseudonymPseudonym) spGroup + in case sheetGrouping of + Arbitrary maxSize + | genericLength sps > maxSize + -> addMessageI Error $ MsgSheetGroupTooLarge sheetGroupDesc + | otherwise + -> do + subId <- insert submission + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + RegisteredGroups -> do + groups <- E.select . E.from $ \submissionGroup -> do + E.where_ . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) + return $ submissionGroup E.^. SubmissionGroupId + case (groups :: [E.Value SubmissionGroupId]) of + [x] -> do + subId <- insert submission + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + [] -> do + subId <- insert submission + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc + _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc + NoGroups + | [SheetPseudonym{sheetPseudonymUser}] <- spGroup + -> do + subId <- insert submission + insert_ SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + | otherwise -> do + subId <- insert submission + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + + + defaultLayout $ do + $(widgetFile "corrections-create") + where + partition :: [[Either a b]] -> ([[b]], [a]) + partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) + + textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]]) + textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws) + = let + invalid :: [Text] + valid :: [[Pseudonym]] + (valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws + in case invalid of + (i:_) -> return . Left $ MsgInvalidPseudonym i + [] -> return $ Right valid + textFromList :: [[Pseudonym]] -> Textarea + textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText)) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0da366171..ac246b4e9 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -235,6 +235,15 @@ submissionModeField = selectFieldList , (MsgSheetUserSubmissions, UserSubmissions) ] +pseudonymWordField :: Field Handler PseudonymWord +pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist) + where + doCheck (CI.mk -> w) + | Just w' <- find (== w) pseudonymWordlist + = return $ Right w' + | otherwise + = return . Left $ MsgUnknownPseudonymWord (CI.original w) + zipFileField :: Bool -- ^ Unpack zips? -> Field Handler (Source Handler File) zipFileField doUnpack = Field{..} diff --git a/src/Model/Types.hs b/src/Model/Types.hs index d8f4c8820..b1e98b0b6 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -604,6 +604,15 @@ pseudonymWords = prism' pToWords pFromWords maxWord :: Num a => a maxWord = 0b111111111111 +pseudonymText :: Prism' Text Pseudonym +pseudonymText = iso tFromWords tToWords . pseudonymWords + where + tFromWords :: Text -> [PseudonymWord] + tFromWords = map CI.mk . Text.words + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + -- Type synonyms diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 0ccc1da6f..2ec9e3218 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -129,8 +129,8 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass) setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg } -addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a -addDatalist field mValues = field +addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a +addDatalist mValues field = field { fieldView = \fId fName fAttrs fRes fReq -> do listId <- newIdent values <- map toPathPiece . otoList <$> mValues diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index c6a518fae..b716e1a49 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveLift #-} module Utils.Message ( MessageClass(..) - , addMessage, addMessageI + , addMessage, addMessageI, addMessageIHamlet, addMessageFile ) where @@ -16,9 +18,14 @@ import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece) import qualified ClassyPrelude.Yesod (addMessage, addMessageI) import ClassyPrelude.Yesod hiding (addMessage, addMessageI) +import Text.Hamlet + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift) + data MessageClass = Error | Warning | Info | Success - deriving (Eq,Ord,Enum,Bounded,Show,Read) + deriving (Eq,Ord,Enum,Bounded,Show,Read,Lift) instance Universe MessageClass instance Finite MessageClass @@ -34,3 +41,14 @@ addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m () addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) + +addMessageIHamlet :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + , HandlerSite m ~ site + ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m () +addMessageIHamlet mc iHamlet = do + mr <- getMessageRender + ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) + +addMessageFile :: MessageClass -> FilePath -> ExpQ +addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] diff --git a/templates/corrections-create.hamlet b/templates/corrections-create.hamlet new file mode 100644 index 000000000..4b1de86e1 --- /dev/null +++ b/templates/corrections-create.hamlet @@ -0,0 +1,2 @@ +
+ ^{pseudonymWidget} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 5e682fba2..9ab544bb6 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -524,3 +524,6 @@ section:last-of-type { border-bottom: none; } +.pseudonym { + font-family: monospace; +} diff --git a/templates/messages/submissionCreateDuplicates.hamlet b/templates/messages/submissionCreateDuplicates.hamlet new file mode 100644 index 000000000..3d54bcd75 --- /dev/null +++ b/templates/messages/submissionCreateDuplicates.hamlet @@ -0,0 +1,6 @@ +_{MsgSheetDuplicatePseudonym} + +