fradrive-old/src/Handler/ExamOffice/Users.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.ExamOffice.Users
  ( getEOUsersR, postEOUsersR
  , getEOUsersInviteR, postEOUsersInviteR
  ) where

import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations

import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
import Jobs.Queue

import qualified Database.Esqueleto as E

import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map ((!), (!?))

import qualified Data.HashSet as HashSet


instance IsInvitableJunction ExamOfficeUser where
  type InvitationFor ExamOfficeUser = User
  data InvitableJunction ExamOfficeUser = JunctionExamOfficeUser
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData ExamOfficeUser = InvDBDataExamOfficeUser
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData ExamOfficeUser = InvTokenDataExamOfficeUser
    { invTokenExamOfficeUserOffice :: CryptoUUIDUser
    }
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\ExamOfficeUser{..} -> (examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser))
    (\(examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser) -> ExamOfficeUser{..})

instance ToJSON (InvitableJunction ExamOfficeUser) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction ExamOfficeUser) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData ExamOfficeUser) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData ExamOfficeUser) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }

instance ToJSON (InvitationTokenData ExamOfficeUser) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
instance FromJSON (InvitationTokenData ExamOfficeUser) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }

examOfficeUserInvitationConfig :: InvitationConfig ExamOfficeUser
examOfficeUserInvitationConfig = InvitationConfig{..}
  where
    invitationRoute _ _ = return $ ExamOfficeR EOUsersInviteR
    invitationResolveFor InvTokenDataExamOfficeUser{..} = do
      officeId <- decrypt invTokenExamOfficeUserOffice
      bool notFound (return officeId) =<< existsKey officeId
    invitationSubject (Entity _ User{..}) _ = do
      return . SomeMessage $ MsgMailSubjectExamOfficeUserInvitation userDisplayName
    invitationHeading (Entity _ User{..}) _ = do
      return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
      let itExpiresAt = Nothing
          itStartsAt = Nothing
          itAddAuth = Nothing
      return InvitationTokenConfig{..}
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = pure (JunctionExamOfficeUser, ())
    invitationInsertHook _ _ _ ExamOfficeUser{..} _ act = do
      res <- act
      audit $ TransactionExamOfficeUserAdd examOfficeUserOffice examOfficeUserUser
      return res
    invitationSuccessMsg _ _ =
      return $ SomeMessage MsgExamOfficeUserInvitationAccepted
    invitationUltDest _ _ = return $ SomeRoute NewsR


makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
makeExamOfficeUsersForm template = renderWForm FormStandard $ do
  cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute

  let
    miAdd' :: (Text -> Text)
           -> FieldView UniWorX
           -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
    miAdd' nudge btn csrf = do
      MsgRenderer mr <- getMsgRenderer
      (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgExamOfficeUserEmail & addName (nudge "users") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
      let
        res' :: FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
        res' = addRes <&> \newUsers oldUsers -> if
          | null newUsers
            -> pure oldUsers
          | otherwise
            -> pure . nub $ oldUsers ++ Set.toList newUsers
      return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
    miCell' :: Either UserEmail UserId -> Widget
    miCell' (Left email) = do
      invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
      $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
    miCell' (Right uid) = do
      User{..} <- liftHandler . runDB $ getJust uid
      $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
    miLayout' :: MassInputLayout ListLength _ ()
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examOfficeUsers/layout")
    miIdent' :: Text
    miIdent' = "exam-office-users"
    fSettings :: FieldSettings UniWorX
    fSettings = fslI MsgExamOfficeSubscribedUsers
              & setTooltip MsgExamOfficeSubscribedUsersTip
    fRequired :: Bool
    fRequired = False

  template' <- for template $ \uids -> liftHandler . runDB $ do
    let (invitations, knownUsers) = partitionEithers $ Set.toList uids
    knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
      E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
      E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
      return $ user E.^. UserId
    return $ map Left invitations ++ map Right knownUsers'

  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'


-- | Manage the list of users this user (in her function as exam-office)
--   has an interest in, i.e. that authorize her to view their grades
getEOUsersR, postEOUsersR :: Handler Html
getEOUsersR = postEOUsersR
postEOUsersR = do
  uid <- requireAuthId

  oldUsers <- liftHandler . runDB $ do
    users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do
      E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
       E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
      return $ user E.^. UserId
    invites <- Map.keysSet <$> sourceInvitationsF @ExamOfficeUser uid
    return $ setOf (folded . _Value . re _Right) users <> Set.mapMonotonic Left invites

  ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers

  formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
    liftHandler . runDBJobs . forM_ changes $ \change -> if
      | change `Set.member` oldUsers -> case change of
          Right change' -> do
            deleteBy $ UniqueExamOfficeUser uid change'
            audit $ TransactionExamOfficeUserDelete uid change'
          Left change' ->
            deleteInvitation @ExamOfficeUser uid change'
      | otherwise -> case change of
          Right change' -> do
            insert_ $ ExamOfficeUser uid change'
            audit $ TransactionExamOfficeUserAdd uid change'
          Left change' -> do
            cID <- encrypt uid
            sinkInvitation examOfficeUserInvitationConfig (change', uid, (InvDBDataExamOfficeUser, InvTokenDataExamOfficeUser cID))
    addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers)
    redirect $ ExamOfficeR EOExamsR

  let
    usersView' = wrapForm usersView def
      { formAction = Just . SomeRoute $ ExamOfficeR EOUsersR
      , formEncoding = usersEnc
      }

  siteLayoutMsg MsgMenuExamOfficeUsers $ do
    setTitleI MsgMenuExamOfficeUsers

    [whamlet|
      $newline never
      <p>
        _{MsgExamOfficeSubscribedUsersExplanation}
      ^{usersView'}
    |]

getEOUsersInviteR, postEOUsersInviteR :: Handler Html
getEOUsersInviteR = postEOUsersInviteR
postEOUsersInviteR = invitationR examOfficeUserInvitationConfig