gundeck: Fix SNS endpoint parser

changelog.d/3-bug-fixes/sns-arn-parsing

@@ -0,0 +1,3 @@
+The AWS SNS ARN was parsed by accumulating the environment name up to the first
+dash ('-') such that parts of this name spilled over into the app name. Now, we
+accumulate up to the last dash.

services/gundeck/default.nix

@@ -24,6 +24,7 @@
 , exceptions
 , extended
 , extra
+, foldl
 , gitignoreSource
 , gundeck-types
 , hedis
@@ -105,6 +106,7 @@ mkDerivation {
     exceptions
     extended
     extra
+    foldl
     gundeck-types
     hedis
     http-client
@@ -184,6 +186,7 @@ mkDerivation {
     aeson
     aeson-pretty
     amazonka
+    amazonka-core
     async
     base
     bytestring-conversion

services/gundeck/gundeck.cabal

@@ -128,6 +128,7 @@ library
     , exceptions             >=0.4
     , extended
     , extra                  >=1.1
+    , foldl
     , gundeck-types          >=1.0
     , hedis                  >=0.14.0
     , http-client            >=0.7
@@ -391,6 +392,7 @@ test-suite gundeck-tests
   type:               exitcode-stdio-1.0
   main-is:            Main.hs
   other-modules:
+    Aws.Arn
     DelayQueue
     Json
     MockGundeck
@@ -452,6 +454,7 @@ test-suite gundeck-tests
       aeson
     , aeson-pretty
     , amazonka
+    , amazonka-core
     , async
     , base
     , bytestring-conversion

services/gundeck/src/Gundeck/Aws/Arn.hs

@@ -53,6 +53,7 @@ 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
@@ -151,9 +152,14 @@ endpointTopicParser :: Parser EndpointTopic
 endpointTopicParser = do
   _ <- string "endpoint"
   t <- char '/' *> transportParser
-  e <- char '/' *> takeTill (== '-')
-  a <- char '-' *> takeTill (== '/')
+  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

services/gundeck/src/Gundeck/Push.hs

@@ -34,7 +34,7 @@ where
 import Control.Arrow ((&&&))
 import Control.Error
 import Control.Exception (ErrorCall (ErrorCall))
-import Control.Lens (view, (.~), (^.))
+import Control.Lens (to, view, (.~), (^.))
 import Control.Monad.Catch
 import Data.Aeson as Aeson (Object)
 import Data.Id
@@ -525,22 +525,35 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget)
 updateEndpoint :: UserId -> PushToken -> EndpointArn -> Aws.SNSEndpoint -> Gundeck ()
 updateEndpoint uid t arn e = do
   env <- view awsEnv
+  requestId <- view reqId
+
   unless (equalTransport && equalApp) $ do
-    Log.err $ logMessage uid arn (t ^. token) "Transport or app mismatch"
+    Log.err $ logMessage requestId "PushToken does not fit to user_push data: Transport or app mismatch"
     throwM $ mkError status500 "server-error" "Server Error"
-  Log.info $ logMessage uid arn (t ^. token) "Upserting push token."
+
+  Log.info $ logMessage requestId "Upserting push token."
   let users = Set.insert uid (e ^. endpointUsers)
   Aws.execute env $ Aws.updateEndpoint users (t ^. token) arn
   where
     equalTransport = t ^. tokenTransport == arn ^. snsTopic . endpointTransport
     equalApp = t ^. tokenApp == arn ^. snsTopic . endpointAppName
-    logMessage a r tk m =
+    logMessage requestId m =
       "user"
-        .= UUID.toASCIIBytes (toUUID a)
+        .= UUID.toASCIIBytes (toUUID uid)
         ~~ "token"
-          .= Text.take 16 (tokenText tk)
+          .= Text.take 16 (t ^. token . to tokenText)
+        ~~ "tokenTransport"
+          .= show (t ^. tokenTransport)
+        ~~ "tokenApp"
+          .= (t ^. tokenApp . to appNameText)
         ~~ "arn"
-          .= toText r
+          .= toText arn
+        ~~ "endpointTransport"
+          .= show (arn ^. snsTopic . endpointTransport)
+        ~~ "endpointAppName"
+          .= (arn ^. snsTopic . endpointAppName . to appNameText)
+        ~~ "request"
+          .= unRequestId requestId
         ~~ msg (val m)
 
 deleteToken :: UserId -> Token -> Gundeck (Maybe ())

services/gundeck/test/unit/Aws/Arn.hs

@@ -0,0 +1,57 @@
+module Aws.Arn where
+
+import Amazonka.Data.Text
+import Control.Lens
+import Gundeck.Aws.Arn
+import Gundeck.Types
+import Imports
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests =
+  testGroup
+    "Aws.Arn"
+    [ testGroup
+        "Parser"
+        [ testGroup
+            "EndpointArn"
+            [ testCaseSteps "real world round-trip" realWorldArnTest,
+              testCaseSteps "made-up round-trip" madeUpArnTest
+            ]
+        ]
+    ]
+
+realWorldArnTest :: HasCallStack => (String -> IO ()) -> Assertion
+realWorldArnTest step = do
+  step "Given an ARN from a test environment"
+  let arnText :: Text = "arn:aws:sns:eu-central-1:091205192927:endpoint/GCM/sven-test-782078216207/ded226c7-45b8-3f6c-9e89-f253340bbb60"
+  arnData <-
+    either (\e -> assertFailure ("Arn cannot be parsed: " ++ e)) pure (fromText @EndpointArn arnText)
+
+  step "Check that values were parsed correctly"
+  (arnData ^. snsRegion) @?= "eu-central-1"
+  (arnData ^. snsAccount . to fromAccount) @?= "091205192927"
+  (arnData ^. snsTopic . endpointTransport) @?= GCM
+  (arnData ^. snsTopic . endpointAppName) @?= "782078216207"
+  (arnData ^. snsTopic . endpointId . to (\(EndpointId eId) -> eId)) @?= "ded226c7-45b8-3f6c-9e89-f253340bbb60"
+
+  step "Expect values to be de-serialized correctly"
+  (toText arnData) @?= arnText
+
+madeUpArnTest :: HasCallStack => (String -> IO ()) -> Assertion
+madeUpArnTest step = do
+  step "Given an ARN with data to cover untested cases"
+  let arnText :: Text = "arn:aws:sns:us-east-2:000000000001:endpoint/APNS/nodash-000000000002/8ffd8d14-db06-4f3a-a3bb-08264b9dbfb0"
+  arnData <-
+    either (\e -> assertFailure ("Arn cannot be parsed: " ++ e)) pure (fromText @EndpointArn arnText)
+
+  step "Check that values were parsed correctly"
+  (arnData ^. snsRegion) @?= "us-east-2"
+  (arnData ^. snsAccount . to fromAccount) @?= "000000000001"
+  (arnData ^. snsTopic . endpointTransport) @?= APNS
+  (arnData ^. snsTopic . endpointAppName) @?= "000000000002"
+  (arnData ^. snsTopic . endpointId . to (\(EndpointId eId) -> eId)) @?= "8ffd8d14-db06-4f3a-a3bb-08264b9dbfb0"
+
+  step "Expect values to be de-serialized correctly"
+  (toText arnData) @?= arnText

services/gundeck/test/unit/Main.hs

@@ -20,6 +20,7 @@ module Main
   )
 where
 
+import Aws.Arn qualified
 import Data.Metrics.Test (pathsConsistencyCheck)
 import Data.Metrics.WaiRoute (treeToPaths)
 import DelayQueue qualified
@@ -50,5 +51,6 @@ main =
         Native.tests,
         Push.tests,
         ThreadBudget.tests,
-        ParseExistsError.tests
+        ParseExistsError.tests,
+        Aws.Arn.tests
       ]