Complete bounded browser and API product behavior

test/RecoveryPhase.hs

@@ -53,7 +53,6 @@ runPhase cfg database redis store phase =
         recoverySession
         Shared
         rec
-        "settlement failed"
         "request timed out"
         (putObjectStream
           store

test/Spec.hs

@@ -49,6 +49,7 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import           Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
+import           GHC.Clock (getMonotonicTimeNSec)
 import           Hedgehog
   ( Gen
   , Property
@@ -69,7 +70,7 @@ import           Network.HTTP.Types
   , status404
   , status405
   )
-import           Network.Wai (Request (..))
+import           Network.Wai (Request (..), responseLBS)
 import           Network.Wai.Test
   ( SRequest (..)
   , SResponse (..)
@@ -81,6 +82,7 @@ import           Network.Wai.Test
 import           Nuthatch.Api
 import           Nuthatch.App
   ( authenticationHandler
+  , collectKeysBoundedWith
   , loginResponse
   , utf8Boundary
   )
@@ -111,6 +113,7 @@ import           Nuthatch.Recovery
   , trySynchronous
   , withLinkedWorker
   )
+import           Nuthatch.S3 (ListPage (..))
 import           Nuthatch.Types
 import           Nuthatch.Session (mintSession)
 import           Nuthatch.Streaming
@@ -119,7 +122,7 @@ import           Nuthatch.Streaming
   , maximumMultipartBytes
   , multipartPartBytes
   )
-import           Nuthatch.Ui (browsePage, browserScript)
+import           Nuthatch.Ui (browserScript, productPage)
 import           Servant
 import           Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
 import           Servant.Types.SourceT
@@ -143,10 +146,28 @@ tests = testGroup "nuthatch-unit"
   , protocolTests
   , recoveryTests
   , streamingTests
+  , productBehaviorTests
   , oidcTests
   , apiTests
   ]
 
+productBehaviorTests :: TestTree
+productBehaviorTests = testGroup "product behavior"
+  [ testCase "search deadline cancels an in-flight listing" $ do
+      started <- getMonotonicTimeNSec
+      result <- collectKeysBoundedWith
+        getMonotonicTimeNSec
+        (\_ _ -> do
+          threadDelay 100000
+          pure (Right (ListPage [] [] Nothing False)))
+        100
+        (started + 5000000)
+      finished <- getMonotonicTimeNSec
+      result @?= Right ([], True)
+      assertBool "listing returns inside the configured deadline margin"
+        (finished - started < 50000000)
+  ]
+
 streamingTests :: TestTree
 streamingTests = testGroup "streaming"
   [ testCase "upload bodies are inspected and emitted in bounded parts" $ do
@@ -537,7 +558,7 @@ apiTests = testGroup "typed HTTP boundary"
         ("prefix_mutation_rejected" `BS.isInfixOf` BL.toStrict prefixError)
   , testCase "production authentication validates cookies and callback emits secure cookies"
       testAuthenticationBoundary
-  , testCase "retained browser forms are wired to the typed API bridge"
+  , testCase "legacy browser entry directs safely to the static application"
       testBrowserBridge
   , testCase "links derive from the type-level API" $
       show (linkURI (safeLink api (Proxy :: Proxy HealthEndpoint)))
@@ -730,6 +751,9 @@ typedTestServer calls =
        counted (HealthResponse True)
   :<|> counted (ReadyResponse True)
   :<|> counted (BrowserScript "script")
+  :<|> (\_ -> counted (addHeader "default-src 'none'" (HtmlPage "app")))
+  :<|> (\_ -> Tagged $ \_ sendResponse ->
+        sendResponse (responseLBS status404 [] ""))
   :<|> counted
         (addHeader "transaction=cookie"
           (addHeader "https://issuer.example/authorize" NoContent))
@@ -737,7 +761,7 @@ typedTestServer calls =
         (addHeader "session=cookie"
           (addHeader "csrf=cookie"
             (addHeader "transaction=expired"
-              (addHeader "/" NoContent)))))
+              (addHeader "/app" NoContent)))))
   :<|> (\_ _ -> counted
         (addHeader "session=expired"
           (addHeader "csrf=expired"
@@ -750,9 +774,10 @@ typedTestServer calls =
             , browseContinuation = Nothing
             , browsePartial = False
             }))
-  :<|> (\_ _ _ -> counted
+  :<|> (\_ _ _ _ -> counted
         (addHeader "attachment; filename=\"file.txt\""
-          (addHeader "nosniff" (addHeader 4 (source ["body"])))))
+          (addHeader "nosniff"
+            (addHeader "sandbox" (addHeader 4 (source ["body"]))))))
   :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
         { uploadResponseOperationId = operation
         , uploadResponseResult = MutationSucceeded
@@ -764,9 +789,47 @@ typedTestServer calls =
         , deleteResponseIdempotencyWindowSeconds = 3600
         })
   :<|> (\_ _ -> counted (DeletePrefixResponse 1))
+  :<|>
+    (    (\session -> counted SessionResponse
+            { sessionResponseUserId = suUserId (sessionUser session)
+            , sessionResponseDisplay = Nothing
+            , sessionResponseCsrf =
+                CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+            })
+    :<|> (\_ _ _ _ _ -> counted emptyBrowse)
+    :<|> (\_ _ _ _ -> counted downloadResponse)
+    :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
+          { uploadResponseOperationId = operation
+          , uploadResponseResult = MutationSucceeded
+          , uploadResponseIdempotencyWindowSeconds = 3600
+          })
+    :<|> (\_ request -> counted DeleteResponse
+          { deleteResponseOperationId = deleteOperationId request
+          , deleteResponseResult = MutationSucceeded
+          , deleteResponseIdempotencyWindowSeconds = 3600
+          })
+    :<|> (\_ _ _ _ -> counted DeletePlanResponse
+          { deletePlanPaths = []
+          , deletePlanContinuation = Nothing
+          })
+    :<|> (\_ _ -> counted (DeleteBatchResponse []))
+    )
   where
     counted :: a -> Handler a
     counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
+    emptyBrowse =
+      BrowseView
+        (HtmlPage "browse")
+        BrowseResponse
+          { browseEntries = []
+          , browseContinuation = Nothing
+          , browsePartial = False
+          }
+    downloadResponse =
+      addHeader "attachment; filename=\"file.txt\"" $
+        addHeader "nosniff" $
+          addHeader "sandbox" $
+            addHeader 4 (source ["body"])
 
 testAuthenticationBoundary :: IO ()
 testAuthenticationBoundary = do
@@ -780,6 +843,7 @@ testAuthenticationBoundary = do
         | (name, value) <- responseHeaders
         , name == "Set-Cookie"
         ]
+  lookup "Location" responseHeaders @?= Just "/app"
   length cookieHeaders @?= 3
   assertBool "login sets the session cookie"
     (any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
@@ -847,43 +911,18 @@ testAuthenticationBoundary = do
 
 testBrowserBridge :: IO ()
 testBrowserBridge = do
-  let csrf = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
-      user = SessionUser
-        { suIssuer = "issuer"
-        , suSubject = "subject"
-        , suUserId = UserId "user"
-        , suDisplay = Just "User"
-        }
-      entry = ListEntry
+  let entry = ListEntry
         { leName = "folder"
         , leIsPrefix = True
         , leSize = Nothing
-        , leRelativePath = "folder"
+        , leRelativePath = "folder<script>"
         }
-      browse = browsePage
-        user
-        Personal
-        ""
-        csrf
-        "upload-1"
-        ["delete-1"]
-        [entry]
-        Nothing
-        ""
-  mapM_
-    (\marker -> assertBool ("browse page includes " <> T.unpack marker)
-      (marker `T.isInfixOf` browse))
-    [ "data-nuthatch=\"upload\""
-    , "data-nuthatch=\"delete\""
-    , "data-nuthatch=\"logout\""
-    ]
-  mapM_
-    (\endpoint -> assertBool ("bridge calls " <> T.unpack endpoint)
-      (endpoint `T.isInfixOf` browserScript))
-    [ "/upload"
-    , "/delete-prefix"
-    , "/logout"
-    ]
+      browse = productPage [entry]
+  assertBool "legacy page directs browsers to the static application"
+    ("/app" `T.isInfixOf` browse && "/app" `T.isInfixOf` browserScript)
+  assertBool "legacy page escapes object paths"
+    ("folder&lt;script&gt;" `T.isInfixOf` browse
+      && not ("folder<script>" `T.isInfixOf` browse))
 
 productionAuthTestApplication :: Config -> IORef Int -> Application
 productionAuthTestApplication cfg calls =
@@ -928,7 +967,10 @@ testConfig = Config
   , cfgThrottleBytesPerSec = 1024
   , cfgThrottleBurstBytes = 1024
   , cfgListCacheTtlSec = 30
+  , cfgBrowsePageSize = 100
   , cfgSearchMaxKeys = 100
+  , cfgSearchTimeoutMs = 1000
+  , cfgDeletePageSize = 100
   , cfgRecoveryGraceSec = 30
   , cfgIdempotencyWindowSec = 3600
   , cfgObjectRequestTimeoutSec = 300