feat(add-users): connect confirmation form with handler

src/Handler/Course/ParticipantInvite.hs

@@ -13,14 +13,8 @@ import Handler.Utils.Avs
 
 import Jobs.Queue
 
---import qualified Database.Esqueleto.Legacy as E
-
---import qualified Data.Conduit.List as C (sourceList)
---import qualified Data.Conduit.Combinators as C
-
 import qualified Data.Aeson as Aeson
 import qualified Data.CaseInsensitive as CI
---import Data.List (genericLength)
 import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Text as Text
@@ -28,9 +22,6 @@ import qualified Data.Time.Zones as TZ
 import qualified Data.Set as Set
 
 import Control.Monad.Except (MonadError(..))
---import Control.Monad.State (evalStateT)
---import Control.Monad.State.Class (modify)
---import qualified Control.Monad.State as State
 
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
@@ -80,7 +71,7 @@ data CourseRegisterActionData
 -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
 --   { crActUnknownPersonIdent :: Text
 --   }
-   deriving (Eq, Ord, Generic, Typeable)
+   deriving (Eq, Ord, Show, Generic, Typeable)
 
 makeLenses_ ''CourseRegisterActionData
 
@@ -107,74 +98,12 @@ courseRegisterRenderAction = \case
   CourseRegisterActionAddParticipantData{..}    -> [whamlet|^{userWidget (view _2 crActAddParticipantUser)} (#{crActAddParticipantIdent})|]
   CourseRegisterActionAddTutorialMemberData{..} -> [whamlet|^{userWidget (view _2 crActAddTutorialMemberUser)} (#{crActAddTutorialMemberIdent}), _{MsgCourseParticipantsRegisterTutorialField}: #{crActAddTutorialMemberTutorial}|]
 
---data CourseRegisterActionClass
---   = CourseRegisterActionClassNew
---   | CourseRegisterActionClassExisting
---   | CourseRegisterActionClassMissing
---   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
---instance Universe CourseRegisterActionClass
---instance Finite CourseRegisterActionClass
-
---courseRegisterCoarsenActionClass :: CourseRegisterAction -> CourseRegisterActionClass
---courseRegisterCoarsenActionClass = \case
---  CourseRegisterActionAddParticipant    -> CourseRegisterActionClassNew
---  CourseRegisterActionAddTutorialMember -> CourseRegisterActionClassExisting
---  CourseRegisterActionUnknownPerson     -> CourseRegisterActionClassMissing
---
---data CourseRegisterActionDiff -- old new key
---   = CourseRegisterActionDiffNew
---     { crActKey         :: Text
---     , crActNewUser     :: UserId              -- crActNewKey :: Maybe key
---     , crActNewTutorial :: Maybe TutorialIdent -- crActNew    :: new
---     }
---   | CourseRegisterActionDiffExisting
---     { crActKey         :: Text
---     , crActOldUser     :: UserId              -- crActOldKey :: key
---     , crActOldTutorial :: TutorialIdent       -- crActOld    :: old
---     , crActNewTutorial :: Maybe TutorialIdent -- crActNew    :: new
---     }
---   | CourseRegisterActionDiffMissing
---     { crActKey         :: Text
---   --{ crActOldKey :: key
---   --, crActOld    :: old
---     }
---
---makeLenses_ ''CourseRegisterActionDiff
---makePrisms ''CourseRegisterActionDiff
-
---data CourseRegisterException
---   = CourseRegisterExceptionDuplicateIdent
---     { crExcptDuplicateIdent :: Text
---     }
---   | CourseRegisterException
---     { crExcpt :: Text
---     }
---   deriving (Show, Typeable)
---
---makeLenses_ ''CourseRegisterException
---
---instance Exception CourseRegisterException
-
---courseRegisterRenderException :: CourseRegisterException -> DB Text
---courseRegisterRenderException = ap getMessageRender . pure
---
---registerActionDefaultChecked :: CourseRegisterAction -> Bool
---registerActionDefaultChecked = (/=) CourseRegisterActionUnknownPerson
---
---registerActionDisabled :: CourseRegisterAction -> Bool
---registerActionDisabled = (==) CourseRegisterActionUnknownPerson
-
 
 data AddUserRequest = AddUserRequest
   { auReqUsers    :: Set UserSearchKey
   , auReqTutorial :: Maybe TutorialIdent
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
---data AddUser = AddUser
---  { addUserIdent    :: Text
---  , addUserTutorial :: Maybe TutorialIdent
---  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
 
 data AddParticipantsResult = AddParticipantsResult
   { aurNotFound              :: Set UserSearchKey
@@ -195,10 +124,30 @@ instance Monoid AddParticipantsResult where
 getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCAddUserR = postCAddUserR
 postCAddUserR tid ssh csh = do
-  _cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
   today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
   currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
 
+  piConfirmPost <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction)
+  $logErrorS "CAddUserR" . tshow $ Aeson.encode piConfirmPost
+  let
+    piConfirmRes :: FormResult CourseRegisterActionData
+    piConfirmRes = maybe FormMissing FormSuccess piConfirmPost
+  case piConfirmRes of
+    FormSuccess res'' -> do
+      let res' = [res'']
+      forM_ res' $ \case
+        CourseRegisterActionAddTutorialMemberData{..} -> do
+          registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
+          tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
+          registerTutorialMembers tutId registeredUsers
+          redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
+        CourseRegisterActionAddParticipantData{..} -> do
+          void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
+          redirect $ CourseR tid ssh csh CUsersR
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+
   ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
     let
       cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
@@ -267,14 +216,6 @@ postCAddUserR tid ssh csh = do
               }
         $(widgetFile "course/add-user/confirmation-wrapper")
 
-        --registeredUsers <- registerUsers cid avsUsers
-        --case auReqTutorial of
-        --  Nothing -> redirect $ CourseR tid ssh csh CUsersR
-        --  Just tutorialName -> do
-        --    tutId <- upsertNewTutorial cid tutorialName
-        --    registerTutorialMembers tutId registeredUsers
-        --    redirect $ CTutorialR tid ssh csh tutorialName TUsersR
-
   let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
 
   siteLayoutMsg heading $ do
@@ -284,110 +225,48 @@ postCAddUserR tid ssh csh = do
       , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
       }
 
---getRowKey :: AddUser -> MaybeT DB UserId
---getRowKey AddUser{..} = MaybeT . liftHandler $ upsertAvsUser addUserIdent
 
---confirmAddUser :: SomeRoute UniWorX -> Handler Html
+registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId)
---confirmAddUser srcRoute = do
+registerUsers cid users
---  let
---    existing = Map.fromList $ zip currentKeys rows
---    sourceDiff :: ConduitT () CourseRegisterActionDiff (StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB) ()
---    sourceDiff = do
---      let
---        toDiff :: CourseRegisterActionData -> StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB CourseRegisterActionDiff
---        toDiff row = do
---          rowKey <- lift $ handle (throwM . (CourseRegisterException :: Text -> CourseRegisterException) <=< courseRegisterRenderException) . runMaybeT $ getRowKey row
---          seenKeys <- State.get
---          (<* modify (maybe id (flip Map.insert row) rowKey)) $ if
---            | Just rowKey' <- rowKey
---            , Just oldRow <- Map.lookup rowKey' seenKeys
---              -> throwM $ CourseRegisterExceptionDuplicateIdent rowKey'
---            | Just rowKey' <- rowKey
---            , Just oldRow <- Map.lookup rowKey' existing
---              -> return $ CourseRegisterActionDiffExisting rowKey' oldRow row
---            | otherwise
---              -> return $ CourseRegisterActionDiffNew rowKey' oldRow row
---      transPipe liftHandler blubb .| C.mapM toDiff
---      seen <- State.get
---      forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
---        | Map.member rowKey seen -> return ()
---        | otherwise -> yield $ CourseRegisterActionDiffMissing rowKey
---
---    accActionMap :: Map CourseRegisterActionClass (Set CourseRegisterActionData) -> CourseRegisterActionData -> Map CourseRegisterActionClass (Set CourseRegisterActionData)
---    accActionMap acc act = Map.insertWith Set.union (courseRegisterCoarsenActionClass $ classifyRegisterAction act) (Set.singleton act) acc
---
---    courseRegisterComputeActions :: CourseRegisterActionDiff -> ConduitT () CourseRegisterActionData DB ()
---    courseRegisterComputeActions = \case
---      CourseRegisterActionDiffNew{..} -> return () -- crActKey, crActNewUser, crActNewTutorial
---        -- TODO: fetch course participant, if any
---        -- TODO: if course participant was found, fetch tutorial member and (if yes) yield CourseRegisterActionAddTutorialMemberData
---        -- TODO: if no course participant was found, yield CourseRegisterActionAddParticipantData
---      CourseRegisterActionDiffExisting{..} -> return () -- TODO
---      CourseRegisterActionDiffMissing{} -> return () -- pseudo-action; no deletion -- TODO: yield smth?
---    courseRegisterComputeActions' :: ConduitT CourseRegisterActionDiff Void DB (Map CourseRegisterActionClass (Set CourseRegisterActionData))
---    courseRegisterComputeActions' = do
---      let innerAct = awaitForever $ \x
---            -> let doHandle = handle $ throwM CourseRegisterException <=< courseRegisterRenderException
---                in C.sourceList <=< lift . doHandle . runConduit $ courseRegisterComputeActions x .| C.foldMap pure
---      innerAct .| C.foldl accActionMap Map.empty
---  actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift courseRegisterComputeActions'
---
---  when (Map.null actionMap) $
---    addMessageI Info MsgCourseParticipantsRegisterUnnecessary
---    redirect srcRoute
---
---  E.transactionSave -- Commit side-effects of courseRegisterComputeActions
---
---  liftHandler . (>>= sendResponse) $
---    siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do
---      setTitleI MsgCourseParticipantsRegisterConfirmationHeading
---      let precomputeIdents :: forall f m. (Eq (Element f), MonoFoldable f, MonadHandler m) => f -> m (Element f -> Text)
---          precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
---      actionClassIdent <- precomputeIdents $ Map.keys actionMap
---      actionIdent <- precomputeIdents . Set.union $ Map.elems actionMap
---      let
---        --defaultChecked actClass = case courseRegisterCoarsenActionClass actClass of
---        --  CourseRegisterActionDiffMissing -> False
---        --  _other                          -> True
---        defaultChecked = const True
---        confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget
---        confirmCheckBox vAttrs act = do
---          let sJsonField :: Field (HandlerFor UniWorX) CourseRegisterAction
---              sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
---                [whamlet|
---                  $newline never
---                  <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :registerActionDefaultChecked (classifyRegisterAction act):checked :registerActionDisabled (classifyRegisterAction act):disabled>
---                |]
---          fieldView sJsonField act mempty vAttrs (Right act) False
---        availableActs :: Widget
---        availableActs = fieldView (secretJsonField :: Field Handler (Set CourseRegisterAction)) "" mempty [] (Right . Set.unions $ Map.elems actionMap) False
---      (confirmForm', confirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation"))
---      let confirmForm = wrapForm confirmForm' FormSettings
---            { formMethod   = POST
---            , formAction   = Just $ tblLink id
---            , formEncoding = confirmEnctype
---            , formAttrs    = []
---            , formSubmit   = FormNoSubmit
---            , formAnchor   = Nothing :: Maybe Text
---            }
---      $(widgetFile "course/add-user/confirmation-wrapper")
-
-
-_registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) ()
-_registerUsers cid users
   | Map.null users = do
     addMessageI Error MsgCourseParticipantsRegisterNoneGiven
     return Set.empty
   | otherwise = do
-    (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (_registerUser cid) $ Map.toList users
+    (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users
     unless (Set.null aurRegisterSuccess) $
       addMessageI Success . MsgCourseParticipantsRegistered $ Set.size aurRegisterSuccess
     unless (Set.null aurAlreadyRegistered) $
       addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered
     return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered
 
-_upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
+registerUser :: CourseId
-_upsertNewTutorial cid tutorialName = do
+             -> (UserSearchKey, Maybe UserId)
+             -> YesodJobDB UniWorX AddParticipantsResult
+registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent }
+registerUser  cid (_avsIdent, Just uid) = exceptT return return $ do
+  whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
+    throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
+
+  courseParticipantRegistration <- liftIO getCurrentTime
+  void . lift $ upsert
+    CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess
+      { courseParticipantCourse = cid
+      , courseParticipantUser = uid
+      , courseParticipantAllocated = Nothing
+      , courseParticipantState = CourseParticipantActive
+      , ..
+      }
+    [ CourseParticipantRegistration =. courseParticipantRegistration
+    , CourseParticipantAllocated =. Nothing
+    , CourseParticipantState =. CourseParticipantActive
+    ]
+  lift . audit $ TransactionCourseParticipantEdit cid uid
+  lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?
+
+  return $ mempty { aurRegisterSuccess = Set.singleton uid }
+
+upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
+upsertNewTutorial cid tutorialName = do
   now <- liftIO getCurrentTime
   Entity tutId _ <- runDB $ upsert
     Tutorial
@@ -410,8 +289,8 @@ _upsertNewTutorial cid tutorialName = do
     ]
   return tutId
 
-_registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
+registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
-_registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
+registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
   prevParticipants <- fmap Set.fromList $ selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []
   participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> upsert
     TutorialParticipant
@@ -424,57 +303,3 @@ _registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
     addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants
   unless (Set.null prevParticipants) $
     addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants
-
---addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
---                              => AddParticipantsResult
---                              -> ReaderT (YesodPersistBackend UniWorX) m [Message]
---addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
---  unless (null aurNotFound) $ do
---    let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|]
---        modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs")
---    tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
---
---  aurAlreadyRegistered'     <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered)
---  aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember)
---
---  unless (null aurAlreadyRegistered) $ do
---    let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
---        modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
---    tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
---  unless (null aurAlreadyTutorialMember) $ do
---    let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|]
---        modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember")
---    tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
---
---  unless (null aurRegisterSuccess) $
---    tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
---  unless (null aurTutorialSuccess) $
---    tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
-
-
-_registerUser :: CourseId
-             -> (UserSearchKey, Maybe UserId)
-             -> YesodJobDB UniWorX AddParticipantsResult
-             -- -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
-_registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } -- tell $ mempty { aurNotFound = Set.singleton avsIdent }
-_registerUser  cid (_avsIdent, Just uid) = exceptT return return $ do
-  whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
-    throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
-
-  courseParticipantRegistration <- liftIO getCurrentTime
-  void . lift $ upsert
-    CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess
-      { courseParticipantCourse = cid
-      , courseParticipantUser = uid
-      , courseParticipantAllocated = Nothing
-      , courseParticipantState = CourseParticipantActive
-      , ..
-      }
-    [ CourseParticipantRegistration =. courseParticipantRegistration
-    , CourseParticipantAllocated =. Nothing
-    , CourseParticipantState =. CourseParticipantActive
-    ]
-  lift . audit $ TransactionCourseParticipantEdit cid uid
-  lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?
-
-  return $ mempty { aurRegisterSuccess = Set.singleton uid }