106 lines
4.5 KiB
Haskell
106 lines
4.5 KiB
Haskell
module Handler.Utils.Communication where
|
|
|
|
import Import
|
|
import Handler.Utils.Form
|
|
import Handler.Utils.Form.MassInput
|
|
import Utils.Lens
|
|
|
|
import Jobs.Types
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe RecipientGroup
|
|
instance Finite RecipientGroup
|
|
nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''RecipientGroup id
|
|
|
|
|
|
data RecipientAddOption
|
|
= AddRecipientGroups
|
|
| AddRecipientGroup RecipientGroup
|
|
| AddRecipientCustom
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe RecipientAddOption where
|
|
universe = concat
|
|
[ pure AddRecipientGroups
|
|
, [ AddRecipientGroup g | g <- universe ]
|
|
, pure AddRecipientCustom
|
|
]
|
|
instance Finite RecipientAddOption
|
|
|
|
instance PathPiece RecipientAddOption where
|
|
toPathPiece AddRecipientGroups = "recipient-groups"
|
|
toPathPiece AddRecipientCustom = "recipient-custom"
|
|
toPathPiece (AddRecipientGroup g) = toPathPiece g
|
|
|
|
fromPathPiece = finiteFromPathPiece
|
|
|
|
instance RenderMessage UniWorX RecipientAddOption where
|
|
renderMessage foundation ls = \case
|
|
AddRecipientGroups -> renderMessage' MsgAddRecipientGroups
|
|
AddRecipientCustom -> renderMessage' MsgAddRecipientCustom
|
|
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)))
|
|
, crJob :: Communication -> DB Job
|
|
}
|
|
|
|
-- `Communication` is defined in `Jobs.Types`
|
|
|
|
|
|
commR :: CommunicationRoute -> Handler Html
|
|
commR CommunicationRoute{..} = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
suggestedRecipients' <- runDB $ traverse E.select crRecipients
|
|
suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent
|
|
|
|
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
|
|
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True (Nothing {- TODO -})
|
|
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 ]
|
|
) ("" & addName (nudge . toPathPiece $ AddRecipientGroups)) Nothing
|
|
)
|
|
, do
|
|
(g,recs) <- Map.toList suggestedRecipients
|
|
return ( AddRecipientGroup g
|
|
, Set.unions <$> apreq (multiSelectField . return $ mkOptionList
|
|
[ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
|
|
) ("" & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing
|
|
)
|
|
-- , pure (AddRecipientCustom, _ )
|
|
]
|
|
(addRes, addWdgt) <- multiActionM addOptions ("" & addName (nudge "select")) Nothing csrf
|
|
error "miAdd" :: MForm Handler (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget)
|
|
miCell = error "miCell"
|
|
miDelete :: ListLength -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) -- This type signature is needed, so GHC can infer the type of @MassInput{..}@, above
|
|
miDelete = error "miDelete"
|
|
miAllowAdd = error "miAllowAdd"
|
|
miButtonAction = error "miButtonAction"
|
|
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
|
|
postProcess = Set.fromList . map fst . Map.elems
|
|
|
|
runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication
|
|
<$> recipientAForm
|
|
<*> aopt textField (fslI MsgCommSubject) Nothing
|
|
|
|
error "commR"
|