fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Restructure recipient form

Browse Source
This commit is contained in:
Gregor Kleen 2019-04-20 00:21:30 +02:00
parent 11d2cc46a8
commit 2191272c43
17 changed files with 346 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
messages/uniworx/de.msg
View File

@ -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

69
src/Data/Universe/TH.hs Normal file
View File

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

6
src/Handler/Course.hs
View File

@ -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
}

166
src/Handler/Utils/Communication.hs
View File

@ -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

58
src/Handler/Utils/Form/MassInput.hs
View File

@ -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

8
src/Handler/Utils/Form/MassInput/Liveliness.hs
View File

@ -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

39
src/Handler/Utils/Form/MassInput/TH.hs Normal file
View File

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

2
src/Handler/Utils/Mail.hs
View File

@ -7,7 +7,7 @@ module Handler.Utils.Mail
import Import
import Utils.Lens hiding (snoc)
import Utils.Lens
import qualified Data.CaseInsensitive as CI

2
src/Import/NoFoundation.hs
View File

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

2
src/Utils/Lens.hs
View File

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

33
src/Utils/PathPiece.hs
View File

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

12
src/Web/PathPieces/Instances.hs Normal file
View File

@ -0,0 +1,12 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Web.PathPieces.Instances
(
) where
import Prelude
import Utils.PathPiece
$(mapM tuplePathPiece [2..4])

2
src/Yesod/Core/Instances.hs
View File

@ -102,4 +102,4 @@ instance Extend FormResult where
duplicated FormMissing = FormMissing
duplicated (FormFailure errs) = FormFailure errs
deriving instance Eq a => Eq (FormResult a)

5
templates/widgets/communication/recipientAdd.hamlet Normal file
View File

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

7
templates/widgets/communication/recipientEmail.hamlet Normal file
View File

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

13
templates/widgets/communication/recipientLayout.hamlet Normal file
View File

@ -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}

6
templates/widgets/communication/recipientName.hamlet Normal file
View File

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