From 2191272c43135bc87f2217b7300cbd63164335f4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 20 Apr 2019 00:21:30 +0200 Subject: [PATCH] Restructure recipient form --- messages/uniworx/de.msg | 7 +- src/Data/Universe/TH.hs | 69 ++++++++ src/Handler/Course.hs | 6 +- src/Handler/Utils/Communication.hs | 166 +++++++++++------- src/Handler/Utils/Form/MassInput.hs | 58 ++++-- .../Utils/Form/MassInput/Liveliness.hs | 8 +- src/Handler/Utils/Form/MassInput/TH.hs | 39 ++++ src/Handler/Utils/Mail.hs | 2 +- src/Import/NoFoundation.hs | 2 + src/Utils/Lens.hs | 2 +- src/Utils/PathPiece.hs | 33 ++++ src/Web/PathPieces/Instances.hs | 12 ++ src/Yesod/Core/Instances.hs | 2 +- .../widgets/communication/recipientAdd.hamlet | 5 + .../communication/recipientEmail.hamlet | 7 + .../communication/recipientLayout.hamlet | 13 ++ .../communication/recipientName.hamlet | 6 + 17 files changed, 346 insertions(+), 91 deletions(-) create mode 100644 src/Data/Universe/TH.hs create mode 100644 src/Handler/Utils/Form/MassInput/TH.hs create mode 100644 src/Web/PathPieces/Instances.hs create mode 100644 templates/widgets/communication/recipientAdd.hamlet create mode 100644 templates/widgets/communication/recipientEmail.hamlet create mode 100644 templates/widgets/communication/recipientLayout.hamlet create mode 100644 templates/widgets/communication/recipientName.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index fc0aa2c0d..49184101c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -763,16 +763,13 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommBody: Nachricht CommRecipients: Empfänger -CommRecipientsTip: Sie können die Liste von Empfängern beliebig bearbeiten, bevor Sie die Nachricht verschicken. Sie selbst erhalten immer eine Kopie der Nachricht. -CommRecipientsSelectBy: Auswahl nach -CommRecipientsSelectByTip: Mögliche Empfänger sind in verschiedene Gruppen unterteilt; sie können sowohl ganze Empfängergruppen als auch einzelne Mitglieder von Empfängergruppen hinzufügen +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 -AddRecipientGroups: Empfängergruppen -AddRecipientCustom: Weitere Empfänger +RecipientCustom: Weitere Empfänger RGCourseParticipants: Kursteilnehmer RGCourseLecturers: Kursverwalter 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/Handler/Course.hs b/src/Handler/Course.hs index 1a866936e..b02252f36 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -662,11 +662,12 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do miAllowAdd _ _ _ = True 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") + miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] @@ -1120,6 +1121,9 @@ postCCommR tid ssh csh = do return user ) ] + , crRecipientAuth = Just $ \uid -> do + cID <- encrypt uid + evalAccessDB (CourseR tid ssh csh $ CUserR cID) False } diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 6d4527402..47e3eb0e2 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -17,9 +17,15 @@ 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) @@ -29,43 +35,51 @@ instance Finite RecipientGroup nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''RecipientGroup id +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''RecipientGroup -data RecipientAddOption - = AddRecipientGroups - | AddRecipientGroup RecipientGroup - | AddRecipientCustom + +data RecipientCategory + = RecipientGroup RecipientGroup + | RecipientCustom deriving (Eq, Ord, Read, Show, Generic, Typeable) -instance Universe RecipientAddOption where - universe = concat - [ pure AddRecipientGroups - , [ AddRecipientGroup g | g <- universe ] - , pure AddRecipientCustom - ] -instance Finite RecipientAddOption +deriveFinite ''RecipientCategory +finiteEnum ''RecipientCategory -instance PathPiece RecipientAddOption where - toPathPiece AddRecipientGroups = "recipient-groups" - toPathPiece AddRecipientCustom = "recipient-custom" - toPathPiece (AddRecipientGroup g) = toPathPiece g +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 RecipientAddOption where +instance RenderMessage UniWorX RecipientCategory where renderMessage foundation ls = \case - AddRecipientGroups -> renderMessage' MsgAddRecipientGroups - AddRecipientCustom -> renderMessage' MsgAddRecipientCustom - AddRecipientGroup g -> renderMessage' g + 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))) - , crJobs :: Communication -> Source (YesodDB UniWorX) Job - , crHeading :: SomeMessage UniWorX - , crUltDest :: SomeRoute UniWorX + { 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 @@ -77,58 +91,80 @@ data Communication = Communication commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do - uid <- maybeAuthId + cUser <- maybeAuth MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute - suggestedRecipients' <- runDB $ traverse E.select crRecipients - suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent + (suggestedRecipients, chosenRecipients) <- runDB $ do + suggested <- for crRecipients $ \user -> E.select user - chosenRecipients <- fmap (maybe id cons uid) $ mapM (decrypt :: CryptoUUIDUser -> Handler UserId) =<< lookupGlobalGetParams GetRecipient + 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 . Map.fromList . zip [0..] $ map ((, ()) . Right) chosenRecipients) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') where - miAdd _ _ nudge submitView = Just $ \csrf -> do - let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId))) - addOptions = Map.fromList . concat $ - [ pure ( AddRecipientGroups - , Set.unions <$> apreq (multiSelectField . return $ mkOptionList - [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ] - ) (fslI AddRecipientGroups & addName (nudge . toPathPiece $ AddRecipientGroups) & setTooltip MsgMultiSelectFieldTip) Nothing - ) - , do - (g, recs) <- Map.toList suggestedRecipients - guard . not $ null recs - return ( AddRecipientGroup g - , Set.unions <$> apreq (multiSelectField . return $ mkOptionList - [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] - ) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g) & setTooltip MsgMultiSelectFieldTip) Nothing - ) - , pure ( AddRecipientCustom - , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom) & setTooltip MsgMultiEmailFieldTip) Nothing ) - ] - (addRes, addWdgt) <- multiActionM addOptions (fslI MsgCommRecipientsSelectBy & addName (nudge "select") & setTooltip MsgCommRecipientsSelectByTip) Nothing csrf - let addRes' = addRes <&> \newSet oldMap -> - let freshSet = newSet `Set.difference` Set.fromList (Map.elems oldMap) - in FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList freshSet - addWdgt' = mconcat [ toWidget csrf, addWdgt, fvInput submitView ] - return (addRes', addWdgt') - - miCell _ (Left email) _ _nudge csrf - = return (pure (), toWidget csrf <> toWidget (mailtoHtml email)) - miCell _ (Right rid) _ _nudge csrf = do - User{..} <- liftHandlerT . runDB $ getJust rid - return (pure (), toWidget csrf <> nameEmailWidget userEmail userDisplayName userSurname) - miDelete :: ListLength -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) -- This type signature is needed, so GHC can infer the type of @MassInput{..}@, above - miDelete = miDeleteList -- default for lists suffices, since there are no restrictions - miAllowAdd _ _ _ = True + 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 + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) initRes + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute - miLayout = defaultMiLayout - postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) - postProcess = Set.fromList . map fst . Map.elems + 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) 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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index e30c061ee..3b7087e7b 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Handler.Utils.Form.MassInput @@ -9,6 +10,7 @@ module Handler.Utils.Form.MassInput , massInputList , ListLength(..), ListPosition(..), miDeleteList , EnumLiveliness(..), EnumPosition(..) + , MapLiveliness(..) ) where import Import @@ -16,6 +18,7 @@ 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 @@ -30,11 +33,13 @@ import qualified Data.IntSet as IntSet import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Foldable as Fold -import Data.List (iterate) import Control.Monad.Reader.Class (MonadReader(local)) +$(mapM tupleBoxCoord [2..4]) + + newtype ListLength = ListLength { unListLength :: Natural } deriving newtype (Num, Integral, Real, Enum, PathPiece) deriving (Eq, Ord, Generic, Typeable, Read, Show) @@ -50,7 +55,7 @@ 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 @@ -95,16 +100,16 @@ instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum) newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum } - deriving newtype (Enum, Bounded, PathPiece, ToJSONKey, FromJSONKey) + 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, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where +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, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where +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 @@ -112,6 +117,30 @@ instance (Enum enum, Bounded enum, PathPiece enum, ToJSONKey enum, FromJSONKey e 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) miDeleteList l pos -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard` @@ -222,6 +251,7 @@ data MassInput handler liveliness cellData cellResult = MassInput -> Bool -- ^ Decide whether an addition-operation should be permitted , 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 @@ -368,6 +398,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do 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) @@ -381,20 +412,21 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do fvErrors = Nothing in return (result, FieldView{..}) -defaultMiLayout :: forall liveliness. +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 +defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions where - 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 + 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 @@ -402,7 +434,7 @@ defaultMiLayout liveliness cellResults delResults addResults = miWidget' boxOrig let deleteButton = Map.lookup coord delResults return (coord, $(widgetFile "widgets/massinput/cell")) | otherwise = - [ (coord, miWidget' coord remDims) | coord <- coords ] + [ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ] addWidget = Map.lookup (dimIx, miCoord) addResults in $(widgetFile "widgets/massinput/row") @@ -427,7 +459,7 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes , miDelete = miDeleteList , miAllowAdd = \_ _ _ -> True , miButtonAction - , miLayout = \lLength cellWdgts delButtons addWdgts + , miLayout = \lLength _ cellWdgts delButtons addWdgts -> $(widgetFile "widgets/massinput/list/layout") } miSettings diff --git a/src/Handler/Utils/Form/MassInput/Liveliness.hs b/src/Handler/Utils/Form/MassInput/Liveliness.hs index 53c33d236..9891350d8 100644 --- a/src/Handler/Utils/Form/MassInput/Liveliness.hs +++ b/src/Handler/Utils/Form/MassInput/Liveliness.hs @@ -7,8 +7,8 @@ module Handler.Utils.Form.MassInput.Liveliness import ClassyPrelude -import Web.PathPieces(PathPiece) -import Data.Aeson (ToJSONKey, FromJSONKey) +import Web.PathPieces (PathPiece) +import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey) import Numeric.Natural @@ -20,9 +20,9 @@ import qualified Data.Set as Set import Data.List (genericLength, genericIndex) -data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n) +data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n) -class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where +class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where boxDimensions :: [BoxDimension x] boxOrigin :: x 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 02af114b7..211923159 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -7,7 +7,7 @@ module Handler.Utils.Mail import Import -import Utils.Lens hiding (snoc) +import Utils.Lens import qualified Data.CaseInsensitive as CI diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 0a7f4f126..51de48a1e 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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) @@ -83,6 +84,7 @@ 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/Utils/Lens.hs b/src/Utils/Lens.hs index c71790d31..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 ((<.>), universe) +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_) 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/templates/widgets/communication/recipientAdd.hamlet b/templates/widgets/communication/recipientAdd.hamlet new file mode 100644 index 000000000..6f992e6bd --- /dev/null +++ b/templates/widgets/communication/recipientAdd.hamlet @@ -0,0 +1,5 @@ +$newline never +
+ #{csrf} + ^{fvInput addView} + ^{fvInput submitView} diff --git a/templates/widgets/communication/recipientEmail.hamlet b/templates/widgets/communication/recipientEmail.hamlet new file mode 100644 index 000000000..ed3964879 --- /dev/null +++ b/templates/widgets/communication/recipientEmail.hamlet @@ -0,0 +1,7 @@ +$newline never +
+ #{csrf} + ^{fvInput tickView} +