content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  -- This file is part of the Wire Server implementation.
  --
  -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
  --
  -- This program is free software: you can redistribute it and/or modify it under
  -- the terms of the GNU Affero General Public License as published by the Free
  -- Software Foundation, either version 3 of the License, or (at your option) any
  -- later version.
  --
  -- This program is distributed in the hope that it will be useful, but WITHOUT
  -- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  -- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
  -- details.
  --
  -- You should have received a copy of the GNU Affero General Public License along
  -- with this program. If not, see <https://www.gnu.org/licenses/>.
  
  module Gundeck.Aws.Arn
    ( ArnEnv (..),
      Region (..),
      Account (..),
      EndpointId (..),
      toText,
      fromText,
  
      -- * SNS ARN
      SnsArn,
      mkSnsArn,
      snsRegion,
      snsAccount,
      snsTopic,
  
      -- ** ARNs
      AppArn,
      EndpointArn,
      transportParser,
  
      -- ** Topics
      AppTopic,
      mkAppTopic,
      appTransport,
      appName,
      EndpointTopic,
      mkEndpointTopic,
      endpointTransport,
      endpointAppName,
      endpointId,
    )
  where
  
  import Amazonka (Region (..))
  import Amazonka.Data
  import Control.Foldl qualified as Foldl
  import Control.Lens
  import Data.Attoparsec.Text
  import Data.Text qualified as Text
  import Imports
  import Wire.API.Push.V2 (AppName (..), Transport (..))
  
  newtype ArnEnv = ArnEnv {arnEnvText :: Text} deriving (Show, ToText, FromJSON)
  
  newtype Account = Account {fromAccount :: Text} deriving (Eq, Ord, Show, ToText, FromJSON)
  
  newtype EndpointId = EndpointId Text deriving (Eq, Ord, Show, ToText)
  
  data SnsArn a = SnsArn
    { _snsAsText :: !Text,
      _snsRegion :: !Region,
      _snsAccount :: !Account,
      _snsTopic :: !a
    }
    deriving (Eq, Ord, Show)
  
  data AppTopic = AppTopic
    { _appAsText :: !Text,
      _appTransport :: !Transport,
      _appName :: !AppName
    }
    deriving (Eq, Show)
  
  data EndpointTopic = EndpointTopic
    { _endpointAsText :: !Text,
      _endpointTransport :: !Transport,
      _endpointAppName :: !AppName,
      _endpointId :: !EndpointId
    }
    deriving (Eq, Ord, Show)
  
  type AppArn = SnsArn AppTopic
  
  type EndpointArn = SnsArn EndpointTopic
  
  makeLenses ''SnsArn
  
  makeLenses ''AppTopic
  
  makeLenses ''EndpointTopic
  
  instance ToText (SnsArn a) where
    toText = view snsAsText
  
  instance (FromText a, ToText a) => FromText (SnsArn a) where
    fromText = parseOnly snsArnParser
  
  instance ToText AppTopic where
    toText = view appAsText
  
  instance ToText EndpointTopic where
    toText = view endpointAsText
  
  instance FromText EndpointTopic where
    fromText = parseOnly endpointTopicParser
  
  mkSnsArn :: (ToText topic) => Region -> Account -> topic -> SnsArn topic
  mkSnsArn r a t =
    let txt = Text.intercalate ":" ["arn:aws:sns", toText r, toText a, toText t]
     in SnsArn txt r a t
  
  mkAppTopic :: ArnEnv -> Transport -> AppName -> AppTopic
  mkAppTopic e t n =
    let name = toText e <> "-" <> appNameText n
        txt = Text.intercalate "/" ["app", arnTransportText t, name]
     in AppTopic txt t n
  
  mkEndpointTopic :: ArnEnv -> Transport -> AppName -> EndpointId -> EndpointTopic
  mkEndpointTopic e t n i =
    let name = toText e <> "-" <> appNameText n
        txt = Text.intercalate "/" ["endpoint", arnTransportText t, name, toText i]
     in EndpointTopic txt t n i
  
  arnTransportText :: Transport -> Text
  arnTransportText GCM = "GCM"
  arnTransportText APNS = "APNS"
  arnTransportText APNSSandbox = "APNS_SANDBOX"
  arnTransportText APNSVoIP = "APNS_VOIP"
  arnTransportText APNSVoIPSandbox = "APNS_VOIP_SANDBOX"
  
  -- Parsers --------------------------------------------------------------------
  
  snsArnParser :: (FromText t, ToText t) => Parser (SnsArn t)
  snsArnParser = do
    _ <- string "arn" *> char ':' *> string "aws" *> char ':' *> string "sns"
    r <- char ':' *> takeTill (== ':') >>= either fail pure . fromText
    a <- char ':' *> takeTill (== ':')
    t <- char ':' *> takeText >>= either fail pure . fromText
    pure $ mkSnsArn r (Account a) t
  
  endpointTopicParser :: Parser EndpointTopic
  endpointTopicParser = do
    _ <- string "endpoint"
    t <- char '/' *> transportParser
    envAndName <- char '/' *> takeTill (== '/')
    i <- char '/' *> takeWhile1 (not . isSpace)
    let xs = Text.split (== '-') envAndName
        e = Text.intercalate (Text.pack "-") (init xs)
    a <- case Foldl.fold Foldl.last xs of
      Just x -> pure x
      Nothing -> fail ("Cannot parse appName in " ++ show xs)
  
    pure $ mkEndpointTopic (ArnEnv e) t (AppName a) (EndpointId i)
  
  transportParser :: Parser Transport
  transportParser =
    string "GCM"
      $> GCM
      <|> string "APNS_VOIP_SANDBOX"
      $> APNSVoIPSandbox
      <|> string "APNS_VOIP"
      $> APNSVoIP
      <|> string "APNS_SANDBOX"
      $> APNSSandbox
      <|> string "APNS"
      $> APNS
  