fradrive/src/Handler/Admin/Tokens.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Admin.Tokens
  ( getAdminTokensR, postAdminTokensR
  ) where

import Import
import Handler.Utils

import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson

import Data.Map ((!), (!?))

import qualified Data.Text as Text

import qualified Database.Esqueleto.Legacy as E hiding (random_)
import qualified Database.Esqueleto.PostgreSQL as E

import qualified Data.Conduit.Combinators as C

import Data.List (genericTake)

import System.Random.Shuffle (shuffleM)


data BTFImpersonate
  = BTFISingle
    { btfiUser :: UserId
    }
  | BTFIRandom
    { btfiCount :: Int64
    , btfiWeightActivity :: Bool
    }
  deriving (Eq, Ord, Generic)

data BTFImpersonate' = BTFINone' | BTFISingle' | BTFIRandom'
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving (Universe, Finite, Hashable)
nullaryPathPiece ''BTFImpersonate' $ let noNone n | n == "none" = "impersonate-" <> n
                                                  | otherwise   = n
                                      in noNone . camelToPathPiece' 1 . dropSuffix "'"
embedRenderMessage ''UniWorX ''BTFImpersonate' $ ("BearerTokenImpersonate" <>) . dropPrefix "BTFI" . dropSuffix "'"
  
data BearerTokenForm = BearerTokenForm
  { btfAuthority   :: HashSet (Either UserGroupName UserId)
  , btfImpersonate :: Maybe BTFImpersonate
  , btfRoutes      :: Maybe (HashSet (Route UniWorX))
  , btfRestrict    :: HashMap (Route UniWorX) Value
  , btfAddAuth     :: Maybe AuthDNF
  , btfExpiresAt   :: Maybe (Maybe UTCTime)
  , btfStartsAt    :: Maybe UTCTime
  } deriving (Generic)

bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
bearerTokenForm = do
  muid <- maybeAuthId
  mr <- getMessageRender

  btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") MsgBearerTokenAuthorityGroupMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
  btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
  let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
      btfAuthority'
        = (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty)

  let
    btfiActs = mapF $ \case
      BTFINone' -> pure Nothing
      BTFISingle' -> Just . BTFISingle <$> apreq (checkMap (left MsgBearerTokenImpersonateUnknownUser) Right $ userField False Nothing) (fslpI MsgBearerTokenImpersonateSingleUser (mr MsgLdapIdentificationOrEmail)) Nothing
      BTFIRandom' -> fmap Just $ BTFIRandom
        <$> apreq (posIntFieldI MsgBearerTokenImpersonateRandomNegative) (fslI MsgBearerTokenImpersonateRandomCount) (Just 1)
        <*> apopt checkBoxField (fslI MsgBearerTokenImpersonateRandomWeightActivity) (Just True)
  btfImpersonate' <- multiActionW btfiActs (fslI MsgBearerTokenImpersonate) Nothing

  let btfRoutesForm = HashSet.fromList <$> massInputListA routeField (const "") MsgBearerTokenRouteMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-routes" :: Text) (fslI MsgBearerTokenRoutes & setTooltip MsgBearerTokenRoutesTip) True Nothing
  btfRoutes' <- optionalActionW btfRoutesForm (fslI MsgBearerTokenRestrictRoutes) (Just True)

  let btfRestrictForm = massInputAccumEditW miAdd' miCell' (\p -> Just . SomeRoute $ AdminTokensR :#: p) miLayout' ("token-restrictions" :: Text) (fslI MsgBearerTokenRestrictions) False Nothing
        where miAdd' nudge = fmap (over (mapped . _1) tweakRes) . miForm nudge . Left
                where tweakRes res = res <&> \(newRoute, newRestr) oldRestrs -> pure (bool [(newRoute, newRestr)] [] $ newRoute `HashMap.member` HashMap.fromList oldRestrs)
              miCell' nudge = miForm nudge . Right
              miForm :: (Text -> Text)
                     -> Either (FieldView UniWorX) (Route UniWorX, Value)
                     -> Form (Route UniWorX, Value)
              miForm nudge mode csrf = do
                (routeRes, routeView) <- mpreq routeField (fslI MsgBearerTokenRestrictRoute & addName (nudge "route")) (mode ^? _Right . _1)
                (restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) textareaField) (fslI MsgBearerTokenRestrictValue & addName (nudge "restr")) (mode ^? _Right . _2)

                return ((,) <$> routeRes <*> restrRes, case mode of
                           Left btn -> $(widgetFile "widgets/massinput/token-restrictions/add")
                           Right _  -> $(widgetFile "widgets/massinput/token-restrictions/cell")
                       )

              miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
              miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")

  btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm

  btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing

  btfExpiresAt' <- optionalActionW (aopt utcTimeField (fslI MsgBearerTokenExpires & setTooltip MsgBearerTokenExpiresTip) Nothing) (fslI MsgBearerTokenOverrideExpiration) (Just False)
  btfStartsAt' <- wopt utcTimeField (fslI MsgBearerTokenOverrideStart & setTooltip MsgBearerTokenOverrideStartTip) Nothing

  return $ BearerTokenForm
    <$> btfAuthority'
    <*> btfImpersonate'
    <*> btfRoutes'
    <*> btfRestrict'
    <*> btfAddAuth'
    <*> btfExpiresAt'
    <*> btfStartsAt'


getAdminTokensR, postAdminTokensR :: Handler Html
getAdminTokensR = postAdminTokensR
postAdminTokensR = do
  ((bearerReq, bearerView), bearerEnc) <- runFormPost $ renderWForm FormStandard bearerTokenForm

  mjwt <- formResultMaybe bearerReq $ \BearerTokenForm{..} -> do
    uid <- requireAuthId
    let btfAuthority' = btfAuthority
          & HashSet.insert (Right uid)
          & HashSet.map (left toJSON)

    case btfImpersonate of
      Just BTFIRandom{..} -> do
        MsgRenderer mr <- getMsgRenderer
        now <- liftIO getCurrentTime
        users <- runDB $ if
          | not btfiWeightActivity -> fmap (fmap E.unValue) . E.select . E.from $ \user -> do
              E.orderBy [E.asc $ E.random_ @Int64]
              E.limit btfiCount
              return $ user E.^. UserId
          | otherwise -> do
              users <- fmap (fmap E.unValue) . E.select . E.from $ \user -> do
                E.orderBy [ E.asc . E.isNothing $ user E.^. UserLastAuthentication
                          , E.desc $ user E.^. UserLastAuthentication
                          ]
                E.limit $ 2 * btfiCount
                return $ user E.^. UserId
              genericTake btfiCount <$> shuffleM users

        let
          toTokenFile :: UserId -> DB (Either Void DBFile)
          toTokenFile uid' = do
            cID <- encrypt uid' :: DB CryptoUUIDUser
            tok <- encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' (Just uid') (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt
            return . Right $ File
              { fileTitle = unpack (toPathPiece cID) <.> "jwt"
              , fileModified = now
              , fileContent = Just . yield $ unJwt tok
              }

        sendResponse <=< serveZipArchive' ((ensureExtension `on` unpack) extensionZip (mr MsgBearerTokenArchiveName)) $ yieldMany users .| C.mapM toTokenFile
          
      _other -> do
        let btfImpersonate' = btfImpersonate <&> \case
              BTFISingle{..} -> btfiUser
              _other -> error "btfImpersonate: not BTFISingle where expected"

        fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfImpersonate' (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt

  siteLayoutMsg MsgHeadingAdminTokens $ do
    setTitleI MsgHeadingAdminTokens

    let bearerForm = wrapForm bearerView def
          { formMethod = POST
          , formAction = Just $ SomeRoute AdminTokensR
          , formEncoding = bearerEnc
          }

    warning <- notification NotificationBroad <$> messageI Warning MsgBearerTokenUsageWarning

    $(widgetFile "admin-tokens")