Restructure recipient form

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.
+CommRecipientsTip: 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
 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
+RecipientCustom: Weitere Empfänger
-AddRecipientCustom: Weitere Empfänger
 
 RGCourseParticipants: Kursteilnehmer
 RGCourseLecturers: Kursverwalter

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) []
+      ]
+    ]

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
     }
 
  

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
+data RecipientCategory
-  | AddRecipientGroup RecipientGroup
+  = RecipientGroup RecipientGroup
-  | AddRecipientCustom
+  | RecipientCustom
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-instance Universe RecipientAddOption where
+deriveFinite ''RecipientCategory
-  universe = concat
+finiteEnum ''RecipientCategory
-    [ pure AddRecipientGroups
-    , [ AddRecipientGroup g | g <- universe ]
-    , pure AddRecipientCustom
-    ]
-instance Finite RecipientAddOption
 
-instance PathPiece RecipientAddOption where
+deriveJSON defaultOptions
-  toPathPiece AddRecipientGroups    = "recipient-groups"
+  { constructorTagModifier = camelToPathPiece' 1
-  toPathPiece AddRecipientCustom    = "recipient-custom"
+  , unwrapUnaryRecords = True
-  toPathPiece (AddRecipientGroup g) = toPathPiece g
+  , 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
+    RecipientCustom  -> renderMessage' MsgRecipientCustom
-    AddRecipientCustom  -> renderMessage' MsgAddRecipientCustom
+    RecipientGroup g -> renderMessage' g
-    AddRecipientGroup 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)))
+  { crRecipients    :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
-  , crJobs       :: Communication -> Source (YesodDB UniWorX) Job
+  , crRecipientAuth :: Maybe (UserId -> DB AuthResult)
-  , crHeading    :: SomeMessage UniWorX
+  , crJobs          :: Communication -> Source (YesodDB UniWorX) Job
-  , crUltDest    :: SomeRoute UniWorX
+  , 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, chosenRecipients) <- runDB $ do
-  suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent
+    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
+          miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
-            let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId)))
+            (addRes, addView) <- mpreq multiEmailField (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
-                addOptions = Map.fromList . concat $
+            let
-                  [ pure ( AddRecipientGroups
+              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)
-                         , Set.unions <$> apreq (multiSelectField . return $ mkOptionList
+            return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
-                                                   [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ]
+          miAdd _ _ _ _ = Nothing
-                                                ) (fslI AddRecipientGroups & addName (nudge . toPathPiece $ AddRecipientGroups) & setTooltip MsgMultiSelectFieldTip) Nothing
+          miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
-                         )
+            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) initRes
-                  , do
+            return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
-                      (g, recs) <- Map.toList suggestedRecipients
+          miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do 
-                      guard . not $ null recs
+            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) initRes
-                      return ( AddRecipientGroup g
+            return (tickRes, $(widgetFile "widgets/communication/recipientName"))
-                             , Set.unions <$> apreq (multiSelectField . return $ mkOptionList
+          miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
-                                                       [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
+          miAllowAdd _ _ _ = False
-                                                    ) (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
           miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
           miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
-          miLayout = defaultMiLayout
+          miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
-          postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
+                   -> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
-          postProcess = Set.fromList . map fst . Map.elems
+                   -> 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

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' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
-    miWidget' _ [] = mempty
+    miWidget' _ _ [] = mempty
-    miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
+    miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
-      let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+      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

src/Handler/Utils/Form/MassInput/Liveliness.hs

@@ -7,8 +7,8 @@ module Handler.Utils.Form.MassInput.Liveliness
 
 import ClassyPrelude
 
-import Web.PathPieces(PathPiece)
+import Web.PathPieces (PathPiece)
-import Data.Aeson (ToJSONKey, FromJSONKey)
+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
 

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|]) []
+      ]
+    ]

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
 

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)

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_)
 

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')|]
+                         ]) []
+      ]
+    ]

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])

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)

templates/widgets/communication/recipientAdd.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<div .category__entry-add>
+  #{csrf}
+  ^{fvInput addView}
+  ^{fvInput submitView}

templates/widgets/communication/recipientEmail.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<div .category__option>
+  #{csrf}
+  ^{fvInput tickView}
+  <label for=#{fvId tickView}>
+    <span style="font-family: monospace">
+      #{email}

templates/widgets/communication/recipientLayout.hamlet

@@ -0,0 +1,13 @@
+$newline never
+$forall category <- activeCategories
+  <div .category>
+    <input type=checkbox id=#{checkedIdent category} :elem category checkedCategories:checked>
+    <label for=#{checkedIdent category}>
+      _{category}
+
+    <fieldset uw-interactive-fieldset data-conditional-input=#{checkedIdent category}>
+      $forall optIx <- categoryIndices category
+        ^{cellWdgts ! optIx}
+
+      $maybe addWdgt <- addWdgts !? (0, (EnumPosition category, 0))
+        ^{addWdgt}

templates/widgets/communication/recipientName.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<div .category__option>
+  #{csrf}
+  ^{fvInput tickView}
+  <label for=#{fvId tickView}>
+    #{nameHtml userDisplayName userSurname}