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


data BearerTokenForm = BearerTokenForm
  { btfAuthority :: HashSet (Either UserGroupName UserId)
  , btfRoutes    :: Maybe (HashSet (Route UniWorX))
  , btfRestrict  :: HashMap (Route UniWorX) Value
  , btfAddAuth   :: Maybe AuthDNF
  , btfExpiresAt :: Maybe (Maybe UTCTime)
  , btfStartsAt  :: Maybe UTCTime
  }

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 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'
    <*> 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)

    fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt

  siteLayoutMsg MsgMenuAdminTokens $ do
    setTitleI MsgMenuAdminTokens

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

    warning <- notification NotificationBroad <$> messageI Warning MsgBearerTokenUsageWarning

    $(widgetFile "admin-tokens")