144 lines
7.1 KiB
Haskell
144 lines
7.1 KiB
Haskell
module Handler.Utils.Communication where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Form.MassInput
|
|
import Utils.Lens
|
|
|
|
import Jobs.Queue
|
|
import Control.Monad.Trans.Reader (mapReaderT)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Data.CaseInsensitive as CI
|
|
import 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
|
|
, crHeading :: SomeMessage UniWorX
|
|
, crUltDest :: SomeRoute UniWorX
|
|
}
|
|
-- `Communication` is defined in `Jobs.Types`
|
|
|
|
|
|
commR :: CommunicationRoute -> Handler Html
|
|
commR CommunicationRoute{..} = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
mbCurrentRoute <- getCurrentRoute
|
|
|
|
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 ]
|
|
) (fslI AddRecipientGroups & 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 ]
|
|
) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing
|
|
)
|
|
, pure ( AddRecipientCustom
|
|
, Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing )
|
|
]
|
|
(addRes, addWdgt) <- multiActionM addOptions ("foobar" & addName (nudge "select")) Nothing csrf
|
|
-- lookupUserDisplayName :: UserId -> UserDisplayName
|
|
-- lookupUserDisplayName <- liftHandlerT . runDB $ do
|
|
-- let uids = toListOf (_FormSuccess . folded . _Right) addRes
|
|
-- names <- forM uids getJustEntity
|
|
-- return $ \uid -> case filter ((== uid) . entityKey) names of
|
|
-- [Entity _ User{..}] -> userDisplayName
|
|
-- _other -> error "UserId lookpup failed"
|
|
let addRes' = addRes <&> \newSet oldMap ->
|
|
-- if
|
|
-- | collisions <- newSet `Set.intersection` Set.fromList (Map.elems oldMap)
|
|
-- , not $ Set.null collisions ->
|
|
-- -- FormFailure [ mr . MsgCommDuplicateRecipients . map (either CI.original lookupUserDisplayName) $ Set.toList collisions ]
|
|
-- FormFailure [ mr . MsgCommDuplicateRecipients $ Set.size collisions ]
|
|
-- | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList newSet
|
|
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
|
|
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
|
|
postProcess = Set.fromList . map fst . Map.elems
|
|
|
|
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
|
|
<$> recipientAForm
|
|
<*> aopt textField (fslI MsgCommSubject) Nothing
|
|
formResult commRes $ \comm -> do
|
|
runDBJobs $ queueDBJob =<< mapReaderT lift (crJob comm)
|
|
addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
|
|
redirect crUltDest
|
|
|
|
|
|
let formWdgt = wrapForm commWdgt def
|
|
{ formMethod = POST
|
|
, formAction = SomeRoute <$> mbCurrentRoute
|
|
, formEncoding = commEncoding
|
|
}
|
|
siteLayoutMsg crHeading formWdgt
|