diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c42f8cb0c..49184101c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -117,6 +117,7 @@ CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseUserDeregister: Abmelden CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +CourseUserSendMail: Mitteilung verschicken CourseLecturers: Kursverwalter CourseLecturer: Dozent @@ -530,6 +531,7 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} +CommCourseSubject: Kursmitteilung MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen @@ -687,6 +689,7 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer @@ -757,6 +760,23 @@ MassInputDeleteCell: Entfernen NavigationFavourites: Favoriten +CommSubject: Betreff +CommBody: Nachricht +CommRecipients: Empfänger +CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht. +CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert +CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt + +CommCourseHeading: Kursmitteilung + +RecipientCustom: Weitere Empfänger + +RGCourseParticipants: Kursteilnehmer +RGCourseLecturers: Kursverwalter +RGCourseCorrectors: Korrektoren + +MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg) +MultiEmailFieldTip: Je nach Browser sind mehrere komma-separierte E-Mail-Addressen möglich EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt. LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen diff --git a/routes b/routes index 87401b00d..161383a7e 100644 --- a/routes +++ b/routes @@ -81,6 +81,7 @@ /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET + /communication CCommR GET POST /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !corrector diff --git a/src/Data/Set/Instances.hs b/src/Data/Set/Instances.hs new file mode 100644 index 000000000..9dc1c48cd --- /dev/null +++ b/src/Data/Set/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Set.Instances + ( + ) where + +import ClassyPrelude + +import Data.Set (Set) +import qualified Data.Set as Set + + +instance (Ord a, Hashable a) => Hashable (Set a) where + hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs diff --git a/src/Data/Universe/TH.hs b/src/Data/Universe/TH.hs new file mode 100644 index 000000000..1dd097e9f --- /dev/null +++ b/src/Data/Universe/TH.hs @@ -0,0 +1,69 @@ +module Data.Universe.TH + ( finiteEnum + , deriveUniverse + , deriveFinite + ) where + +import Prelude + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +import Data.Universe +import Data.Universe.Helpers (interleave) + +import Control.Monad (unless) + +import Data.List (elemIndex) + + +finiteEnum :: Name -> DecsQ +-- ^ Declare generic `Enum`- and `Bounded`-Instances given `Finite`- and `Eq`-Instances +finiteEnum tName = do + DatatypeInfo{..} <- reifyDatatype tName + + let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars + tUniverse = [e|universeF :: [$(datatype)]|] + + [d| + instance Bounded $(datatype) where + minBound = head $(tUniverse) + maxBound = last $(tUniverse) + + instance Enum $(datatype) where + toEnum n + | n >= 0 + , n < length $(tUniverse) + = $(tUniverse) !! n + | otherwise = error $ "toEnum " ++ $(stringE $ nameBase tName) ++ ": out of bounds" + fromEnum = fromMaybe (error $ "fromEnum " ++ $(stringE $ nameBase tName) ++ ": invalid `universeF`") . flip elemIndex $(tUniverse) + + enumFrom x = map toEnum [fromEnum x .. fromEnum (maxBound :: $(datatype))] + enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. fromEnum (maxBound :: $(datatype))] + |] + +deriveUniverse, deriveFinite :: Name -> DecsQ +deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|] +deriveFinite tName = fmap concat . sequence $ + [ deriveUniverse' [e|concat|] [e|universeF|] tName + , do + DatatypeInfo{..} <- reifyDatatype tName + [d|instance Finite $(foldl appT (conT datatypeName) $ map pure datatypeVars)|] + ] + +deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ +deriveUniverse' interleaveExp universeExp tName = do + DatatypeInfo{..} <- reifyDatatype tName + + let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars + consUniverse ConstructorInfo{..} = do + unless (null constructorVars) $ + fail "Constructors with variables no supported" + + foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields + + pure <$> instanceD (cxt []) [t|Universe $(datatype)|] + [ funD 'universe + [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) [] + ] + ] diff --git a/src/Foundation.hs b/src/Foundation.hs index cc919e8b4..4dbbba963 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -186,8 +186,9 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- Convenience Type for Messages -type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers +-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers +type IntMaybe = Maybe Int +type TextList = [Text] -- | Convenience function for i18n messages definitions maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text @@ -1259,6 +1260,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) @@ -1636,6 +1638,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseCommunication + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit @@ -2325,11 +2335,15 @@ instance YesodMail UniWorX where pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do - void setMailObjectId + void setMailObjectIdRandom setDateCurrent replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) - mail <* setMailSmtpData + (mRes, smtpData) <- listen mail + unless (view _MailSmtpDataSet smtpData) + setMailSmtpData + + return mRes instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 32f8db822..aba016f41 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -205,7 +205,7 @@ postAdminTestR = do -- The actual call to @massInput@ is comparatively simple: - ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing + ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 42c21d62a..b82a85ea0 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -350,7 +350,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \frag -> do - (actionRes, action) <- multiAction actions Nothing + (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = _1 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c084c139f..593b08f7d 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,6 +9,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete import Handler.Utils.Database @@ -27,6 +28,7 @@ import Data.Monoid (Last(..)) import Data.Maybe (fromJust) import qualified Data.Set as Set +import Data.Map ((!)) import qualified Data.Map as Map import qualified Database.Esqueleto as E @@ -637,34 +639,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new FormFailure errs -> FormFailure errs FormMissing -> FormMissing - addView' = toWidget csrf >> fvInput addView >> fvInput btn + addView' = $(widgetFile "course/lecturerMassInput/add") return (addRes'', addView') miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType) User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid - let lrwView' = [whamlet|$newline never - #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} # - ^{fvInput lrwView} - |] + let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType - let lrwView' = [whamlet| - $newline never - #{csrf} - - #{lEmail} - # -
-
-
- _{MsgEmailInvitationWarning} - # - ^{fvInput lrwView} - |] + let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") return (lrwRes,lrwView') miDelete :: ListLength -- ^ Current shape @@ -675,6 +661,17 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True + miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition + miAddEmpty _ _ _ = Set.empty + + miLayout :: ListLength + -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state + -> Map ListPosition Widget -- ^ Cell widgets + -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons + -> Map (Natural, ListPosition) Widget -- ^ Addition widgets + -> Widget + miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") + lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput @@ -863,7 +860,7 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) -data CourseUserAction = CourseUserDeregister +data CourseUserAction = CourseUserSendMail | CourseUserDeregister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe CourseUserAction @@ -970,6 +967,9 @@ postCUsersR tid ssh csh = do table <- makeCourseUserTable cid colChoices psValidator return (ent, numParticipants, table) formResult participantRes $ \case + (CourseUserSendMail, selectedUsers) -> do + cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] + redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (CourseUserDeregister,selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ CourseParticipantCourse ==. cid @@ -1083,6 +1083,53 @@ getCNotesR = error "CNotesR: Not implemented" postCNotesR = error "CNotesR: Not implemented" +getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCCommR = postCCommR +postCCommR tid ssh csh = do + jSender <- requireAuthId + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + + commR CommunicationRoute + { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR + , crJobs = \Communication{..} -> do + let jSubject = cSubject + jMailContent = cBody + jCourse = cid + allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients + jMailObjectUUID <- liftIO getRandom + jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case + Left email -> return . Address Nothing $ CI.original email + Right rid -> userAddress <$> getJust rid + forM_ allRecipients $ \jRecipientEmail -> + yield JobSendCourseCommunication{..} + , crRecipients = Map.fromList + [ ( RGCourseParticipants + , E.from $ \(user `E.InnerJoin` participant) -> do + E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + return user + ) + , ( RGCourseLecturers + , E.from $ \(user `E.InnerJoin` lecturer) -> do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + return user + ) + , ( RGCourseCorrectors + , E.from $ \user -> do + E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return user + ) + ] + , crRecipientAuth = Just $ \uid -> do + cID <- encrypt uid + evalAccessDB (CourseR tid ssh csh $ CUserR cID) False + } + + data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ButtonLecInvite diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index d29b7f214..f79d36b92 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -25,7 +25,7 @@ data HelpForm = HelpForm helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm helpForm mr mReferer mUid = HelpForm <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) + <*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid) <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing <*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing) where @@ -53,8 +53,8 @@ postHelpR = do now <- liftIO getCurrentTime hfReferer' <- traverse toTextUrl hfReferer queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpSubject = hfSubject + { jHelpSender = hfUserId + , jSubject = hfSubject , jHelpRequest = hfRequest , jRequestTime = now , jReferer = hfReferer' diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c80ab32c0..8228136d4 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -217,7 +217,7 @@ postMessageListR = do , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing)) ] - (actionRes, action) <- multiAction actions (Just SMActivate) + (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs new file mode 100644 index 000000000..fa63708df --- /dev/null +++ b/src/Handler/Utils/Communication.hs @@ -0,0 +1,188 @@ +module Handler.Utils.Communication + ( RecipientGroup(..) + , CommunicationRoute(..) + , Communication(..) + , commR + -- * Re-Exports + , Job(..) + ) where + +import Import +import Handler.Utils +import Handler.Utils.Form.MassInput +import Utils.Lens + +import Jobs.Queue +import Control.Monad.Trans.Reader (mapReaderT) + +import qualified Database.Esqueleto as E +import qualified Data.CaseInsensitive as CI +import Data.Map ((!), (!?)) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.Aeson.TH +import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..)) + +import Data.List (nub) + + +data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe RecipientGroup +instance Finite RecipientGroup +nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''RecipientGroup id + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''RecipientGroup + + +data RecipientCategory + = RecipientGroup RecipientGroup + | RecipientCustom + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveFinite ''RecipientCategory +finiteEnum ''RecipientCategory + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , unwrapUnaryRecords = True + , sumEncoding = UntaggedValue + } ''RecipientCategory + +instance ToJSONKey RecipientCategory where + toJSONKey = toJSONKeyText toPathPiece +instance FromJSONKey RecipientCategory where + fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece + +instance PathPiece RecipientCategory where + toPathPiece RecipientCustom = "custom" + toPathPiece (RecipientGroup g) = toPathPiece g + + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX RecipientCategory where + renderMessage foundation ls = \case + RecipientCustom -> renderMessage' MsgRecipientCustom + RecipientGroup g -> renderMessage' g + where + renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text + renderMessage' = renderMessage foundation ls + + +data CommunicationRoute = CommunicationRoute + { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) + , crRecipientAuth :: Maybe (UserId -> DB AuthResult) + , crJobs :: Communication -> Source (YesodDB UniWorX) Job + , crHeading :: SomeMessage UniWorX + , crUltDest :: SomeRoute UniWorX + } + +data Communication = Communication + { cRecipients :: Set (Either UserEmail UserId) + , cSubject :: Maybe Text + , cBody :: Html + } + + +commR :: CommunicationRoute -> Handler Html +commR CommunicationRoute{..} = do + cUser <- maybeAuth + + MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute + + (suggestedRecipients, chosenRecipients) <- runDB $ do + suggested <- for crRecipients $ \user -> E.select user + + let + decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) + decrypt' cID = do + uid <- decrypt cID + whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) + getEntity uid + + chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient + + return (suggested, chosen') + + let + lookupUser :: UserId -> User + lookupUser lId + = entityVal . unsafeHead . filter ((== lId) . entityKey) $ (concat $ Map.elems suggestedRecipients) ++ chosenRecipients + + let chosenRecipients' = Map.fromList $ + [ ( (EnumPosition $ RecipientGroup g, pos) + , (Right recp, recp `elem` map entityKey chosenRecipients) + ) + | (g, recps) <- Map.toList suggestedRecipients + , (pos, recp) <- zip [0..] $ map entityKey recps + ] ++ + [ ( (EnumPosition RecipientCustom, pos) + , (Right recp, True) + ) + | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients) + ] + activeCategories = map RecipientGroup (Map.keys suggestedRecipients) `snoc` RecipientCustom + + let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') + where + miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do + (addRes, addView) <- mpreq multiEmailField (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing + let + addRes' = addRes <&> \(nub . map CI.mk -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) (map Left nEmails) + return (addRes', $(widgetFile "widgets/communication/recipientAdd")) + miAdd _ _ _ _ = Nothing + miCell _ (Left (CI.original -> email)) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False + miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0) + miAddEmpty _ _ _ = Set.empty + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength + -> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool) + -> Map (EnumPosition RecipientCategory, ListPosition) Widget + -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX) + -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget + -> Widget + miLayout liveliness state cellWdgts _delButtons addWdgts = do + checkedIdentBase <- newIdent + let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || fromMaybe True (fmap snd $ chosenRecipients' !? k))) False state) $ Map.keysSet state + checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c + categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness + $(widgetFile "widgets/communication/recipientLayout") + miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition)) + -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos + miDelete _ _ = mzero + postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) + postProcess = Set.fromList . map fst . filter snd . Map.elems + + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication + <$> recipientAForm + <*> aopt textField (fslI MsgCommSubject) Nothing + <*> areq htmlField (fslI MsgCommBody) Nothing + formResult commRes $ \comm -> do + runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs + addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm + redirect crUltDest + + + let formWdgt = wrapForm commWdgt def + { formMethod = POST + , formAction = SomeRoute <$> mbCurrentRoute + , formEncoding = commEncoding + } + siteLayoutMsg crHeading $ do + setTitleI crHeading + formWdgt diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 932044f62..c37007add 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -10,7 +10,7 @@ import Handler.Utils.Form.Types import Handler.Utils.DateTime -import Import hiding (cons) +import Import import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -377,7 +377,7 @@ nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'") sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading -sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template) +sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template) where selOptions = Map.fromList [ ( Points', Points <$> maxPointsReq ) @@ -395,7 +395,7 @@ sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> tem sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType -sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template) +sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template) where selOptions = Map.fromList [ ( Normal', Normal <$> gradingReq ) @@ -414,8 +414,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa NotGraded -> NotGraded' sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup -sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do - let +sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template) + where selOptions = Map.fromList [ ( Arbitrary', Arbitrary <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) @@ -423,25 +423,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do , ( RegisteredGroups', pure RegisteredGroups ) , ( NoGroups', pure NoGroups ) ] - (res, selView) <- multiAction selOptions (classify' <$> template) - - fvId <- maybe newIdent return fsId - MsgRenderer mr <- getMsgRenderer - - return (res, - [ FieldView - { fvLabel = toHtml $ mr fsLabel - , fvTooltip = toHtml . mr <$> fsTooltip - , fvId - , fvInput = selView - , fvErrors = case res of - FormFailure [e] -> Just $ toHtml e - _ -> Nothing - , fvRequired = True - } - ]) - - where classify' :: SheetGroup -> SheetGroup' classify' = \case Arbitrary _ -> Arbitrary' @@ -621,48 +602,41 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs -multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) +multiAction :: forall action a. + ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action ) => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX -> Maybe action - -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) -multiAction acts defAction = do + -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) +multiAction acts fs@FieldSettings{..} defAction csrf = do mr <- getMessageRender + let options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece - (actionRes, actionView) <- mreq (selectField $ return options) "" defAction + (actionRes, actionView) <- mreq (selectField $ return options) fs defAction results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts - let mToWidget (_, []) = return Nothing - mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty - widgets <- mapM mToWidget results - let actionWidgets = Map.foldrWithKey accWidget [] widgets - accWidget _act Nothing = id - accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action") - actionResults = Map.map fst results - return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect")) + + let actionResults = view _1 <$> results + actionViews = Map.foldrWithKey accViews [] results + + accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] + accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd + + return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => FieldSettings UniWorX - -> Map action (AForm (HandlerT UniWorX IO) a) - -> Maybe action - -> AForm (HandlerT UniWorX IO) a -multiActionA FieldSettings{..} acts defAction = formToAForm $ do - (res, selView) <- multiAction acts defAction + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> AForm Handler a +multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty - fvId <- maybe newIdent return fsId - MsgRenderer mr <- getMsgRenderer - - return (res, - [ FieldView - { fvLabel = toHtml $ mr fsLabel - , fvTooltip = toHtml . mr <$> fsTooltip - , fvId - , fvInput = selView - , fvErrors = case res of - FormFailure [e] -> Just $ toHtml e - _ -> Nothing - , fvRequired = True - } - ]) +multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, Widget)) +multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () formResultModal res finalDest handler = maybeT_ $ do diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index d1c403ec7..142f0ef2a 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,19 +1,24 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Handler.Utils.Form.MassInput ( MassInput(..) + , defaultMiLayout , massInput + , module Handler.Utils.Form.MassInput.Liveliness + , massInputA , massInputList - , BoxDimension(..) - , IsBoxCoord(..), boxDimension - , Liveliness(..) , ListLength(..), ListPosition(..), miDeleteList + , EnumLiveliness(..), EnumPosition(..) + , MapLiveliness(..) ) where import Import import Utils.Form import Utils.Lens import Handler.Utils.Form (secretJsonField) +import Handler.Utils.Form.MassInput.Liveliness +import Handler.Utils.Form.MassInput.TH import Data.Aeson @@ -24,35 +29,15 @@ import Text.Blaze (Markup) import qualified Data.Text as Text import qualified Data.Set as Set +import qualified Data.IntSet as IntSet +import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Foldable as Fold -import Data.List (genericLength, genericIndex, iterate) -import Control.Monad.Trans.Maybe import Control.Monad.Reader.Class (MonadReader(local)) -data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n) - -class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where - boxDimensions :: [BoxDimension x] - boxOrigin :: x - -boxDimension :: IsBoxCoord x => Natural -> BoxDimension x -boxDimension n - | n < genericLength dims = genericIndex dims n - | otherwise = error "boxDimension: insufficient dimensions" - where - dims = boxDimensions - --- zeroDimension :: IsBoxCoord x => Natural -> x -> x --- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim - -class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where - type BoxCoord a :: * - liveCoords :: Prism' (Set (BoxCoord a)) a - liveCoord :: BoxCoord a -> Prism' Bool a - liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC)) +$(mapM tupleBoxCoord [2..4]) newtype ListLength = ListLength { unListLength :: Natural } @@ -70,13 +55,13 @@ instance BoundedJoinSemiLattice ListLength where bottom = 0 newtype ListPosition = ListPosition { unListPosition :: Natural } - deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey) + deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey) deriving (Eq, Ord, Generic, Typeable, Read, Show) makeWrapped ''ListPosition instance IsBoxCoord ListPosition where - boxDimensions = [BoxDimension id] + boxDimensions = [BoxDimension _Wrapped] boxOrigin = 0 instance Liveliness ListLength where @@ -94,7 +79,66 @@ instance Liveliness ListLength where = Nothing where max' = Set.lookupMax ns - liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0))) + liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0))) + + +newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet } + deriving (Eq, Ord, Generic, Typeable, Read, Show) + +makeWrapped ''EnumLiveliness + +instance JoinSemiLattice (EnumLiveliness enum) where + (EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b +instance MeetSemiLattice (EnumLiveliness enum) where + (EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b +instance Lattice (EnumLiveliness enum) +instance BoundedJoinSemiLattice (EnumLiveliness enum) where + bottom = EnumLiveliness IntSet.empty +instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where + top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound] +instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum) + + +newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum } + deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey) + deriving (Eq, Ord, Generic, Typeable, Read, Show) + +makeWrapped ''EnumPosition + +instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where + boxDimensions = [BoxDimension _Wrapped] + boxOrigin = minBound + +instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where + type BoxCoord (EnumLiveliness enum) = EnumPosition enum + liveCoords = iso fromSet toSet + where + toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness + fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList + + +newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 } + deriving (Generic, Typeable) + +makeWrapped ''MapLiveliness + +deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2) +deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2) +deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2) +deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2) + +instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where + type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2) + liveCoords = prism' + (Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness) + (\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks) + miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition) @@ -205,7 +249,17 @@ data MassInput handler liveliness cellData cellResult = MassInput -> Natural -> liveliness -> Bool -- ^ Decide whether an addition-operation should be permitted + , miAddEmpty :: BoxCoord liveliness + -> Natural + -> liveliness + -> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment` + , miLayout :: liveliness + -> Map (BoxCoord liveliness) (cellData, FormResult cellResult) + -> Map (BoxCoord liveliness) Widget -- Cell Widgets + -> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons + -> Map (Natural, BoxCoord liveliness) Widget -- Addition forms + -> Widget } massInput :: forall handler cellData cellResult liveliness. @@ -221,12 +275,12 @@ massInput :: forall handler cellData cellResult liveliness. -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX)) massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let initialShape = fmap fst <$> initialResult - + miName <- maybe newFormIdent return fsName fvId <- maybe newIdent return fsId miAction <- traverse toTextUrl $ miButtonAction fvId let addFormAction = maybe id (addAttr "formaction") miAction - + let shapeName :: MassInputFieldName (BoxCoord liveliness) shapeName = MassInputShape{..} @@ -243,10 +297,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget)) - addForm = addForm' boxOrigin . zip [0..] + addForm = addForm' boxOrigin [] . zip [0..] where - addForm' _ [] = return Map.empty - addForm' miCoord ((dimIx, _) : remDims) = do + addForm' _ _ [] = return Map.empty + addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do let nudgeAddWidgetName :: Text -> Text nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..} (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing @@ -262,9 +316,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do case remDims of [] -> return dimRes' ((_, BoxDimension dim) : _) -> do - let - miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord - dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords + let miCoords + = Set.union (miAddEmpty miCoord dimIx sentLiveliness) + . Set.map (\c -> miCoord & dim .~ (c ^. dim)) + . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ]) + $ review liveCoords sentLiveliness + dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords return $ dimRes' `Map.union` fold dimRess addResults <- addForm boxDimensions @@ -303,8 +360,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults shape <- if - | Just s <- addShape -> return s - | Just s <- delShape -> return s + | Just s <- addShape -> return s + | Just s <- delShape -> return s | otherwise -> return sentShape' liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness @@ -342,25 +399,16 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do guard $ not shapeChanged for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult - let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget - miWidget' _ [] = mempty - miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) = - let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord - cells - | [] <- remDims = do - coord <- coords - Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults - let deleteButton = snd <$> Map.lookup coord delResults - return (coord, $(widgetFile "widgets/massinput/cell")) - | otherwise = - [ (coord, miWidget' coord remDims) | coord <- coords ] - addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults - in $(widgetFile "widgets/massinput/row") - - miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions + let miWidget + = miLayout + liveliness + (fmap (view _1 &&& view (_2 . _1)) cellResults) + (fmap (view $ _2 . _2) cellResults) + (fmap (view _2) delResults) + (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults) MsgRenderer mr <- getMsgRenderer - + let fvLabel = toHtml $ mr fsLabel fvTooltip = toHtml . mr <$> fsTooltip @@ -368,6 +416,32 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do fvErrors = Nothing in return (result, FieldView{..}) +defaultMiLayout :: forall liveliness cellData cellResult. + Liveliness liveliness + => liveliness + -> Map (BoxCoord liveliness) (cellData, FormResult cellResult) + -> Map (BoxCoord liveliness) Widget + -> Map (BoxCoord liveliness) (FieldView UniWorX) + -> Map (Natural, BoxCoord liveliness) Widget + -> Widget +-- | Generic `miLayout` using recursively nested lists +defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions + where + miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget + miWidget' _ _ [] = mempty + miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) = + let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness + cells + | [] <- remDims = do + coord <- coords + Just cellWdgt <- return $ Map.lookup coord cellResults + let deleteButton = Map.lookup coord delResults + return (coord, $(widgetFile "widgets/massinput/cell")) + | otherwise = + [ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ] + addWidget = Map.lookup (dimIx, miCoord) addResults + in $(widgetFile "widgets/massinput/row") + -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints massInputList :: forall handler cellResult. @@ -388,8 +462,25 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes , miDelete = miDeleteList , miAllowAdd = \_ _ _ -> True + , miAddEmpty = \_ _ _ -> Set.empty , miButtonAction + , miLayout = \lLength _ cellWdgts delButtons addWdgts + -> $(widgetFile "widgets/massinput/list/layout") } miSettings miRequired (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult) + +massInputA :: forall handler cellData cellResult liveliness. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , ToJSON cellData, FromJSON cellData + , Liveliness liveliness + , MonadLogger handler + ) + => MassInput handler liveliness cellData cellResult + -> FieldSettings UniWorX + -> Bool -- ^ Required? + -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult)) + -> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult)) +massInputA mi fs fvRequired initialResult = formToAForm $ + over _2 pure <$> massInput mi fs fvRequired initialResult mempty diff --git a/src/Handler/Utils/Form/MassInput/Liveliness.hs b/src/Handler/Utils/Form/MassInput/Liveliness.hs new file mode 100644 index 000000000..9891350d8 --- /dev/null +++ b/src/Handler/Utils/Form/MassInput/Liveliness.hs @@ -0,0 +1,45 @@ +module Handler.Utils.Form.MassInput.Liveliness + ( BoxDimension(..) + , IsBoxCoord(..) + , boxDimension + , Liveliness(..) + ) where + +import ClassyPrelude + +import Web.PathPieces (PathPiece) +import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +import Numeric.Natural + +import Utils.Lens + +import Algebra.Lattice + +import qualified Data.Set as Set +import Data.List (genericLength, genericIndex) + + +data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n) + +class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where + boxDimensions :: [BoxDimension x] + boxOrigin :: x + +boxDimension :: IsBoxCoord x => Natural -> BoxDimension x +boxDimension n + | n < genericLength dims = genericIndex dims n + | otherwise = error "boxDimension: insufficient dimensions" + where + dims = boxDimensions + +-- zeroDimension :: IsBoxCoord x => Natural -> x -> x +-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim + +class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where + type BoxCoord a :: * + liveCoords :: Prism' (Set (BoxCoord a)) a + liveCoord :: BoxCoord a -> Prism' Bool a + liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC)) + + diff --git a/src/Handler/Utils/Form/MassInput/TH.hs b/src/Handler/Utils/Form/MassInput/TH.hs new file mode 100644 index 000000000..b495a244b --- /dev/null +++ b/src/Handler/Utils/Form/MassInput/TH.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Handler.Utils.Form.MassInput.TH + ( tupleBoxCoord + ) where + +import Prelude +import Handler.Utils.Form.MassInput.Liveliness + +import Language.Haskell.TH + +import Control.Lens + +import Data.List ((!!)) + + +tupleBoxCoord :: Int -> DecQ +tupleBoxCoord tupleDim = do + cs <- sequence . replicate tupleDim $ newName "c" + + let tupleType = foldl appT (tupleT tupleDim) $ map varT cs + tCxt = cxt $ concat + [ [ [t|IsBoxCoord $(varT c)|] | c <- cs ] + ] + fieldLenses = + [ [e|_1|] + , [e|_2|] + , [e|_3|] + , [e|_4|] + ] + + instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType) + [ funD 'boxDimensions + [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) [] + ] + , funD 'boxOrigin + [ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) [] + ] + ] diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 5c35dd4aa..211923159 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -1,12 +1,13 @@ module Handler.Utils.Mail ( addRecipientsDB + , userAddress , userMailT , addFileDB ) where import Import -import Utils.Lens hiding (snoc) +import Utils.Lens import qualified Data.CaseInsensitive as CI @@ -31,22 +32,22 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectS let addr = Address (Just userDisplayName) $ CI.original userEmail _mailTo %= flip snoc addr +userAddress :: User -> Address +userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail + userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadBaseControl IO m , MonadLogger m ) => UserId -> MailT m a -> m a userMailT uid mAct = do - User - { userEmail - , userDisplayName - , userMailLanguages + user@User + { userMailLanguages , userDateTimeFormat , userDateFormat , userTimeFormat } <- liftHandlerT . runDB $ getJust uid let - addr = Address (Just userDisplayName) $ CI.original userEmail ctx = MailContext { mcLanguages = userMailLanguages , mcDateTimeFormat = \case @@ -55,7 +56,7 @@ userMailT uid mAct = do SelFormatTime -> userTimeFormat } mailT ctx $ do - _mailTo .= pure addr + _mailTo .= pure (userAddress user) mAct addFileDB :: ( MonadMail m @@ -69,4 +70,4 @@ addFileDB fId = do _partEncoding .= Base64 _partFilename .= Just fileName _partContent .= LBS.fromStrict fileContent - setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId + setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index fc4e88574..2e980312f 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -18,8 +18,6 @@ import Import import Text.PrettyPrint.Leijen.Text hiding ((<$>)) -import Control.Monad.Trans.Maybe - import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text.Encoding.Error (UnicodeException(..)) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9b7114837..51de48a1e 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -36,6 +36,7 @@ import Text.Lucius as Import import Text.Shakespeare.Text as Import hiding (text, stext) import Data.Universe as Import +import Data.Universe.TH as Import import Data.Pool as Import (Pool) import Network.HaskellNet.SMTP as Import (SMTPConnection) @@ -54,6 +55,7 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) import Data.Monoid as Import (Last(..), First(..)) import Data.Monoid.Instances as Import () +import Data.Set.Instances as Import () import Data.HashMap.Strict.Instances as Import () import Data.HashSet.Instances as Import () import Data.Vector.Instances as Import () @@ -80,7 +82,9 @@ import Numeric.Natural.Instances as Import () import System.Random as Import (Random) import Control.Monad.Random.Class as Import (MonadRandom(..)) +import Text.Blaze.Instances as Import () import Jose.Jwt.Instances as Import () +import Web.PathPieces.Instances as Import () import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs.hs b/src/Jobs.hs index 9b06c3a1c..615c48755 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -59,6 +59,7 @@ import Jobs.Handler.QueueNotification import Jobs.Handler.HelpRequest import Jobs.Handler.SetLogSettings import Jobs.Handler.DistributeCorrections +import Jobs.Handler.SendCourseCommunication import Jobs.Handler.LecturerInvitation diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index aaa46bef2..68d3a2d1e 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -23,13 +23,13 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do supportAddress <- view _appMailSupport userInfo <- bitraverse return (runDB . getEntity) jSender - let userAddress = either + let senderAddress = either id (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) userInfo mailT def $ do _mailTo .= [supportAddress] - whenIsJust userAddress (_mailFrom .=) + whenIsJust senderAddress (_mailFrom .=) replaceMailHeader "Auto-Submitted" $ Just "no" setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject setDate jRequestTime diff --git a/src/Jobs/Handler/LecturerInvitation.hs b/src/Jobs/Handler/LecturerInvitation.hs index 098ccbb61..8faeabba2 100644 --- a/src/Jobs/Handler/LecturerInvitation.hs +++ b/src/Jobs/Handler/LecturerInvitation.hs @@ -12,8 +12,6 @@ import qualified Data.CaseInsensitive as CI import Utils.Lens -import Control.Monad.Trans.Maybe - dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler () dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs new file mode 100644 index 000000000..734612c43 --- /dev/null +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -0,0 +1,37 @@ +module Jobs.Handler.SendCourseCommunication + ( dispatchJobSendCourseCommunication + ) where + +import Import + +import Utils.Lens +import Handler.Utils + +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + + +dispatchJobSendCourseCommunication :: Either UserEmail UserId + -> Set Address + -> CourseId + -> UserId + -> UUID + -> Maybe Text + -> Html + -> Handler () +dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do + (sender, Course{..}) <- runDB $ (,) + <$> getJust jSender + <*> getJust jCourse + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + void $ setMailObjectUUID jMailObjectUUID + _mailFrom .= userAddress sender + if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients + | jRecipientEmail == Right jSender + -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses) + | otherwise + -> addMailHeader "Cc" "Undisclosed Recipients:;" + addMailHeader "Auto-Submitted" "no" + setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject + void $ addPart jMailContent diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index a9d701ec4..b91a51d1d 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -2,7 +2,7 @@ module Jobs.Queue ( writeJobCtl, writeJobCtlBlock , queueJob, queueJob' , YesodJobDB - , runDBJobs, queueDBJob + , runDBJobs, queueDBJob, sinkDBJobs , module Jobs.Types ) where @@ -21,6 +21,8 @@ import qualified Data.HashMap.Strict as HashMap import Control.Monad.Random (evalRand, mkStdGen, uniform) +import qualified Data.Conduit.List as C + data JobQueueException = JobQueuePoolEmpty deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) @@ -29,6 +31,10 @@ instance Exception JobQueueException writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () +-- | Pass an instruction to the `Job`-Workers +-- +-- Instructions are assigned deterministically and pseudo-randomly to one specific worker. +-- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others writeJobCtl cmd = do tid <- liftIO myThreadId wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO @@ -39,6 +45,7 @@ writeJobCtl cmd = do liftIO . atomically $ writeTMChan chan cmd writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () +-- | Pass an instruction to the `Job`-Workers and block until it was acted upon writeJobCtlBlock cmd = do getResVar <- asks jobConfirm resVar <- liftIO . atomically $ do @@ -67,19 +74,30 @@ queueJobUnsafe job = do -- return jId queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId +-- ^ Queue a job for later execution +-- +-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`) queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m () --- ^ `queueJob` followed by `JobCtlPerform` +-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform +-- | Slightly modified Version of `YesodDB` for `runDBJobs` type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO)) -queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) () +queueDBJob :: Job -> YesodJobDB UniWorX () +-- | Queue a job as part of a database transaction and execute it after the transaction succeeds queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton -runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) - => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +sinkDBJobs :: Sink Job (YesodJobDB UniWorX) () +-- | Queue many jobs as part of a database transaction and execute them after the transaction passes +sinkDBJobs = C.mapM_ queueDBJob + +runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a +-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction +-- +-- Jobs get immediately executed if the transaction succeeds runDBJobs act = do (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act forM_ jIds $ writeJobCtl . JobCtlPerform diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 42ce48824..47df31a88 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -15,14 +15,22 @@ import Data.List.NonEmpty (NonEmpty) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } | JobQueueNotification { jNotification :: Notification } - | JobHelpRequest { jSender :: Either (Maybe Address) UserId + | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId , jRequestTime :: UTCTime - , jHelpSubject :: Maybe Text + , jSubject :: Maybe Text , jHelpRequest :: Text , jReferer :: Maybe Text } | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } | JobDistributeCorrections { jSheet :: SheetId } + | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCourse :: CourseId + , jSender :: UserId + , jMailObjectUUID :: UUID + , jSubject :: Maybe Text + , jMailContent :: Html + } | JobLecturerInvitation { jInviter :: UserId , jLecturerInvitation :: LecturerInvitation } @@ -40,15 +48,15 @@ instance Hashable Job instance Hashable Notification deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "job" "data" } ''Job deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "notification" "data" } ''Notification diff --git a/src/Mail.hs b/src/Mail.hs index 283de2deb..82bac2273 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -7,7 +7,9 @@ module Mail module Network.Mail.Mime -- * MailT , MailT, defMailT - , MailSmtpData(..), MailContext(..), MailLanguages(..) + , MailSmtpData(..) + , _MailSmtpDataSet + , MailContext(..), MailLanguages(..) , MonadMail(..) , getMailMessageRender, getMailMsgRenderer -- * YesodMail @@ -24,7 +26,8 @@ module Mail , MailObjectId , replaceMailHeader, addMailHeader, removeMailHeader , replaceMailHeaderI, addMailHeaderI - , setSubjectI, setMailObjectId, setMailObjectId' + , setSubjectI + , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom , setDate, setDateCurrent , setMailSmtpData , _addressName, _addressEmail @@ -61,18 +64,19 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LTB import qualified Data.ByteString.Lazy as LBS -import Utils (MsgRendererS(..)) +import Utils (MsgRendererS(..), MonadSecretBox(..)) import Utils.Lens.TH import Control.Lens hiding (from) +import Control.Lens.Extras (is) import Text.Blaze.Renderer.Utf8 import Data.UUID (UUID) import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID import Data.UUID.Cryptographic.ImplicitNamespace import Data.Binary (Binary) +import qualified Data.Binary as Binary import GHC.TypeLits (KnownSymbol) @@ -105,6 +109,12 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen) +import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..)) +import qualified Data.ByteArray as ByteArray (convert) +import Crypto.MAC.HMAC (hmac, HMAC) +import Crypto.Hash.Algorithms (SHAKE128) + makeLenses_ ''Address makeLenses_ ''Mail @@ -133,6 +143,13 @@ instance Monoid (MailSmtpData) where mempty = memptydefault mappend = mappenddefault +_MailSmtpDataSet :: Getter MailSmtpData Bool +_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id + [ is (_Wrapped . _Nothing) smtpEnvelopeFrom + , Set.null smtpRecipients + ] + + newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] } deriving (Eq, Ord, Show, Read, Generic, Typeable) deriving newtype (FromJSON, ToJSON, IsList) @@ -426,20 +443,33 @@ setMailObjectUUID uuid = do replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">" return objectId -setMailObjectId :: ( MonadHeader m - , YesodMail (HandlerSite m) - ) => m MailObjectId -setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom +setMailObjectIdRandom :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => m MailObjectId +setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom -setMailObjectId' :: ( MonadHeader m - , YesodMail (HandlerSite m) - , MonadCrypto m - , HasCryptoUUID plain m - , MonadCryptoKey m ~ CryptoIDKey - , KnownSymbol (CryptoIDNamespace UUID plain) - , Binary plain - ) => plain -> m MailObjectId -setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid +setMailObjectIdCrypto :: ( MonadHeader m + , YesodMail (HandlerSite m) + , MonadCrypto m + , HasCryptoUUID plain m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol (CryptoIDNamespace UUID plain) + , Binary plain + ) => plain -> m MailObjectId +setMailObjectIdCrypto oid = setMailObjectUUID . ciphertext =<< encrypt oid + +setMailObjectIdPseudorandom :: ( MonadHeader m + , YesodMail (HandlerSite m) + , Binary obj + , MonadSecretBox m + ) => obj -> m MailObjectId +-- | Designed to leak no information about the `secretBoxKey` or the given object +setMailObjectIdPseudorandom obj = do + sbKey <- secretBoxKey + let + seed :: HMAC (SHAKE128 64) + seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj + setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString) setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () diff --git a/src/Text/Blaze/Instances.hs b/src/Text/Blaze/Instances.hs new file mode 100644 index 000000000..346b17c60 --- /dev/null +++ b/src/Text/Blaze/Instances.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Blaze.Instances + ( + ) where + +import ClassyPrelude +import Text.Blaze +import qualified Text.Blaze.Renderer.Text as Text + +import Text.Read (Read(..)) + +import Data.Hashable (Hashable(..)) +import Data.Aeson (ToJSON(..), FromJSON(..)) +import qualified Data.Aeson as Aeson + + +instance Eq Markup where + (==) = (==) `on` Text.renderMarkup + +instance Ord Markup where + compare = comparing Text.renderMarkup + +instance Read Markup where + readPrec = preEscapedLazyText <$> readPrec + +instance Show Markup where + showsPrec prec = showsPrec prec . Text.renderMarkup + +instance Hashable Markup where + hashWithSalt s = hashWithSalt s . Text.renderMarkup + +instance ToJSON Markup where + toJSON = Aeson.String . toStrict . Text.renderMarkup + +instance FromJSON Markup where + parseJSON = Aeson.withText "Html" $ return . preEscapedText diff --git a/src/Utils.hs b/src/Utils.hs index 68906d803..40fa580ee 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -45,7 +45,7 @@ import Control.Lens as Utils (none) import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Except (MonadError(..)) -import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Maybe as Utils (MaybeT(..)) import Control.Monad.Catch hiding (throwM) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 96dec5423..1f207d484 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -189,6 +189,7 @@ data FormIdentifier | FIDcUserNote | FIDAdminDemo | FIDUserDelete + | FIDCommunication deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 05261e95b..f83e91b59 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -2,7 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where import ClassyPrelude.Yesod hiding ((.=)) import Model -import Control.Lens as Utils.Lens hiding ((<.>)) +import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc) import Control.Lens.Extras as Utils.Lens (is) import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_) @@ -94,6 +94,8 @@ makeLenses_ ''StudyTerms makeLenses_ ''StudyTermCandidate +makeLenses_ ''FieldView + makePrisms ''HandlerContents makePrisms ''ErrorResponse diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index bc3735620..57d1a0cff 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -1,10 +1,10 @@ module Utils.Parameters ( GlobalGetParam(..) - , lookupGlobalGetParam, hasGlobalGetParam + , lookupGlobalGetParam, hasGlobalGetParam, lookupGlobalGetParams , lookupGlobalGetParamForm, hasGlobalGetParamForm , globalGetParamField , GlobalPostParam(..) - , lookupGlobalPostParam, hasGlobalPostParam + , lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams , lookupGlobalPostParamForm, hasGlobalPostParamForm , globalPostParamField ) where @@ -20,7 +20,7 @@ import Data.Universe import Control.Monad.Trans.Maybe (MaybeT(..)) -data GlobalGetParam = GetReferer | GetBearer +data GlobalGetParam = GetReferer | GetBearer | GetRecipient deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalGetParam @@ -33,6 +33,9 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) +lookupGlobalGetParams :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m [result] +lookupGlobalGetParams ident = mapMaybe fromPathPiece <$> lookupGetParams (toPathPiece ident) + lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result) lookupGlobalGetParamForm ident = runMaybeT $ do @@ -42,7 +45,7 @@ lookupGlobalGetParamForm ident = runMaybeT $ do hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams -globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a) +globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe a) globalGetParamField ident Field{fieldParse} = runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles @@ -63,7 +66,11 @@ lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPie hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) + +lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result] +lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident) + lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result) lookupGlobalPostParamForm ident = runMaybeT $ do ps <- MaybeT askParams diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 5e0dd8621..7f2e0bd78 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -4,6 +4,7 @@ module Utils.PathPiece , nullaryPathPiece , splitCamel , camelToPathPiece, camelToPathPiece' + , tuplePathPiece ) where import ClassyPrelude.Yesod @@ -17,6 +18,9 @@ import qualified Data.Char as Char import Numeric.Natural +import Data.List (foldl) + + finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of [x] -> Just x @@ -63,3 +67,32 @@ camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dro camelToPathPiece :: Textual t => t -> t camelToPathPiece = camelToPathPiece' 0 + + +tuplePathPiece :: Int -> DecQ +tuplePathPiece tupleDim = do + let + tupleSeparator :: Text + tupleSeparator = "," + + xs <- sequence . replicate tupleDim $ newName "x" :: Q [Name] + xs' <- sequence . replicate tupleDim $ newName "x'" :: Q [Name] + + let tupleType = foldl appT (tupleT tupleDim) $ map varT xs + tCxt = cxt + [ [t|PathPiece $(varT x)|] | x <- xs ] + + t <- newName "t" + + instanceD tCxt [t|PathPiece $(tupleType)|] + [ funD 'toPathPiece + [ clause [tupP $ map varP xs] (normalB [e|Text.intercalate 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)|] + , [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ] + , pure $ noBindS [e|return $(tupE $ map varE xs')|] + ]) [] + ] + ] diff --git a/src/Web/PathPieces/Instances.hs b/src/Web/PathPieces/Instances.hs new file mode 100644 index 000000000..a47711a8e --- /dev/null +++ b/src/Web/PathPieces/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Web.PathPieces.Instances + ( + ) where + +import Prelude + +import Utils.PathPiece + + +$(mapM tuplePathPiece [2..4]) diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index 50b37679b..153cbec8e 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -102,4 +102,4 @@ instance Extend FormResult where duplicated FormMissing = FormMissing duplicated (FormFailure errs) = FormFailure errs - +deriving instance Eq a => Eq (FormResult a) diff --git a/static/css/utils/form.scss b/static/css/utils/form.scss index b1d6b22c3..6612beeb1 100644 --- a/static/css/utils/form.scss +++ b/static/css/utils/form.scss @@ -1,16 +1,13 @@ fieldset { border: 0; - margin: 20px 0 30px; + margin: 0; + padding: 0; legend { display: none; } } -.form-group__input > fieldset { - margin-bottom: 0; -} - @media (min-width: 769px) { .form-group__input { grid-column: 2; diff --git a/static/js/utils/form.js b/static/js/utils/form.js index cb7cdd9f9..b2a449e2a 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -124,8 +124,10 @@ * Selector for the input that this fieldset watches for changes * data-conditional-value: string * The value the conditional input needs to be set to for this fieldset to be shown + * Can be omitted if conditionalInput is a checkbox * * Example usage: + * ## example with text input * *
...
*
...
@@ -135,16 +137,25 @@ *