Generate the browser contract from ProductApi

test/WebContractIntegration.hs

@@ -0,0 +1,156 @@
+module Main (main) where
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import           Network.Wai (Request)
+import           Network.Wai.Handler.Warp (testWithApplication)
+import           Nuthatch.Api
+import           Nuthatch.Types
+import           Servant
+import           Servant.Server.Experimental.Auth
+  ( AuthHandler
+  , mkAuthHandler
+  )
+import           Servant.Types.SourceT (source)
+import           System.Process (callProcess)
+
+main :: IO ()
+main =
+  testWithApplication (pure application) $ \port ->
+    callProcess
+      "node"
+      [ "web/test/contract-integration.mjs"
+      , "http://127.0.0.1:" <> show port
+      ]
+
+application :: Application
+application =
+  serveWithContext
+    (Proxy :: Proxy ProductApi)
+    (authentication :. EmptyContext)
+    productServer
+
+authentication :: AuthHandler Request SessionContext
+authentication = mkAuthHandler $ \_ ->
+  pure SessionContext
+    { sessionUser = SessionUser
+        { suIssuer = "issuer"
+        , suSubject = "subject"
+        , suUserId = UserId "user-1"
+        , suDisplay = Just "User"
+        }
+    , sessionCsrf =
+        Just (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
+    }
+
+productServer :: Server ProductApi
+productServer =
+       sessionHandler
+  :<|> browseHandler
+  :<|> downloadHandler
+  :<|> uploadHandler
+  :<|> deleteHandler
+  :<|> deletePlanHandler
+  :<|> deleteBatchHandler
+
+sessionHandler :: SessionContext -> Handler SessionResponse
+sessionHandler session =
+  pure SessionResponse
+    { sessionResponseUserId = suUserId (sessionUser session)
+    , sessionResponseDisplay = suDisplay (sessionUser session)
+    , sessionResponseCsrf =
+        CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+    }
+
+browseHandler
+  :: SessionContext
+  -> Maybe Root
+  -> Maybe BrowsePrefix
+  -> Maybe SearchQuery
+  -> Maybe PaginationToken
+  -> Handler BrowseResponse
+browseHandler _ _ prefix query continuation =
+  pure BrowseResponse
+    { browseEntries =
+        [ EntryResponse
+            { entryResponseName = maybe "root" browsePrefixName prefix
+            , entryResponseIsPrefix = False
+            , entryResponseSize = Just 3
+            , entryResponsePath = maybe "root" browsePrefixName prefix
+            }
+        ]
+    , browseContinuation = continuation
+    , browsePartial = maybe False (const True) query
+    }
+  where
+    browsePrefixName (BrowsePrefix selected) =
+      maybe "" unRelativePath selected
+
+downloadHandler
+  :: SessionContext
+  -> Root
+  -> RelativePath
+  -> Maybe T.Text
+  -> Handler DownloadSuccess
+downloadHandler _ _ _ _ =
+  pure $
+    addHeader
+      "attachment; filename=\"file.txt\"" $
+      addHeader "nosniff" $
+        addHeader "default-src 'none'" $
+          addHeader 3 (source ["abc"])
+
+uploadHandler
+  :: SessionContext
+  -> Root
+  -> RelativePath
+  -> OperationId
+  -> DeclaredSize
+  -> ContentSha256
+  -> CsrfToken
+  -> SourceIO BS.ByteString
+  -> Handler UploadResponse
+uploadHandler _ _ _ operation _ _ _ _ =
+  pure UploadResponse
+    { uploadResponseOperationId = operation
+    , uploadResponseResult = MutationSucceeded
+    , uploadResponseIdempotencyWindowSeconds = 3600
+    }
+
+deleteHandler
+  :: SessionContext
+  -> DeleteRequest
+  -> Handler DeleteResponse
+deleteHandler _ request =
+  pure DeleteResponse
+    { deleteResponseOperationId = deleteOperationId request
+    , deleteResponseResult = MutationSucceeded
+    , deleteResponseIdempotencyWindowSeconds = 3600
+    }
+
+deletePlanHandler
+  :: SessionContext
+  -> Root
+  -> RelativePath
+  -> Maybe PaginationToken
+  -> Handler DeletePlanResponse
+deletePlanHandler _ _ path continuation =
+  pure DeletePlanResponse
+    { deletePlanPaths = [path]
+    , deletePlanContinuation = continuation
+    }
+
+deleteBatchHandler
+  :: SessionContext
+  -> DeleteBatchRequest
+  -> Handler DeleteBatchResponse
+deleteBatchHandler _ request =
+  pure $ DeleteBatchResponse
+    [ DeleteItemResponse
+        { deleteItemPath = deleteBatchPath item
+        , deleteItemOperationId = deleteBatchOperationId item
+        , deleteItemResult = Just MutationSucceeded
+        , deleteItemError = Nothing
+        }
+    | item <- deleteBatchItems request
+    ]