From 7b27c7eeb8c5bb0dc4cb1df0bec2e209b05cf5d9 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Thu, 16 Nov 2023 12:14:41 +1000 Subject: [PATCH 01/22] WPB-5382: Initial move over of code. Very broken in many ways --- integration/default.nix | 150 +----- integration/integration.cabal | 7 + integration/test/API/Cargohold.hs | 14 + integration/test/Test/Cargohold.hs | 16 + .../test/Test/Cargohold}/API.hs | 86 +--- .../test/Test/Cargohold}/API/Federation.hs | 101 ++-- .../test/Test/Cargohold}/API/Util.hs | 81 +-- .../test/Test/Cargohold}/API/V3.hs | 39 +- .../test/Test/Cargohold}/App.hs | 23 +- .../test/Test/Cargohold}/Metrics.hs | 28 +- libs/bilge/default.nix | 52 +- libs/brig-types/default.nix | 51 +- libs/cargohold-types/default.nix | 16 +- libs/cassandra-util/default.nix | 44 +- libs/deriving-swagger2/default.nix | 7 +- libs/dns-util/default.nix | 20 +- libs/extended/default.nix | 70 +-- libs/galley-types/default.nix | 57 +-- libs/gundeck-types/default.nix | 32 +- libs/hscim/default.nix | 123 +---- libs/http2-manager/default.nix | 48 +- libs/imports/default.nix | 32 +- libs/jwt-tools/default.nix | 18 +- libs/metrics-core/default.nix | 24 +- libs/metrics-wai/default.nix | 36 +- libs/polysemy-wire-zoo/default.nix | 57 +-- libs/ropes/default.nix | 28 +- libs/schema-profunctor/default.nix | 49 +- libs/sodium-crypto-sign/default.nix | 15 +- libs/ssl-util/default.nix | 20 +- libs/tasty-cannon/default.nix | 42 +- libs/types-common-aws/default.nix | 34 +- libs/types-common-journal/default.nix | 24 +- libs/types-common/default.nix | 134 +---- libs/wai-utilities/default.nix | 71 +-- libs/wire-api-federation/default.nix | 106 +--- libs/wire-api/default.nix | 294 ++--------- libs/wire-message-proto-lens/default.nix | 10 +- libs/zauth/default.nix | 70 +-- services/background-worker/default.nix | 103 +--- services/brig/default.nix | 472 +++--------------- services/cannon/default.nix | 114 +---- services/cargohold/cargohold.cabal | 101 ---- services/cargohold/default.nix | 184 +------ services/cargohold/test/integration/Main.hs | 83 --- .../cargohold/test/integration/TestSetup.hs | 216 -------- services/federator/default.nix | 225 ++------- services/galley/default.nix | 369 +++----------- services/gundeck/default.nix | 246 ++------- services/proxy/default.nix | 66 +-- services/spar/default.nix | 256 ++-------- tools/db/assets/default.nix | 31 +- tools/db/auto-whitelist/default.nix | 28 +- tools/db/find-undead/default.nix | 36 +- tools/db/inconsistencies/default.nix | 36 +- tools/db/migrate-sso-feature-flag/default.nix | 30 +- tools/db/move-team/default.nix | 67 +-- .../db/repair-brig-clients-table/default.nix | 24 +- tools/db/repair-handles/default.nix | 34 +- tools/db/service-backfill/default.nix | 28 +- tools/fedcalls/default.nix | 22 +- tools/mlsstats/default.nix | 50 +- tools/rabbitmq-consumer/default.nix | 32 +- tools/rex/default.nix | 46 +- tools/stern/default.nix | 137 +---- tools/test-stats/default.nix | 28 +- 66 files changed, 837 insertions(+), 4356 deletions(-) create mode 100644 integration/test/Test/Cargohold.hs rename {services/cargohold/test/integration => integration/test/Test/Cargohold}/API.hs (86%) rename {services/cargohold/test/integration => integration/test/Test/Cargohold}/API/Federation.hs (72%) rename {services/cargohold/test/integration => integration/test/Test/Cargohold}/API/Util.hs (69%) rename {services/cargohold/test/integration => integration/test/Test/Cargohold}/API/V3.hs (79%) rename {services/cargohold/test/integration => integration/test/Test/Cargohold}/App.hs (74%) rename {services/cargohold/test/integration => integration/test/Test/Cargohold}/Metrics.hs (61%) delete mode 100644 services/cargohold/test/integration/Main.hs delete mode 100644 services/cargohold/test/integration/TestSetup.hs diff --git a/integration/default.nix b/integration/default.nix index 15ef55849c..ed3d56148c 100644 --- a/integration/default.nix +++ b/integration/default.nix @@ -2,72 +2,18 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-pretty -, array -, async -, attoparsec -, base -, base64-bytestring -, bytestring -, bytestring-conversion -, Cabal -, case-insensitive -, containers -, cql -, cql-io -, cryptonite -, data-default -, data-timeout -, deriving-aeson -, directory -, errors -, exceptions -, extended -, extra -, filepath -, gitignoreSource -, hex -, http-client -, http-types -, kan-extensions -, lens -, lens-aeson -, lib -, memory -, mime -, monad-control -, mtl -, network -, network-uri -, optparse-applicative -, pem -, process -, proto-lens -, random -, raw-strings-qq -, regex-base -, regex-tdfa -, retry -, scientific -, split -, stm -, string-conversions -, tagged -, temporary -, text -, time -, transformers -, transformers-base -, unix -, unliftio -, uuid -, vector -, websockets -, wire-message-proto-lens -, xml -, yaml +{ mkDerivation, aeson, aeson-pretty, array, async, attoparsec, base +, base64-bytestring, bytestring, bytestring-conversion, Cabal +, case-insensitive, containers, cql, cql-io, cryptonite +, data-default, data-timeout, deriving-aeson, directory, errors +, exceptions, extended, extra, filepath, gitignoreSource, hex +, http-client, http-types, kan-extensions, lens, lens-aeson, lib +, memory, mime, monad-control, mtl, network, network-uri +, optparse-applicative, pem, process, proto-lens, random +, raw-strings-qq, regex-base, regex-tdfa, retry, scientific, split +, stm, string-conversions, tagged, temporary, text, time +, transformers, transformers-base, unix, unliftio, uuid, vector +, websockets, wire-message-proto-lens, xml, yaml }: mkDerivation { pname = "integration"; @@ -77,68 +23,16 @@ mkDerivation { isExecutable = true; setupHaskellDepends = [ base Cabal containers directory filepath ]; libraryHaskellDepends = [ - aeson - aeson-pretty - array - async - attoparsec - base - base64-bytestring - bytestring - bytestring-conversion - case-insensitive - containers - cql - cql-io - cryptonite - data-default - data-timeout - deriving-aeson - directory - errors - exceptions - extended - extra - filepath - hex - http-client - http-types - kan-extensions - lens - lens-aeson - memory - mime - monad-control - mtl - network - network-uri - optparse-applicative - pem - process - proto-lens - random - raw-strings-qq - regex-base - regex-tdfa - retry - scientific - split - stm - string-conversions - tagged - temporary - text - time - transformers - transformers-base - unix - unliftio - uuid - vector - websockets - wire-message-proto-lens - xml - yaml + aeson aeson-pretty array async attoparsec base base64-bytestring + bytestring bytestring-conversion case-insensitive containers cql + cql-io cryptonite data-default data-timeout deriving-aeson + directory errors exceptions extended extra filepath hex http-client + http-types kan-extensions lens lens-aeson memory mime monad-control + mtl network network-uri optparse-applicative pem process proto-lens + random raw-strings-qq regex-base regex-tdfa retry scientific split + stm string-conversions tagged temporary text time transformers + transformers-base unix unliftio uuid vector websockets + wire-message-proto-lens xml yaml ]; license = lib.licenses.agpl3Only; } diff --git a/integration/integration.cabal b/integration/integration.cabal index f28655943e..472fd1f18a 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -105,6 +105,13 @@ library Test.AssetUpload Test.B2B Test.Brig + Test.Cargohold + Test.Cargohold.API + Test.Cargohold.API.Federation + Test.Cargohold.API.Util + Test.Cargohold.API.V3 + Test.Cargohold.App + Test.Cargohold.Metrics Test.Client Test.Conversation Test.Demo diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index 5e08d84d79..2ff334bad3 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -11,9 +11,23 @@ import Data.Time.Clock import GHC.Stack import Network.HTTP.Client qualified as HTTP import Testlib.Prelude +import Wire.API.Asset (AssetRetention, assetRetentionSeconds) type LByteString = LBS.ByteString +uploadAssetV3 :: (HasCallStack, MakesValue user) => user -> Bool -> AssetRetention -> MIME.MIMEType -> LByteString -> App Response +uploadAssetV3 user isPublic retention mimeType bdy = do + uid <- user & objId + req <- baseRequest user Cargohold (ExplicitVersion 1) "/assets/v3" + submit "POST" $ req + & zUser uid + & addBody body multipartMixedMime + where + ret = assetRetentionSeconds retention + body = buildUploadAssetRequestBody isPublic ret bdy mimeType + multipartMixedMime :: String + multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary + uploadAsset :: (HasCallStack, MakesValue user) => user -> App Response uploadAsset user = do uid <- user & objId diff --git a/integration/test/Test/Cargohold.hs b/integration/test/Test/Cargohold.hs new file mode 100644 index 0000000000..78dfdaf26c --- /dev/null +++ b/integration/test/Test/Cargohold.hs @@ -0,0 +1,16 @@ +module Test.Cargohold where + +import API.Brig +import API.Brig qualified as API +import API.Gundeck +import Control.Lens hiding ((.=)) +import Control.Monad.Codensity +import Control.Monad.Reader +import Data.Aeson hiding ((.=)) +import Data.ProtoLens.Labels () +import Data.Time.Clock.POSIX +import Data.Time.Clock.System +import Data.Time.Format +import SetupHelpers +import Testlib.Prelude +import Testlib.ResourcePool \ No newline at end of file diff --git a/services/cargohold/test/integration/API.hs b/integration/test/Test/Cargohold/API.hs similarity index 86% rename from services/cargohold/test/integration/API.hs rename to integration/test/Test/Cargohold/API.hs index 47428f0ea3..c161f81aad 100644 --- a/services/cargohold/test/integration/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -17,15 +17,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API (tests) where +module Test.Cargohold.API where -import API.Util -import Bilge hiding (body) -import Bilge.Assert -import CargoHold.API.Error -import CargoHold.Options (aws, s3DownloadEndpoint) -import CargoHold.Types -import qualified CargoHold.Types.V3 as V3 import qualified Codec.MIME.Type as MIME import Control.Exception (throw) import Control.Lens hiding (sets, (.=)) @@ -33,60 +26,23 @@ import qualified Data.Aeson as Aeson import Data.ByteString.Builder import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion -import Data.Domain -import Data.Id -import Data.Qualified import qualified Data.Text.Encoding.Error as Text import qualified Data.Text.Lazy.Encoding as LText import Data.Time.Clock import Data.Time.Format import Data.UUID.V4 -import Federator.MockServer -import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) import qualified Network.HTTP.Client as HTTP -import Network.HTTP.Media ((//)) import qualified Network.HTTP.Types as HTTP -import Network.Wai.Utilities (Error (label)) -import qualified Network.Wai.Utilities.Error as Wai -import Test.Tasty -import Test.Tasty.HUnit -import TestSetup -import Util.Options -import Wire.API.Federation.API.Cargohold -import Wire.API.Federation.Component - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "API Integration" - [ testGroup - "simple" - [ test s "roundtrip" testSimpleRoundtrip, - test s "download with accept header" testDownloadWithAcceptHeader, - test s "tokens" testSimpleTokens, - test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, - test s "client-compatibility" testUploadCompatibility, - test s "download url override" testDownloadURLOverride - ], - testGroup - "remote" - [ test s "remote download wrong domain" testRemoteDownloadWrongDomain, - test s "remote download no asset" testRemoteDownloadNoAsset, - test s "federator failure on remote download" testRemoteDownloadFederationFailure, - test s "remote download" (testRemoteDownload "asset content"), - test s "large remote download" $ - testRemoteDownload - ( toLazyByteString - (mconcat (replicate 20000 (byteString "hello world\n"))) - ) - ] - ] +import Data.Vector.Internal.Check (HasCallStack) +import Testlib.Types +import qualified Wire.API.Asset as V3 +import Testlib.Prelude -------------------------------------------------------------------------------- -- Simple (single-step) uploads -testSimpleRoundtrip :: TestM () +testSimpleRoundtrip :: HasCallStack => App () testSimpleRoundtrip = do let def = V3.defAssetSettings let rets = [minBound ..] @@ -131,7 +87,7 @@ testSimpleRoundtrip = do let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime liftIO $ assertBool "bad date" (utc' >= utc) -testDownloadWithAcceptHeader :: TestM () +testDownloadWithAcceptHeader :: HasCallStack => App () testDownloadWithAcceptHeader = do assetId <- liftIO $ Id <$> nextRandom uid <- liftIO $ Id <$> nextRandom @@ -141,7 +97,7 @@ testDownloadWithAcceptHeader = do downloadAssetWith (header "Accept" "image/jpeg") uid qkey () !!! const 404 === statusCode -testSimpleTokens :: TestM () +testSimpleTokens :: HasCallStack => App () testSimpleTokens = do uid <- randomUser uid2 <- liftIO $ Id <$> nextRandom @@ -212,7 +168,7 @@ testSimpleTokens = do -- S3 closes idle connections after ~5 seconds, before the http-client 'Manager' -- does. If such a closed connection is reused for an upload, no problems should -- occur (i.e. the closed connection should be detected before sending any data). -testSimpleS3ClosedConnectionReuse :: TestM () +testSimpleS3ClosedConnectionReuse :: HasCallStack => App () testSimpleS3ClosedConnectionReuse = go >> wait >> go where wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 @@ -223,7 +179,7 @@ testSimpleS3ClosedConnectionReuse = go >> wait >> go uploadSimple (path "/assets/v3") uid sets part2 !!! const 201 === statusCode -testDownloadURLOverride :: TestM () +testDownloadURLOverride :: HasCallStack => App () testDownloadURLOverride = do -- This is a .example domain, it shouldn't resolve. But it is also not -- supposed to be used by cargohold to make connections. @@ -261,7 +217,7 @@ testDownloadURLOverride = do -- -- The body is taken directly from a request made by the web app -- (just replaced the content with a shorter one and updated the MD5 header). -testUploadCompatibility :: TestM () +testUploadCompatibility :: HasCallStack => App () testUploadCompatibility = do uid <- randomUser -- Initial upload @@ -281,8 +237,8 @@ testUploadCompatibility = do assertEqual "user mismatch" uid (decodeHeaderOrFail "x-amz-meta-user" r3) assertEqual "data mismatch" (Just "test") (responseBody r3) where - exampleMultipart :: LByteString - exampleMultipart = + exampleMultipart :: a + exampleMultipart = cs "--FrontierIyj6RcVrqMcxNtMEWPsNpuPm325QsvWQ\r\n\ \Content-Type: application/json;charset=utf-8\r\n\ \Content-length: 37\r\n\ @@ -300,7 +256,7 @@ testUploadCompatibility = do -------------------------------------------------------------------------------- -- Federation behaviour -testRemoteDownloadWrongDomain :: TestM () +testRemoteDownloadWrongDomain :: HasCallStack => App () testRemoteDownloadWrongDomain = do assetId <- liftIO $ Id <$> nextRandom uid <- liftIO $ Id <$> nextRandom @@ -310,7 +266,7 @@ testRemoteDownloadWrongDomain = do downloadAsset uid qkey () !!! do const 422 === statusCode -testRemoteDownloadNoAsset :: TestM () +testRemoteDownloadNoAsset :: HasCallStack => App () testRemoteDownloadNoAsset = do assetId <- liftIO $ Id <$> nextRandom uid <- liftIO $ Id <$> nextRandom @@ -340,7 +296,7 @@ testRemoteDownloadNoAsset = do } ] -testRemoteDownloadFederationFailure :: TestM () +testRemoteDownloadFederationFailure :: HasCallStack => App () testRemoteDownloadFederationFailure = do assetId <- liftIO $ Id <$> nextRandom uid <- liftIO $ Id <$> nextRandom @@ -359,8 +315,14 @@ testRemoteDownloadFederationFailure = do Wai.label resp @?= "mock-error" Wai.message resp @?= "mock error" -testRemoteDownload :: LByteString -> TestM () -testRemoteDownload assetContent = do +testRemoteDownloadShort :: HasCallStack => App () +testRemoteDownloadShort = remoteDownload "asset content" + +testRemoteDownloadLong :: HasCallStack => App () +testRemoteDownloadLong = remoteDownload $ toLazyByteString $ mconcat $ replicate 20000 $ byteString "hello world\n" + +remoteDownload :: HasCallStack => LByteString -> App () +remoteDownload assetContent = do assetId <- liftIO $ Id <$> nextRandom uid <- liftIO $ Id <$> nextRandom diff --git a/services/cargohold/test/integration/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs similarity index 72% rename from services/cargohold/test/integration/API/Federation.hs rename to integration/test/Test/Cargohold/API/Federation.hs index d7bf5c87cf..a693a50e42 100644 --- a/services/cargohold/test/integration/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -15,61 +15,41 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.Federation (tests) where +module Test.Cargohold.API.Federation where -import API.Util -import Bilge -import Bilge.Assert -import CargoHold.API.V3 (randToken) -import Conduit +import Test.Cargohold.API.Util import Control.Lens import Crypto.Random -import Data.Id -import Data.Qualified import Data.UUID.V4 -import Imports -import qualified Network.HTTP.Types as HTTP -import qualified Network.Wai.Utilities.Error as Wai -import Test.Tasty -import Test.Tasty.HUnit -import TestSetup -import Wire.API.Asset -import Wire.API.Federation.API -import Wire.API.Federation.API.Cargohold -import Wire.API.Routes.AssetBody - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "API Federation" - [ testGroup - "get-asset" - [ test s "private asset is available" (testGetAssetAvailable False), - test s "public asset is available" (testGetAssetAvailable True), - test s "not available" testGetAssetNotAvailable, - test s "wrong token" testGetAssetWrongToken - ], - testGroup - "stream-asset" - [ test s "streaming large asset" testLargeAsset, - test s "stream an asset" testStreamAsset, - test s "stream asset not available" testStreamAssetNotAvailable, - test s "stream asset wrong token" testStreamAssetWrongToken - ] - ] - -testGetAssetAvailable :: Bool -> TestM () -testGetAssetAvailable isPublicAsset = do - -- Initial upload - let bdy = (applicationOctetStream, "Hello World") - settings = - defAssetSettings - & set setAssetRetention (Just AssetVolatile) - & set setAssetPublic isPublicAsset +import API.Brig qualified as BrigP +import API.BrigInternal qualified as BrigI +import API.Common qualified as API +import API.GalleyInternal qualified as GalleyI +import Control.Concurrent (threadDelay) +import Data.Aeson.Types hiding ((.=)) +import Data.Set qualified as Set +import Data.String.Conversions +import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUID +import GHC.Stack +import SetupHelpers +import Testlib.Assertions +import Testlib.Prelude +import Data.Vector.Internal.Check (HasCallStack) +import Wire.API.Asset (AssetRetention(AssetVolatile)) + +testGetAssetAvailablePrivate :: HasCallStack => App () +testGetAssetAvailablePrivate = getAssetAvailable False + +testGetAssetAvailablePublic :: HasCallStack => App () +testGetAssetAvailablePublic = getAssetAvailable True + +getAssetAvailable :: Bool -> App () +getAssetAvailable isPublicAsset = do uid <- randomUser ast :: Asset <- responseJsonError - =<< uploadSimple (path "/assets/v3") uid settings bdy + =<< uploadAssetV3 uid isPublicAsset (Just AssetVolatile) applicationOctetStream bdy App () testGetAssetNotAvailable = do uid <- liftIO $ Id <$> nextRandom token <- randToken @@ -108,7 +88,7 @@ testGetAssetNotAvailable = do -- check that asset is not available liftIO $ ok @?= False -testGetAssetWrongToken :: TestM () +testGetAssetWrongToken :: HasCallStack => App () testGetAssetWrongToken = do -- Initial upload let bdy = (applicationOctetStream, "Hello World") @@ -130,18 +110,9 @@ testGetAssetWrongToken = do } ok <- withFederationClient $ - available <$> runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) - - -- check that asset is not available - liftIO $ ok @?= False - -testLargeAsset :: TestM () -testLargeAsset = do - -- Initial upload - let settings = - defAssetSettings - & set setAssetRetention (Just AssetVolatile) - uid <- randomUser + available +type TestM = ReaderT TestSetup Http +User -- generate random bytes let size = 1024 * 1024 bs <- liftIO $ getRandomBytes size @@ -170,7 +141,7 @@ testLargeAsset = do (length chunks > minNumChunks) mconcat chunks @?= bs -testStreamAsset :: TestM () +testStreamAsset :: HasCallStack => App () testStreamAsset = do -- Initial upload let bdy = (applicationOctetStream, "Hello World") @@ -197,7 +168,7 @@ testStreamAsset = do liftIO . runResourceT $ connect source sinkLazy liftIO $ respBody @?= "Hello World" -testStreamAssetNotAvailable :: TestM () +testStreamAssetNotAvailable :: HasCallStack => App () testStreamAssetNotAvailable = do uid <- liftIO $ Id <$> nextRandom token <- randToken @@ -216,7 +187,7 @@ testStreamAssetNotAvailable = do Wai.code err @?= HTTP.notFound404 Wai.label err @?= "not-found" -testStreamAssetWrongToken :: TestM () +testStreamAssetWrongToken :: HasCallStack => App () testStreamAssetWrongToken = do -- Initial upload let bdy = (applicationOctetStream, "Hello World") diff --git a/services/cargohold/test/integration/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs similarity index 69% rename from services/cargohold/test/integration/API/Util.hs rename to integration/test/Test/Cargohold/API/Util.hs index 59ea794f59..29561f6cc5 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -15,12 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.Util where +module Test.Cargohold.API.Util where -import Bilge hiding (body, host, port) -import qualified Bilge -import CargoHold.Options -import CargoHold.Run import qualified Codec.MIME.Parse as MIME import qualified Codec.MIME.Type as MIME import Control.Lens hiding ((.=)) @@ -30,56 +26,19 @@ import Data.ByteString.Builder import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy -import Data.Domain -import Data.Id -import Data.Qualified import Data.Text.Encoding (decodeLatin1, encodeUtf8) import qualified Data.UUID as UUID import Data.UUID.V4 (nextRandom) -import Federator.MockServer -import Imports hiding (head) -import qualified Network.HTTP.Media as HTTP import Network.HTTP.Types.Header import Network.HTTP.Types.Method -import Network.Wai.Utilities.MockServer -import Safe (readNote) -import TestSetup -import Util.Options -import Wire.API.Asset - --- Copied wholesale from gundeck/test/integration/API.hs --- This is needed because it sets up the email on the user, verifiying it. --- The changes to the asset routes forbidding non-verified users from uploading --- assets breaks a lot of existing tests. --- --- FUTUREWORK: Move all the cargohold tests to the new integration test suite. --- https://wearezeta.atlassian.net/browse/WPB-5382 -randomUser :: TestM UserId -randomUser = do - (Endpoint (encodeUtf8 -> eHost) ePort) <- view tsBrig - e <- liftIO $ mkEmail "success" "simulator.amazonses.com" - let p = - object - [ "name" .= e, - "email" .= e, - "password" .= ("secret-8-chars-long-at-least" :: Text) - ] - r <- post (Bilge.host eHost . Bilge.port ePort . path "/i/users" . json p) - pure - . readNote "unable to parse Location header" - . C.unpack - $ getHeader' "Location" r - where - mkEmail loc dom = do - uid <- nextRandom - pure $ loc <> "+" <> UUID.toText uid <> "@" <> dom - -uploadSimple :: +import Testlib.Prelude + +uploadSimple :: HasCallStack => (Request -> Request) -> UserId -> AssetSettings -> (MIME.Type, ByteString) -> - TestM (Response (Maybe Lazy.ByteString)) + App (Response (Maybe Lazy.ByteString)) uploadSimple c usr sts (ct, bs) = let mp = buildMultipartBody sts ct (Lazy.fromStrict bs) in uploadRaw c usr (toLazyByteString mp) @@ -90,11 +49,11 @@ decodeHeaderOrFail h = . fromByteString . getHeader' h -uploadRaw :: +uploadRaw :: HasCallStack => (Request -> Request) -> UserId -> Lazy.ByteString -> - TestM (Response (Maybe Lazy.ByteString)) + App (Response (Maybe Lazy.ByteString)) uploadRaw c usr bs = do cargohold' <- viewUnversionedCargohold post $ @@ -122,12 +81,12 @@ zUser = header "Z-User" . UUID.toASCIIBytes . toUUID zConn :: ByteString -> Request -> Request zConn = header "Z-Connection" -deleteAssetV3 :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) +deleteAssetV3 :: HasCallStack => UserId -> Qualified AssetKey -> App (Response (Maybe Lazy.ByteString)) deleteAssetV3 u k = do c <- viewUnversionedCargohold delete $ apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] -deleteAsset :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) +deleteAsset :: HasCallStack => UserId -> Qualified AssetKey -> App (Response (Maybe Lazy.ByteString)) deleteAsset u k = do c <- viewCargohold delete $ @@ -168,12 +127,12 @@ instance IsAssetToken (Request -> Request) where tokenParam = id downloadAssetWith :: - (IsAssetLocation loc, IsAssetToken tok) => + (HasCallStack, IsAssetLocation loc, IsAssetToken tok) => (Request -> Request) -> UserId -> loc -> tok -> - TestM (Response (Maybe LByteString)) + App (Response (Maybe LByteString)) downloadAssetWith r uid loc tok = do c <- viewUnversionedCargohold get $ @@ -185,14 +144,14 @@ downloadAssetWith r uid loc tok = do . noRedirect downloadAsset :: - (IsAssetLocation loc, IsAssetToken tok) => + (HasCallStack, IsAssetLocation loc, IsAssetToken tok) => UserId -> loc -> tok -> - TestM (Response (Maybe LByteString)) + App (Response (Maybe LByteString)) downloadAsset = downloadAssetWith id -postToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) +postToken :: HasCallStack => UserId -> AssetKey -> App (Response (Maybe LByteString)) postToken uid key = do c <- viewCargohold post $ @@ -200,7 +159,7 @@ postToken uid key = do . zUser uid . paths ["assets", toByteString' key, "token"] -deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) +deleteToken :: HasCallStack => UserId -> AssetKey -> App`` (Response (Maybe LByteString)) deleteToken uid key = do c <- viewCargohold delete $ @@ -208,13 +167,13 @@ deleteToken uid key = do . zUser uid . paths ["assets", toByteString' key, "token"] -viewFederationDomain :: TestM Domain +viewFederationDomain :: HasCallStack => App Domain viewFederationDomain = view (tsOpts . settings . federationDomain) -------------------------------------------------------------------------------- -- Mocking utilities -withSettingsOverrides :: (Opts -> Opts) -> TestM a -> TestM a +withSettingsOverrides :: HasCallStack => (Opts -> Opts) -> App a -> App a withSettingsOverrides f action = do ts <- ask let opts = f (view tsOpts ts) @@ -226,10 +185,10 @@ withSettingsOverrides f action = do setLocalEndpoint :: Word16 -> Endpoint -> Endpoint setLocalEndpoint p = (port .~ p) . (host .~ "127.0.0.1") -withMockFederator :: +withMockFederator :: HasCallStack => (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> - TestM a -> - TestM (a, [FederatedRequest]) + App a -> + App (a, [FederatedRequest]) withMockFederator respond action = do withTempMockFederator [] respond $ \p -> withSettingsOverrides diff --git a/services/cargohold/test/integration/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs similarity index 79% rename from services/cargohold/test/integration/API/V3.hs rename to integration/test/Test/Cargohold/API/V3.hs index 5560905f92..c217dc6fa6 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -17,39 +17,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.V3 (tests) where +module Test.Cargohold.API.V3 where -import API.Util -import Bilge hiding (body) -import Bilge.Assert import Control.Lens hiding (sets) import qualified Data.ByteString.Char8 as C8 -import Data.Id -import Data.Qualified import Data.Time.Clock import Data.Time.Format import Data.UUID.V4 -import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Types.Status (status200) -import Test.Tasty -import Test.Tasty.HUnit -import TestSetup -import Wire.API.Asset - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "API Integration v3" - [ testGroup - "simple" - [test s "roundtrip using v3 API" testSimpleRoundtrip] - ] +import Testlib.Types +import Testlib.Prelude -------------------------------------------------------------------------------- -- Simple (single-step) uploads -testSimpleRoundtrip :: TestM () +testSimpleRoundtrip :: HasCallStack => App () testSimpleRoundtrip = do let def = defAssetSettings let rets = [minBound ..] @@ -65,15 +48,17 @@ testSimpleRoundtrip = do uploadSimple (path "/assets/v3") uid sets bdy r1.json %. "key" + <*> r1.json %. "token" + <*> r1.json %. "expires" + let key = qUnqualified qKey -- Check mandatory Date header let Just date = C8.unpack <$> lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime -- Potentially check for the expires header when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do - liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) + liftIO $ assertBool "invalid expiration" (Just utc < expires) -- Lookup with token and download via redirect. r2 <- downloadAsset uid key (Just tok) TestTree -tests s = - testGroup - "Configuration sanity checks" - [ test s "multiIngress and cloudFront cannot be combined" testMultiIngressCloudFrontFails, - test s "multiIngress and s3DownloadEndpoint cannot be combined" testMultiIngressS3DownloadEndpointFails - ] - -testMultiIngressCloudFrontFails :: TestM () +testMultiIngressCloudFrontFails :: HasCallStack => App () testMultiIngressCloudFrontFails = do ts <- ask let opts = @@ -58,7 +43,7 @@ multiIngressMap = toAWSEndpoint :: ByteString -> AWSEndpoint toAWSEndpoint = fromJust . fromByteString -testMultiIngressS3DownloadEndpointFails :: TestM () +testMultiIngressS3DownloadEndpointFails :: HasCallStack => App () testMultiIngressS3DownloadEndpointFails = do ts <- ask let opts = diff --git a/services/cargohold/test/integration/Metrics.hs b/integration/test/Test/Cargohold/Metrics.hs similarity index 61% rename from services/cargohold/test/integration/Metrics.hs rename to integration/test/Test/Cargohold/Metrics.hs index 0ffbeeab63..6689b62c0a 100644 --- a/services/cargohold/test/integration/Metrics.hs +++ b/integration/test/Test/Cargohold/Metrics.hs @@ -15,24 +15,14 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Metrics - ( tests, - ) -where +module Test.Cargohold.Metrics where +import Testlib.Prelude +import Data.String.Conversions -import Bilge -import Bilge.Assert -import Imports -import Test.Tasty -import TestSetup - -tests :: IO TestSetup -> TestTree -tests s = testGroup "Metrics" [test s "prometheus" testPrometheusMetrics] - -testPrometheusMetrics :: TestM () +testPrometheusMetrics :: HasCallStack => App () testPrometheusMetrics = do - cargohold <- viewUnversionedCargohold - get (cargohold . path "/i/metrics") !!! do - const 200 === statusCode - -- Should contain the request duration metric in its output - const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody + req <- baseRequest OwnDomain Cargohold Unversioned "i/metrics" + resp <- submit "GET" req + withResponse resp $ \r -> do + r.status `shouldMatchInt` 200 + cs r.body `shouldContainString` "TYPE http_request_duration_seconds histogram" diff --git a/libs/bilge/default.nix b/libs/bilge/default.nix index 8c35f0746a..9cf336bd12 100644 --- a/libs/bilge/default.nix +++ b/libs/bilge/default.nix @@ -2,56 +2,20 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, ansi-terminal -, base -, bytestring -, case-insensitive -, cookie -, errors -, exceptions -, gitignoreSource -, http-client -, http-types -, imports -, lens -, lib -, monad-control -, mtl -, text -, tinylog -, transformers-base -, types-common -, uri-bytestring -, wai -, wai-extra +{ mkDerivation, aeson, ansi-terminal, base, bytestring +, case-insensitive, cookie, errors, exceptions, gitignoreSource +, http-client, http-types, imports, lens, lib, monad-control, mtl +, text, tinylog, transformers-base, types-common, uri-bytestring +, wai, wai-extra }: mkDerivation { pname = "bilge"; version = "0.22.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - ansi-terminal - base - bytestring - case-insensitive - cookie - errors - exceptions - http-client - http-types - imports - lens - monad-control - mtl - text - tinylog - transformers-base - types-common - uri-bytestring - wai + aeson ansi-terminal base bytestring case-insensitive cookie errors + exceptions http-client http-types imports lens monad-control mtl + text tinylog transformers-base types-common uri-bytestring wai wai-extra ]; description = "Library for composing HTTP requests"; diff --git a/libs/brig-types/default.nix b/libs/brig-types/default.nix index 173b83591b..2a0b9daac6 100644 --- a/libs/brig-types/default.nix +++ b/libs/brig-types/default.nix @@ -2,25 +2,10 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, attoparsec -, base -, bytestring -, bytestring-conversion -, cassandra-util -, containers -, gitignoreSource -, imports -, lib -, openapi3 -, QuickCheck -, tasty -, tasty-hunit -, tasty-quickcheck -, text -, tinylog -, types-common +{ mkDerivation, aeson, attoparsec, base, bytestring +, bytestring-conversion, cassandra-util, containers +, gitignoreSource, imports, lib, openapi3, QuickCheck, tasty +, tasty-hunit, tasty-quickcheck, text, tinylog, types-common , wire-api }: mkDerivation { @@ -28,31 +13,13 @@ mkDerivation { version = "1.35.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - attoparsec - base - bytestring - bytestring-conversion - cassandra-util - containers - imports - QuickCheck - text - tinylog - types-common - wire-api + aeson attoparsec base bytestring bytestring-conversion + cassandra-util containers imports QuickCheck text tinylog + types-common wire-api ]; testHaskellDepends = [ - aeson - base - bytestring-conversion - imports - openapi3 - QuickCheck - tasty - tasty-hunit - tasty-quickcheck - wire-api + aeson base bytestring-conversion imports openapi3 QuickCheck tasty + tasty-hunit tasty-quickcheck wire-api ]; description = "User Service"; license = lib.licenses.agpl3Only; diff --git a/libs/cargohold-types/default.nix b/libs/cargohold-types/default.nix index 6415170a56..523e4eab3a 100644 --- a/libs/cargohold-types/default.nix +++ b/libs/cargohold-types/default.nix @@ -2,25 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, bytestring-conversion -, gitignoreSource -, imports -, lib -, types-common -, wire-api +{ mkDerivation, base, bytestring-conversion, gitignoreSource +, imports, lib, types-common, wire-api }: mkDerivation { pname = "cargohold-types"; version = "1.5.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - bytestring-conversion - imports - types-common - wire-api + base bytestring-conversion imports types-common wire-api ]; description = "Asset Storage API Types"; license = lib.licenses.agpl3Only; diff --git a/libs/cassandra-util/default.nix b/libs/cassandra-util/default.nix index 5e634fad61..dbbd852837 100644 --- a/libs/cassandra-util/default.nix +++ b/libs/cassandra-util/default.nix @@ -2,26 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, conduit -, cql -, cql-io -, cql-io-tinylog -, exceptions -, gitignoreSource -, imports -, lens -, lens-aeson -, lib -, optparse-applicative -, retry -, split -, text -, time -, tinylog -, uuid +{ mkDerivation, aeson, base, conduit, cql, cql-io, cql-io-tinylog +, exceptions, gitignoreSource, imports, lens, lens-aeson, lib +, optparse-applicative, retry, split, text, time, tinylog, uuid , wreq }: mkDerivation { @@ -29,24 +12,9 @@ mkDerivation { version = "0.16.5"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - base - conduit - cql - cql-io - cql-io-tinylog - exceptions - imports - lens - lens-aeson - optparse-applicative - retry - split - text - time - tinylog - uuid - wreq + aeson base conduit cql cql-io cql-io-tinylog exceptions imports + lens lens-aeson optparse-applicative retry split text time tinylog + uuid wreq ]; description = "Cassandra Utilities"; license = lib.licenses.agpl3Only; diff --git a/libs/deriving-swagger2/default.nix b/libs/deriving-swagger2/default.nix index 5359dbec57..4b1f5f8c3c 100644 --- a/libs/deriving-swagger2/default.nix +++ b/libs/deriving-swagger2/default.nix @@ -2,12 +2,7 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, extra -, gitignoreSource -, imports -, lib +{ mkDerivation, base, extra, gitignoreSource, imports, lib , openapi3 }: mkDerivation { diff --git a/libs/dns-util/default.nix b/libs/dns-util/default.nix index 47548fb34e..2a1db8c6bc 100644 --- a/libs/dns-util/default.nix +++ b/libs/dns-util/default.nix @@ -2,29 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, dns -, gitignoreSource -, hspec -, hspec-discover -, imports -, iproute -, lib -, polysemy -, random +{ mkDerivation, base, dns, gitignoreSource, hspec, hspec-discover +, imports, iproute, lib, polysemy, random }: mkDerivation { pname = "dns-util"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - dns - imports - iproute - polysemy - random + base dns imports iproute polysemy random ]; testHaskellDepends = [ base dns hspec imports ]; testToolDepends = [ hspec-discover ]; diff --git a/libs/extended/default.nix b/libs/extended/default.nix index b44a955a35..3272f13f33 100644 --- a/libs/extended/default.nix +++ b/libs/extended/default.nix @@ -2,70 +2,24 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, amqp -, base -, bytestring -, cassandra-util -, containers -, errors -, exceptions -, extra -, gitignoreSource -, hspec -, hspec-discover -, http-client -, http-types -, imports -, lib -, metrics-wai -, monad-control -, optparse-applicative -, resourcet -, retry -, servant -, servant-client -, servant-client-core -, servant-openapi3 -, servant-server -, temporary -, text -, tinylog -, unliftio -, wai +{ mkDerivation, aeson, amqp, base, bytestring, cassandra-util +, containers, errors, exceptions, extra, gitignoreSource, hspec +, hspec-discover, http-client, http-types, imports, lib +, metrics-wai, monad-control, optparse-applicative, resourcet +, retry, servant, servant-client, servant-client-core +, servant-openapi3, servant-server, temporary, text, tinylog +, unliftio, wai }: mkDerivation { pname = "extended"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - amqp - base - bytestring - cassandra-util - containers - errors - exceptions - extra - http-client - http-types - imports - metrics-wai - monad-control - optparse-applicative - resourcet - retry - servant - servant-client - servant-client-core - servant-openapi3 - servant-server - text - tinylog - unliftio - wai + aeson amqp base bytestring cassandra-util containers errors + exceptions extra http-client http-types imports metrics-wai + monad-control optparse-applicative resourcet retry servant + servant-client servant-client-core servant-openapi3 servant-server + text tinylog unliftio wai ]; testHaskellDepends = [ aeson base hspec imports temporary ]; testToolDepends = [ hspec-discover ]; diff --git a/libs/galley-types/default.nix b/libs/galley-types/default.nix index 5b51cac80f..30b79c9035 100644 --- a/libs/galley-types/default.nix +++ b/libs/galley-types/default.nix @@ -2,62 +2,23 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bytestring -, bytestring-conversion -, containers -, cryptonite -, errors -, gitignoreSource -, imports -, lens -, lib -, memory -, QuickCheck -, schema-profunctor -, tasty -, tasty-hunit -, tasty-quickcheck -, text -, types-common -, uuid -, wire-api +{ mkDerivation, aeson, base, bytestring, bytestring-conversion +, containers, cryptonite, errors, gitignoreSource, imports, lens +, lib, memory, QuickCheck, schema-profunctor, tasty, tasty-hunit +, tasty-quickcheck, text, types-common, uuid, wire-api }: mkDerivation { pname = "galley-types"; version = "0.81.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - base - bytestring - bytestring-conversion - containers - cryptonite - errors - imports - lens - memory - QuickCheck - schema-profunctor - text - types-common - uuid - wire-api + aeson base bytestring bytestring-conversion containers cryptonite + errors imports lens memory QuickCheck schema-profunctor text + types-common uuid wire-api ]; testHaskellDepends = [ - aeson - base - containers - imports - lens - QuickCheck - tasty - tasty-hunit - tasty-quickcheck - wire-api + aeson base containers imports lens QuickCheck tasty tasty-hunit + tasty-quickcheck wire-api ]; license = lib.licenses.agpl3Only; } diff --git a/libs/gundeck-types/default.nix b/libs/gundeck-types/default.nix index 522b4e84b1..d4d49a77fa 100644 --- a/libs/gundeck-types/default.nix +++ b/libs/gundeck-types/default.nix @@ -2,39 +2,17 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, attoparsec -, base -, bytestring -, bytestring-conversion -, containers -, gitignoreSource -, imports -, lens -, lib -, network-uri -, text -, types-common -, wire-api +{ mkDerivation, aeson, attoparsec, base, bytestring +, bytestring-conversion, containers, gitignoreSource, imports, lens +, lib, network-uri, text, types-common, wire-api }: mkDerivation { pname = "gundeck-types"; version = "1.45.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - attoparsec - base - bytestring - bytestring-conversion - containers - imports - lens - network-uri - text - types-common - wire-api + aeson attoparsec base bytestring bytestring-conversion containers + imports lens network-uri text types-common wire-api ]; license = lib.licenses.agpl3Only; } diff --git a/libs/hscim/default.nix b/libs/hscim/default.nix index 175f532a31..7f522f2db7 100644 --- a/libs/hscim/default.nix +++ b/libs/hscim/default.nix @@ -2,48 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-qq -, attoparsec -, base -, bytestring -, case-insensitive -, email-validate -, gitignoreSource -, hashable -, hedgehog -, hspec -, hspec-discover -, hspec-expectations -, hspec-wai -, http-api-data -, http-media -, http-types -, hw-hspec-hedgehog -, indexed-traversable -, lib -, list-t -, microlens -, mmorph -, mtl -, network-uri -, retry -, scientific -, servant -, servant-client -, servant-client-core -, servant-server -, stm -, stm-containers -, string-conversions -, template-haskell -, text -, time -, uuid -, wai -, wai-extra -, warp +{ mkDerivation, aeson, aeson-qq, attoparsec, base, bytestring +, case-insensitive, email-validate, gitignoreSource, hashable +, hedgehog, hspec, hspec-discover, hspec-expectations, hspec-wai +, http-api-data, http-media, http-types, hw-hspec-hedgehog +, indexed-traversable, lib, list-t, microlens, mmorph, mtl +, network-uri, retry, scientific, servant, servant-client +, servant-client-core, servant-server, stm, stm-containers +, string-conversions, template-haskell, text, time, uuid, wai +, wai-extra, warp }: mkDerivation { pname = "hscim"; @@ -52,71 +19,21 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - aeson-qq - attoparsec - base - bytestring - case-insensitive - email-validate - hashable - hspec - hspec-expectations - hspec-wai - http-api-data - http-media - http-types - list-t - microlens - mmorph - mtl - network-uri - retry - scientific - servant - servant-client - servant-client-core - servant-server - stm - stm-containers - string-conversions - template-haskell - text - time - uuid - wai - wai-extra + aeson aeson-qq attoparsec base bytestring case-insensitive + email-validate hashable hspec hspec-expectations hspec-wai + http-api-data http-media http-types list-t microlens mmorph mtl + network-uri retry scientific servant servant-client + servant-client-core servant-server stm stm-containers + string-conversions template-haskell text time uuid wai wai-extra ]; executableHaskellDepends = [ - base - email-validate - network-uri - stm - stm-containers - time - warp + base email-validate network-uri stm stm-containers time warp ]; testHaskellDepends = [ - aeson - attoparsec - base - bytestring - email-validate - hedgehog - hspec - hspec-expectations - hspec-wai - http-types - hw-hspec-hedgehog - indexed-traversable - microlens - network-uri - servant - servant-server - stm-containers - text - wai - wai-extra + aeson attoparsec base bytestring email-validate hedgehog hspec + hspec-expectations hspec-wai http-types hw-hspec-hedgehog + indexed-traversable microlens network-uri servant servant-server + stm-containers text wai wai-extra ]; testToolDepends = [ hspec-discover ]; homepage = "https://github.com/wireapp/wire-server/libs/hscim/README.md"; diff --git a/libs/http2-manager/default.nix b/libs/http2-manager/default.nix index 782b3605f1..6393213267 100644 --- a/libs/http2-manager/default.nix +++ b/libs/http2-manager/default.nix @@ -2,23 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, async -, base -, bytestring -, containers -, gitignoreSource -, HsOpenSSL -, hspec -, hspec-discover -, http-types -, http2 -, lib -, network -, random -, stm -, streaming-commons -, text +{ mkDerivation, async, base, bytestring, containers +, gitignoreSource, HsOpenSSL, hspec, hspec-discover, http-types +, http2, lib, network, random, stm, streaming-commons, text , time-manager }: mkDerivation { @@ -26,32 +12,12 @@ mkDerivation { version = "0.0.1"; src = gitignoreSource ./.; libraryHaskellDepends = [ - async - base - bytestring - containers - HsOpenSSL - http2 - network - stm - streaming-commons - text - time-manager + async base bytestring containers HsOpenSSL http2 network stm + streaming-commons text time-manager ]; testHaskellDepends = [ - async - base - bytestring - containers - HsOpenSSL - hspec - http-types - http2 - network - random - stm - streaming-commons - time-manager + async base bytestring containers HsOpenSSL hspec http-types http2 + network random stm streaming-commons time-manager ]; testToolDepends = [ hspec-discover ]; description = "Managed connection pool for HTTP2"; diff --git a/libs/imports/default.nix b/libs/imports/default.nix index b1b77f2c86..8183ebc1c1 100644 --- a/libs/imports/default.nix +++ b/libs/imports/default.nix @@ -2,39 +2,17 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, bytestring -, containers -, deepseq -, extra -, gitignoreSource -, lib -, mtl -, string-conversions -, text -, transformers -, unliftio -, unliftio-core -, unordered-containers +{ mkDerivation, base, bytestring, containers, deepseq, extra +, gitignoreSource, lib, mtl, string-conversions, text, transformers +, unliftio, unliftio-core, unordered-containers }: mkDerivation { pname = "imports"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - bytestring - containers - deepseq - extra - mtl - string-conversions - text - transformers - unliftio - unliftio-core - unordered-containers + base bytestring containers deepseq extra mtl string-conversions + text transformers unliftio unliftio-core unordered-containers ]; description = "Very common imports"; license = lib.licenses.agpl3Only; diff --git a/libs/jwt-tools/default.nix b/libs/jwt-tools/default.nix index 58d7084889..cca3dd2e94 100644 --- a/libs/jwt-tools/default.nix +++ b/libs/jwt-tools/default.nix @@ -2,27 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, bytestring-conversion -, gitignoreSource -, hspec -, http-types -, imports -, lib -, rusty_jwt_tools_ffi -, transformers +{ mkDerivation, base, bytestring-conversion, gitignoreSource, hspec +, http-types, imports, lib, rusty_jwt_tools_ffi, transformers }: mkDerivation { pname = "jwt-tools"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - bytestring-conversion - http-types - imports - transformers + base bytestring-conversion http-types imports transformers ]; librarySystemDepends = [ rusty_jwt_tools_ffi ]; testHaskellDepends = [ hspec imports transformers ]; diff --git a/libs/metrics-core/default.nix b/libs/metrics-core/default.nix index f3eab69051..eb21ca9b1e 100644 --- a/libs/metrics-core/default.nix +++ b/libs/metrics-core/default.nix @@ -2,17 +2,8 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, containers -, gitignoreSource -, hashable -, immortal -, imports -, lib -, prometheus-client -, text -, time +{ mkDerivation, base, containers, gitignoreSource, hashable +, immortal, imports, lib, prometheus-client, text, time , unordered-containers }: mkDerivation { @@ -20,15 +11,8 @@ mkDerivation { version = "0.3.2"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - containers - hashable - immortal - imports - prometheus-client - text - time - unordered-containers + base containers hashable immortal imports prometheus-client text + time unordered-containers ]; description = "Metrics core"; license = lib.licenses.agpl3Only; diff --git a/libs/metrics-wai/default.nix b/libs/metrics-wai/default.nix index 616c581b7f..58f832d56c 100644 --- a/libs/metrics-wai/default.nix +++ b/libs/metrics-wai/default.nix @@ -2,42 +2,18 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, bytestring -, containers -, gitignoreSource -, hspec -, hspec-discover -, http-types -, imports -, lib -, metrics-core -, servant -, servant-multipart -, text -, wai -, wai-middleware-prometheus -, wai-route -, wai-routing +{ mkDerivation, base, bytestring, containers, gitignoreSource +, hspec, hspec-discover, http-types, imports, lib, metrics-core +, servant, servant-multipart, text, wai, wai-middleware-prometheus +, wai-route, wai-routing }: mkDerivation { pname = "metrics-wai"; version = "0.5.7"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - bytestring - containers - http-types - imports - metrics-core - servant - servant-multipart - text - wai - wai-middleware-prometheus - wai-route + base bytestring containers http-types imports metrics-core servant + servant-multipart text wai wai-middleware-prometheus wai-route wai-routing ]; testHaskellDepends = [ base containers hspec imports ]; diff --git a/libs/polysemy-wire-zoo/default.nix b/libs/polysemy-wire-zoo/default.nix index e5a88e3be1..2d79a5cb6f 100644 --- a/libs/polysemy-wire-zoo/default.nix +++ b/libs/polysemy-wire-zoo/default.nix @@ -2,29 +2,10 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bytestring -, cassandra-util -, containers -, gitignoreSource -, HsOpenSSL -, hspec -, hspec-discover -, imports -, jose -, lib -, polysemy -, polysemy-check -, polysemy-plugin -, QuickCheck -, saml2-web-sso -, time -, tinylog -, types-common -, unliftio -, uuid +{ mkDerivation, aeson, base, bytestring, cassandra-util, containers +, gitignoreSource, HsOpenSSL, hspec, hspec-discover, imports, jose +, lib, polysemy, polysemy-check, polysemy-plugin, QuickCheck +, saml2-web-sso, time, tinylog, types-common, unliftio, uuid , wire-api }: mkDerivation { @@ -32,34 +13,12 @@ mkDerivation { version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - base - bytestring - cassandra-util - HsOpenSSL - hspec - imports - jose - polysemy - polysemy-check - polysemy-plugin - QuickCheck - saml2-web-sso - time - tinylog - types-common - unliftio - uuid - wire-api + aeson base bytestring cassandra-util HsOpenSSL hspec imports jose + polysemy polysemy-check polysemy-plugin QuickCheck saml2-web-sso + time tinylog types-common unliftio uuid wire-api ]; testHaskellDepends = [ - base - containers - hspec - imports - polysemy - polysemy-plugin - unliftio + base containers hspec imports polysemy polysemy-plugin unliftio ]; testToolDepends = [ hspec-discover ]; description = "Polysemy interface for various libraries"; diff --git a/libs/ropes/default.nix b/libs/ropes/default.nix index 6dd3c1ed69..a97db02000 100644 --- a/libs/ropes/default.nix +++ b/libs/ropes/default.nix @@ -2,35 +2,17 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bytestring -, errors -, gitignoreSource -, http-client -, http-types -, imports -, iso3166-country-codes -, lib -, text -, time +{ mkDerivation, aeson, base, bytestring, errors, gitignoreSource +, http-client, http-types, imports, iso3166-country-codes, lib +, text, time }: mkDerivation { pname = "ropes"; version = "0.4.20"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - base - bytestring - errors - http-client - http-types - imports - iso3166-country-codes - text - time + aeson base bytestring errors http-client http-types imports + iso3166-country-codes text time ]; description = "Various ropes to tie together with external web services"; license = lib.licenses.agpl3Only; diff --git a/libs/schema-profunctor/default.nix b/libs/schema-profunctor/default.nix index bede1bdeae..759118e251 100644 --- a/libs/schema-profunctor/default.nix +++ b/libs/schema-profunctor/default.nix @@ -2,55 +2,22 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-qq -, base -, bifunctors -, comonad -, containers -, gitignoreSource -, imports -, insert-ordered-containers -, lens -, lib -, openapi3 -, profunctors -, tasty -, tasty-hunit -, text -, transformers -, vector +{ mkDerivation, aeson, aeson-qq, base, bifunctors, comonad +, containers, gitignoreSource, imports, insert-ordered-containers +, lens, lib, openapi3, profunctors, tasty, tasty-hunit, text +, transformers, vector }: mkDerivation { pname = "schema-profunctor"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - base - bifunctors - comonad - containers - imports - lens - openapi3 - profunctors - text - transformers - vector + aeson base bifunctors comonad containers imports lens openapi3 + profunctors text transformers vector ]; testHaskellDepends = [ - aeson - aeson-qq - base - imports - insert-ordered-containers - lens - openapi3 - tasty - tasty-hunit - text + aeson aeson-qq base imports insert-ordered-containers lens openapi3 + tasty tasty-hunit text ]; license = lib.licenses.agpl3Only; } diff --git a/libs/sodium-crypto-sign/default.nix b/libs/sodium-crypto-sign/default.nix index 16278c2952..b7ab77265d 100644 --- a/libs/sodium-crypto-sign/default.nix +++ b/libs/sodium-crypto-sign/default.nix @@ -2,24 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, base64-bytestring -, bytestring -, gitignoreSource -, imports -, lib -, libsodium +{ mkDerivation, base, base64-bytestring, bytestring +, gitignoreSource, imports, lib, libsodium }: mkDerivation { pname = "sodium-crypto-sign"; version = "0.1.2"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - base64-bytestring - bytestring - imports + base base64-bytestring bytestring imports ]; libraryPkgconfigDepends = [ libsodium ]; description = "FFI to some of the libsodium crypto_sign_* functions"; diff --git a/libs/ssl-util/default.nix b/libs/ssl-util/default.nix index 1ec717b7f7..1ff0f94b88 100644 --- a/libs/ssl-util/default.nix +++ b/libs/ssl-util/default.nix @@ -2,29 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, byteable -, bytestring -, gitignoreSource -, HsOpenSSL -, http-client -, imports -, lib -, time +{ mkDerivation, base, byteable, bytestring, gitignoreSource +, HsOpenSSL, http-client, imports, lib, time }: mkDerivation { pname = "ssl-util"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - base - byteable - bytestring - HsOpenSSL - http-client - imports - time + base byteable bytestring HsOpenSSL http-client imports time ]; description = "SSL-related utilities"; license = lib.licenses.agpl3Only; diff --git a/libs/tasty-cannon/default.nix b/libs/tasty-cannon/default.nix index 297f3ce945..4b79d90f24 100644 --- a/libs/tasty-cannon/default.nix +++ b/libs/tasty-cannon/default.nix @@ -2,47 +2,19 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, async -, base -, bilge -, bytestring -, bytestring-conversion -, data-timeout -, exceptions -, gitignoreSource -, http-client -, http-types -, imports -, lib -, random -, tasty-hunit -, types-common -, websockets -, wire-api +{ mkDerivation, aeson, async, base, bilge, bytestring +, bytestring-conversion, data-timeout, exceptions, gitignoreSource +, http-client, http-types, imports, lib, random, tasty-hunit +, types-common, websockets, wire-api }: mkDerivation { pname = "tasty-cannon"; version = "0.4.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - async - base - bilge - bytestring - bytestring-conversion - data-timeout - exceptions - http-client - http-types - imports - random - tasty-hunit - types-common - websockets - wire-api + aeson async base bilge bytestring bytestring-conversion + data-timeout exceptions http-client http-types imports random + tasty-hunit types-common websockets wire-api ]; description = "Cannon Integration Testing Utilities"; license = lib.licenses.agpl3Only; diff --git a/libs/types-common-aws/default.nix b/libs/types-common-aws/default.nix index ed7f1b5b2d..e87f45fb94 100644 --- a/libs/types-common-aws/default.nix +++ b/libs/types-common-aws/default.nix @@ -2,41 +2,17 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, amazonka -, amazonka-core -, amazonka-sqs -, base -, base64-bytestring -, gitignoreSource -, imports -, lens -, lib -, proto-lens -, resourcet -, safe -, text -, time -, unliftio +{ mkDerivation, amazonka, amazonka-core, amazonka-sqs, base +, base64-bytestring, gitignoreSource, imports, lens, lib +, proto-lens, resourcet, safe, text, time, unliftio }: mkDerivation { pname = "types-common-aws"; version = "0.16.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - amazonka - amazonka-core - amazonka-sqs - base - base64-bytestring - imports - lens - proto-lens - resourcet - safe - text - time - unliftio + amazonka amazonka-core amazonka-sqs base base64-bytestring imports + lens proto-lens resourcet safe text time unliftio ]; description = "Shared AWS type definitions"; license = lib.licenses.agpl3Only; diff --git a/libs/types-common-journal/default.nix b/libs/types-common-journal/default.nix index 7dae825dfb..338c21abae 100644 --- a/libs/types-common-journal/default.nix +++ b/libs/types-common-journal/default.nix @@ -2,19 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, bytestring -, Cabal -, gitignoreSource -, imports -, lib -, proto-lens-protoc -, proto-lens-runtime -, proto-lens-setup -, time -, types-common -, uuid +{ mkDerivation, base, bytestring, Cabal, gitignoreSource, imports +, lib, proto-lens-protoc, proto-lens-runtime, proto-lens-setup +, time, types-common, uuid }: mkDerivation { pname = "types-common-journal"; @@ -22,13 +12,7 @@ mkDerivation { src = gitignoreSource ./.; setupHaskellDepends = [ base Cabal proto-lens-setup ]; libraryHaskellDepends = [ - base - bytestring - imports - proto-lens-runtime - time - types-common - uuid + base bytestring imports proto-lens-runtime time types-common uuid ]; libraryToolDepends = [ proto-lens-protoc ]; description = "Shared protobuf type definitions"; diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index a5c57f5f05..2afa048e8b 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -2,126 +2,36 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, attoparsec -, attoparsec-iso8601 -, base -, base16-bytestring -, base64-bytestring -, binary -, bytestring -, bytestring-conversion -, cassandra-util -, cereal -, containers -, cryptohash-md5 -, cryptohash-sha1 -, cryptonite -, currency-codes -, data-default -, generic-random -, gitignoreSource -, hashable -, http-api-data -, imports -, iproute -, iso3166-country-codes -, iso639 -, lens -, lens-datetime -, lib -, mime -, openapi3 -, optparse-applicative -, pem -, protobuf -, QuickCheck -, quickcheck-instances -, random -, schema-profunctor -, servant-server -, tagged -, tasty -, tasty-hunit -, tasty-quickcheck -, text -, time -, time-locale-compat -, tinylog -, unix -, unordered-containers -, uri-bytestring -, uuid -, yaml +{ mkDerivation, aeson, attoparsec, attoparsec-iso8601, base +, base16-bytestring, base64-bytestring, binary, bytestring +, bytestring-conversion, cassandra-util, cereal, containers +, cryptohash-md5, cryptohash-sha1, cryptonite, currency-codes +, data-default, generic-random, gitignoreSource, hashable +, http-api-data, imports, iproute, iso3166-country-codes, iso639 +, lens, lens-datetime, lib, mime, openapi3, optparse-applicative +, pem, protobuf, QuickCheck, quickcheck-instances, random +, schema-profunctor, servant-server, tagged, tasty, tasty-hunit +, tasty-quickcheck, text, time, time-locale-compat, tinylog, unix +, unordered-containers, uri-bytestring, uuid, yaml }: mkDerivation { pname = "types-common"; version = "0.16.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - attoparsec - attoparsec-iso8601 - base - base16-bytestring - base64-bytestring - binary - bytestring - bytestring-conversion - cassandra-util - containers - cryptohash-md5 - cryptohash-sha1 - cryptonite - currency-codes - data-default - generic-random - hashable - http-api-data - imports - iproute - iso3166-country-codes - iso639 - lens - lens-datetime - mime - openapi3 - optparse-applicative - pem - protobuf - QuickCheck - quickcheck-instances - random - schema-profunctor - servant-server - tagged - tasty - tasty-hunit - text - time - time-locale-compat - tinylog - unix - unordered-containers - uri-bytestring - uuid - yaml + aeson attoparsec attoparsec-iso8601 base base16-bytestring + base64-bytestring binary bytestring bytestring-conversion + cassandra-util containers cryptohash-md5 cryptohash-sha1 cryptonite + currency-codes data-default generic-random hashable http-api-data + imports iproute iso3166-country-codes iso639 lens lens-datetime + mime openapi3 optparse-applicative pem protobuf QuickCheck + quickcheck-instances random schema-profunctor servant-server tagged + tasty tasty-hunit text time time-locale-compat tinylog unix + unordered-containers uri-bytestring uuid yaml ]; testHaskellDepends = [ - aeson - base - bytestring - bytestring-conversion - cereal - imports - protobuf - tasty - tasty-hunit - tasty-quickcheck - text - time - unordered-containers + aeson base bytestring bytestring-conversion cereal imports protobuf + tasty tasty-hunit tasty-quickcheck text time unordered-containers uuid ]; description = "Shared type definitions"; diff --git a/libs/wai-utilities/default.nix b/libs/wai-utilities/default.nix index bc345ab358..361d3b6ab4 100644 --- a/libs/wai-utilities/default.nix +++ b/libs/wai-utilities/default.nix @@ -2,71 +2,24 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, async -, base -, bytestring -, bytestring-conversion -, errors -, exceptions -, gitignoreSource -, http-types -, http2 -, imports -, kan-extensions -, lib -, metrics-core -, metrics-wai -, openapi3 -, pipes -, prometheus-client -, schema-profunctor -, servant-server -, streaming-commons -, text -, tinylog -, types-common -, unix -, wai -, wai-predicates -, wai-routing -, warp -, warp-tls +{ mkDerivation, aeson, async, base, bytestring +, bytestring-conversion, errors, exceptions, gitignoreSource +, http-types, http2, imports, kan-extensions, lib, metrics-core +, metrics-wai, openapi3, pipes, prometheus-client +, schema-profunctor, servant-server, streaming-commons, text +, tinylog, types-common, unix, wai, wai-predicates, wai-routing +, warp, warp-tls }: mkDerivation { pname = "wai-utilities"; version = "0.16.1"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - async - base - bytestring - bytestring-conversion - errors - exceptions - http-types - http2 - imports - kan-extensions - metrics-core - metrics-wai - openapi3 - pipes - prometheus-client - schema-profunctor - servant-server - streaming-commons - text - tinylog - types-common - unix - wai - wai-predicates - wai-routing - warp - warp-tls + aeson async base bytestring bytestring-conversion errors exceptions + http-types http2 imports kan-extensions metrics-core metrics-wai + openapi3 pipes prometheus-client schema-profunctor servant-server + streaming-commons text tinylog types-common unix wai wai-predicates + wai-routing warp warp-tls ]; description = "Various helpers for WAI"; license = lib.licenses.agpl3Only; diff --git a/libs/wire-api-federation/default.nix b/libs/wire-api-federation/default.nix index c4af614fae..635c8853c3 100644 --- a/libs/wire-api-federation/default.nix +++ b/libs/wire-api-federation/default.nix @@ -2,48 +2,14 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-pretty -, amqp -, async -, base -, bytestring -, bytestring-conversion -, containers -, exceptions -, gitignoreSource -, HsOpenSSL -, hspec -, hspec-discover -, http-media -, http-types -, http2 -, http2-manager -, HUnit -, imports -, kan-extensions -, lens -, lib -, metrics-wai -, mtl -, openapi3 -, QuickCheck -, schema-profunctor -, servant -, servant-client -, servant-client-core -, servant-openapi3 -, servant-server -, singletons -, singletons-th -, text -, time -, transformers -, transitive-anns -, types-common -, uuid -, wai-utilities +{ mkDerivation, aeson, aeson-pretty, amqp, async, base, bytestring +, bytestring-conversion, containers, exceptions, gitignoreSource +, HsOpenSSL, hspec, hspec-discover, http-media, http-types, http2 +, http2-manager, HUnit, imports, kan-extensions, lens, lib +, metrics-wai, mtl, openapi3, QuickCheck, schema-profunctor +, servant, servant-client, servant-client-core, servant-openapi3 +, servant-server, singletons, singletons-th, text, time +, transformers, transitive-anns, types-common, uuid, wai-utilities , wire-api }: mkDerivation { @@ -51,56 +17,16 @@ mkDerivation { version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - amqp - async - base - bytestring - bytestring-conversion - containers - exceptions - HsOpenSSL - http-media - http-types - http2 - http2-manager - imports - kan-extensions - lens - metrics-wai - mtl - openapi3 - QuickCheck - schema-profunctor - servant - servant-client - servant-client-core - servant-openapi3 - servant-server - singletons-th - text - time - transformers - transitive-anns - types-common - wai-utilities - wire-api + aeson amqp async base bytestring bytestring-conversion containers + exceptions HsOpenSSL http-media http-types http2 http2-manager + imports kan-extensions lens metrics-wai mtl openapi3 QuickCheck + schema-profunctor servant servant-client servant-client-core + servant-openapi3 servant-server singletons-th text time + transformers transitive-anns types-common wai-utilities wire-api ]; testHaskellDepends = [ - aeson - aeson-pretty - base - bytestring - containers - hspec - HUnit - imports - QuickCheck - singletons - time - types-common - uuid - wire-api + aeson aeson-pretty base bytestring containers hspec HUnit imports + QuickCheck singletons time types-common uuid wire-api ]; testToolDepends = [ hspec-discover ]; description = "The Wire server-to-server API for federation"; diff --git a/libs/wire-api/default.nix b/libs/wire-api/default.nix index 45e9534e5b..4dcad7efb4 100644 --- a/libs/wire-api/default.nix +++ b/libs/wire-api/default.nix @@ -2,261 +2,61 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-diff -, aeson-pretty -, aeson-qq -, async -, attoparsec -, base -, base64-bytestring -, binary -, binary-parsers -, bytestring -, bytestring-arbitrary -, bytestring-conversion -, case-insensitive -, cassandra-util -, cassava -, cereal -, comonad -, conduit -, constraints -, containers -, cookie -, cryptonite -, currency-codes -, deriving-aeson -, deriving-swagger2 -, either -, email-validate -, errors -, extended -, extra -, filepath -, generics-sop -, ghc-prim -, gitignoreSource -, hashable -, hex -, hostname-validate -, hscim -, HsOpenSSL -, hspec -, hspec-wai -, http-api-data -, http-client -, http-media -, http-types -, imports -, insert-ordered-containers -, iproute -, iso3166-country-codes -, iso639 -, jose -, lens -, lib -, memory -, metrics-wai -, mime -, mtl -, openapi3 -, pem -, polysemy -, process -, proto-lens -, protobuf -, QuickCheck -, quickcheck-instances -, random -, resourcet -, saml2-web-sso -, schema-profunctor -, scientific -, scrypt -, servant -, servant-client -, servant-client-core -, servant-conduit -, servant-multipart -, servant-openapi3 -, servant-server -, singletons -, singletons-base -, singletons-th -, sop-core -, tagged -, tasty -, tasty-hspec -, tasty-hunit -, tasty-quickcheck -, text -, time -, transitive-anns -, types-common -, unliftio -, unordered-containers -, uri-bytestring -, utf8-string -, uuid -, vector -, wai -, wai-extra -, wai-utilities -, wai-websockets -, websockets -, wire-message-proto-lens -, x509 -, zauth +{ mkDerivation, aeson, aeson-diff, aeson-pretty, aeson-qq, async +, attoparsec, base, base64-bytestring, binary, binary-parsers +, bytestring, bytestring-arbitrary, bytestring-conversion +, case-insensitive, cassandra-util, cassava, cereal, comonad +, conduit, constraints, containers, cookie, cryptonite +, currency-codes, deriving-aeson, deriving-swagger2, either +, email-validate, errors, extended, extra, filepath, generics-sop +, ghc-prim, gitignoreSource, hashable, hex, hostname-validate +, hscim, HsOpenSSL, hspec, hspec-wai, http-api-data, http-client +, http-media, http-types, imports, insert-ordered-containers +, iproute, iso3166-country-codes, iso639, jose, lens, lib, memory +, metrics-wai, mime, mtl, openapi3, pem, polysemy, process +, proto-lens, protobuf, QuickCheck, quickcheck-instances, random +, resourcet, saml2-web-sso, schema-profunctor, scientific, scrypt +, servant, servant-client, servant-client-core, servant-conduit +, servant-multipart, servant-openapi3, servant-server, singletons +, singletons-base, singletons-th, sop-core, tagged, tasty +, tasty-hspec, tasty-hunit, tasty-quickcheck, text, time +, transitive-anns, types-common, unliftio, unordered-containers +, uri-bytestring, utf8-string, uuid, vector, wai, wai-extra +, wai-utilities, wai-websockets, websockets +, wire-message-proto-lens, x509, zauth }: mkDerivation { pname = "wire-api"; version = "0.1.0"; src = gitignoreSource ./.; libraryHaskellDepends = [ - aeson - async - attoparsec - base - base64-bytestring - binary - binary-parsers - bytestring - bytestring-conversion - case-insensitive - cassandra-util - cassava - cereal - comonad - conduit - constraints - containers - cookie - cryptonite - currency-codes - deriving-aeson - deriving-swagger2 - either - email-validate - errors - extended - extra - filepath - generics-sop - ghc-prim - hashable - hostname-validate - hscim - HsOpenSSL - http-api-data - http-client - http-media - http-types - imports - insert-ordered-containers - iproute - iso3166-country-codes - iso639 - jose - lens - memory - metrics-wai - mime - mtl - openapi3 - pem - polysemy - proto-lens - protobuf - QuickCheck - quickcheck-instances - random - resourcet - saml2-web-sso - schema-profunctor - scientific - scrypt - servant - servant-client - servant-client-core - servant-conduit - servant-multipart - servant-openapi3 - servant-server - singletons - singletons-base - singletons-th - sop-core - tagged - text - time - transitive-anns - types-common - unordered-containers - uri-bytestring - utf8-string - uuid - vector - wai - wai-extra - wai-utilities - wai-websockets - websockets - wire-message-proto-lens - x509 - zauth + aeson async attoparsec base base64-bytestring binary binary-parsers + bytestring bytestring-conversion case-insensitive cassandra-util + cassava cereal comonad conduit constraints containers cookie + cryptonite currency-codes deriving-aeson deriving-swagger2 either + email-validate errors extended extra filepath generics-sop ghc-prim + hashable hostname-validate hscim HsOpenSSL http-api-data + http-client http-media http-types imports insert-ordered-containers + iproute iso3166-country-codes iso639 jose lens memory metrics-wai + mime mtl openapi3 pem polysemy proto-lens protobuf QuickCheck + quickcheck-instances random resourcet saml2-web-sso + schema-profunctor scientific scrypt servant servant-client + servant-client-core servant-conduit servant-multipart + servant-openapi3 servant-server singletons singletons-base + singletons-th sop-core tagged text time transitive-anns + types-common unordered-containers uri-bytestring utf8-string uuid + vector wai wai-extra wai-utilities wai-websockets websockets + wire-message-proto-lens x509 zauth ]; testHaskellDepends = [ - aeson - aeson-diff - aeson-pretty - aeson-qq - async - base - binary - bytestring - bytestring-arbitrary - bytestring-conversion - cassava - containers - cryptonite - currency-codes - either - filepath - hex - hspec - hspec-wai - http-types - imports - iso3166-country-codes - iso639 - lens - memory - metrics-wai - openapi3 - pem - process - proto-lens - QuickCheck - random - saml2-web-sso - schema-profunctor - servant - servant-server - tasty - tasty-hspec - tasty-hunit - tasty-quickcheck - text - time - types-common - unliftio - uri-bytestring - uuid - vector - wai - wire-message-proto-lens + aeson aeson-diff aeson-pretty aeson-qq async base binary bytestring + bytestring-arbitrary bytestring-conversion cassava containers + cryptonite currency-codes either filepath hex hspec hspec-wai + http-types imports iso3166-country-codes iso639 lens memory + metrics-wai openapi3 pem process proto-lens QuickCheck random + saml2-web-sso schema-profunctor servant servant-server tasty + tasty-hspec tasty-hunit tasty-quickcheck text time types-common + unliftio uri-bytestring uuid vector wai wire-message-proto-lens ]; license = lib.licenses.agpl3Only; } diff --git a/libs/wire-message-proto-lens/default.nix b/libs/wire-message-proto-lens/default.nix index 3c58511773..598b4edb7f 100644 --- a/libs/wire-message-proto-lens/default.nix +++ b/libs/wire-message-proto-lens/default.nix @@ -2,14 +2,8 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, Cabal -, gitignoreSource -, lib -, proto-lens-protoc -, proto-lens-runtime -, proto-lens-setup +{ mkDerivation, base, Cabal, gitignoreSource, lib +, proto-lens-protoc, proto-lens-runtime, proto-lens-setup }: mkDerivation { pname = "wire-message-proto-lens"; diff --git a/libs/zauth/default.nix b/libs/zauth/default.nix index e0a60d3abf..1e195124d5 100644 --- a/libs/zauth/default.nix +++ b/libs/zauth/default.nix @@ -2,29 +2,11 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, attoparsec -, base -, base64-bytestring -, bytestring -, bytestring-conversion -, errors -, exceptions -, gitignoreSource -, imports -, lens -, lib -, mtl -, mwc-random -, optparse-applicative -, sodium-crypto-sign -, tasty -, tasty-hunit -, tasty-quickcheck -, text -, time -, uuid -, vector +{ mkDerivation, attoparsec, base, base64-bytestring, bytestring +, bytestring-conversion, errors, exceptions, gitignoreSource +, imports, lens, lib, mtl, mwc-random, optparse-applicative +, sodium-crypto-sign, tasty, tasty-hunit, tasty-quickcheck, text +, time, uuid, vector }: mkDerivation { pname = "zauth"; @@ -33,45 +15,17 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - attoparsec - base - base64-bytestring - bytestring - bytestring-conversion - errors - exceptions - imports - lens - mtl - mwc-random - sodium-crypto-sign - time - uuid - vector + attoparsec base base64-bytestring bytestring bytestring-conversion + errors exceptions imports lens mtl mwc-random sodium-crypto-sign + time uuid vector ]; executableHaskellDepends = [ - base - base64-bytestring - bytestring - bytestring-conversion - errors - imports - lens - optparse-applicative - sodium-crypto-sign - uuid + base base64-bytestring bytestring bytestring-conversion errors + imports lens optparse-applicative sodium-crypto-sign uuid ]; testHaskellDepends = [ - base - bytestring-conversion - imports - lens - sodium-crypto-sign - tasty - tasty-hunit - tasty-quickcheck - text - uuid + base bytestring-conversion imports lens sodium-crypto-sign tasty + tasty-hunit tasty-quickcheck text uuid ]; description = "Creation and validation of signed tokens"; license = lib.licenses.agpl3Only; diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 910b9a396d..9a54116855 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -2,44 +2,14 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, amqp -, base -, bytestring -, containers -, exceptions -, extended -, federator -, gitignoreSource -, HsOpenSSL -, hspec -, http-client -, http-media -, http-types -, http2-manager -, imports -, lib -, metrics-core -, metrics-wai -, monad-control -, prometheus-client -, QuickCheck -, retry -, servant -, servant-client -, servant-client-core -, servant-server -, text -, tinylog -, transformers -, transformers-base -, types-common -, unliftio -, wai -, wai-utilities -, wire-api -, wire-api-federation +{ mkDerivation, aeson, amqp, base, bytestring, containers +, exceptions, extended, federator, gitignoreSource, HsOpenSSL +, hspec, http-client, http-media, http-types, http2-manager +, imports, lib, metrics-core, metrics-wai, monad-control +, prometheus-client, QuickCheck, retry, servant, servant-client +, servant-client-core, servant-server, text, tinylog, transformers +, transformers-base, types-common, unliftio, wai, wai-utilities +, wire-api, wire-api-federation }: mkDerivation { pname = "background-worker"; @@ -48,58 +18,19 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - amqp - containers - exceptions - extended - HsOpenSSL - http-client - http2-manager - imports - metrics-core - metrics-wai - monad-control - prometheus-client - retry - servant-client - servant-server - text - tinylog - transformers-base - types-common - unliftio - wai-utilities + aeson amqp containers exceptions extended HsOpenSSL http-client + http2-manager imports metrics-core metrics-wai monad-control + prometheus-client retry servant-client servant-server text tinylog + transformers-base types-common unliftio wai-utilities wire-api-federation ]; executableHaskellDepends = [ HsOpenSSL imports types-common ]; testHaskellDepends = [ - aeson - amqp - base - bytestring - containers - extended - federator - hspec - http-client - http-media - http-types - imports - prometheus-client - QuickCheck - servant - servant-client - servant-client-core - servant-server - text - tinylog - transformers - types-common - unliftio - wai - wire-api - wire-api-federation + aeson amqp base bytestring containers extended federator hspec + http-client http-media http-types imports prometheus-client + QuickCheck servant servant-client servant-client-core + servant-server text tinylog transformers types-common unliftio wai + wire-api wire-api-federation ]; description = "Runs background work"; license = lib.licenses.agpl3Only; diff --git a/services/brig/default.nix b/services/brig/default.nix index 6887c802f3..dd444edbc5 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -2,162 +2,39 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, amazonka -, amazonka-core -, amazonka-dynamodb -, amazonka-ses -, amazonka-sqs -, amqp -, async -, attoparsec -, auto-update -, base -, base-prelude -, base16-bytestring -, base64-bytestring -, bilge -, binary -, bloodhound -, brig-types -, bytestring -, bytestring-conversion -, case-insensitive -, cassandra-util -, comonad -, conduit -, containers -, cookie -, cql -, cryptobox-haskell -, currency-codes -, data-default -, data-timeout -, dns -, dns-util -, email-validate -, enclosed-exceptions -, errors -, exceptions -, extended -, extra -, federator -, file-embed -, file-embed-lzma -, filepath -, fsnotify -, galley-types -, geoip2 -, gitignoreSource -, gundeck-types -, hashable -, HaskellNet -, HaskellNet-SSL -, hscim -, HsOpenSSL -, html-entities -, http-api-data -, http-client -, http-client-openssl -, http-client-tls -, http-media -, http-reverse-proxy -, http-types -, http2-manager -, imports -, insert-ordered-containers -, iproute -, iso639 -, jose -, jwt-tools -, lens -, lens-aeson -, lib -, metrics-core -, metrics-wai -, mime -, mime-mail -, mmorph -, MonadRandom -, mtl -, mwc-random -, network -, network-conduit-tls -, network-uri -, openapi3 -, optparse-applicative -, pem -, pipes -, polysemy -, polysemy-plugin -, polysemy-wire-zoo -, postie -, process -, proto-lens -, QuickCheck -, random -, random-shuffle -, raw-strings-qq -, resource-pool -, resourcet -, retry -, ropes -, safe -, safe-exceptions -, saml2-web-sso -, schema-profunctor -, scientific -, servant -, servant-client -, servant-client-core -, servant-openapi3 -, servant-server -, servant-swagger-ui -, sodium-crypto-sign -, spar -, split -, ssl-util -, statistics -, stomp-queue -, streaming-commons -, tasty -, tasty-ant-xml -, tasty-cannon -, tasty-hunit -, tasty-quickcheck -, template -, template-haskell -, temporary -, text -, text-icu-translit -, time -, time-out -, time-units -, tinylog -, transformers -, transitive-anns -, types-common -, types-common-aws -, types-common-journal -, unliftio -, unordered-containers -, uri-bytestring -, uuid -, vector -, wai -, wai-extra -, wai-middleware-gunzip -, wai-predicates -, wai-route -, wai-routing -, wai-utilities -, warp -, warp-tls -, wire-api -, wire-api-federation -, yaml -, zauth +{ mkDerivation, aeson, amazonka, amazonka-core, amazonka-dynamodb +, amazonka-ses, amazonka-sqs, amqp, async, attoparsec, auto-update +, base, base-prelude, base16-bytestring, base64-bytestring, bilge +, binary, bloodhound, brig-types, bytestring, bytestring-conversion +, case-insensitive, cassandra-util, comonad, conduit, containers +, cookie, cql, cryptobox-haskell, currency-codes, data-default +, data-timeout, dns, dns-util, email-validate, enclosed-exceptions +, errors, exceptions, extended, extra, federator, file-embed +, file-embed-lzma, filepath, fsnotify, galley-types, geoip2 +, gitignoreSource, gundeck-types, hashable, HaskellNet +, HaskellNet-SSL, hscim, HsOpenSSL, html-entities, http-api-data +, http-client, http-client-openssl, http-client-tls, http-media +, http-reverse-proxy, http-types, http2-manager, imports +, insert-ordered-containers, iproute, iso639, jose, jwt-tools, lens +, lens-aeson, lib, metrics-core, metrics-wai, mime, mime-mail +, mmorph, MonadRandom, mtl, mwc-random, network +, network-conduit-tls, network-uri, openapi3, optparse-applicative +, pem, pipes, polysemy, polysemy-plugin, polysemy-wire-zoo, postie +, process, proto-lens, QuickCheck, random, random-shuffle +, raw-strings-qq, resource-pool, resourcet, retry, ropes, safe +, safe-exceptions, saml2-web-sso, schema-profunctor, scientific +, servant, servant-client, servant-client-core, servant-openapi3 +, servant-server, servant-swagger-ui, sodium-crypto-sign, spar +, split, ssl-util, statistics, stomp-queue, streaming-commons +, tasty, tasty-ant-xml, tasty-cannon, tasty-hunit, tasty-quickcheck +, template, template-haskell, temporary, text, text-icu-translit +, time, time-out, time-units, tinylog, transformers +, transitive-anns, types-common, types-common-aws +, types-common-journal, unliftio, unordered-containers +, uri-bytestring, uuid, vector, wai, wai-extra +, wai-middleware-gunzip, wai-predicates, wai-route, wai-routing +, wai-utilities, warp, warp-tls, wire-api, wire-api-federation +, yaml, zauth }: mkDerivation { pname = "brig"; @@ -166,249 +43,54 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - amazonka - amazonka-core - amazonka-dynamodb - amazonka-ses - amazonka-sqs - amqp - async - auto-update - base - base-prelude - base16-bytestring - base64-bytestring - bilge - bloodhound - brig-types - bytestring - bytestring-conversion - cassandra-util - comonad - conduit - containers - cookie - cql - cryptobox-haskell - currency-codes - data-default - data-timeout - dns - dns-util - enclosed-exceptions - errors - exceptions - extended - extra - file-embed - file-embed-lzma - filepath - fsnotify - galley-types - geoip2 - gundeck-types - hashable - HaskellNet - HaskellNet-SSL - HsOpenSSL - html-entities - http-client - http-client-openssl - http-media - http-types - http2-manager - imports - insert-ordered-containers - iproute - iso639 - jose - jwt-tools - lens - lens-aeson - metrics-core - metrics-wai - mime - mime-mail - mmorph - MonadRandom - mtl - mwc-random - network - network-conduit-tls - openapi3 - optparse-applicative - polysemy - polysemy-plugin - polysemy-wire-zoo - proto-lens - random - random-shuffle - raw-strings-qq - resource-pool - resourcet - retry - ropes - safe-exceptions - saml2-web-sso - schema-profunctor - scientific - servant - servant-openapi3 - servant-server - servant-swagger-ui - sodium-crypto-sign - split - ssl-util - statistics - stomp-queue - template - template-haskell - text - text-icu-translit - time - time-out - time-units - tinylog - transformers - transitive-anns - types-common - types-common-aws - types-common-journal - unliftio - unordered-containers - uri-bytestring - uuid - vector - wai - wai-extra - wai-middleware-gunzip - wai-predicates - wai-routing - wai-utilities - wire-api - wire-api-federation - yaml - zauth + aeson amazonka amazonka-core amazonka-dynamodb amazonka-ses + amazonka-sqs amqp async auto-update base base-prelude + base16-bytestring base64-bytestring bilge bloodhound brig-types + bytestring bytestring-conversion cassandra-util comonad conduit + containers cookie cql cryptobox-haskell currency-codes data-default + data-timeout dns dns-util enclosed-exceptions errors exceptions + extended extra file-embed file-embed-lzma filepath fsnotify + galley-types geoip2 gundeck-types hashable HaskellNet + HaskellNet-SSL HsOpenSSL html-entities http-client + http-client-openssl http-media http-types http2-manager imports + insert-ordered-containers iproute iso639 jose jwt-tools lens + lens-aeson metrics-core metrics-wai mime mime-mail mmorph + MonadRandom mtl mwc-random network network-conduit-tls openapi3 + optparse-applicative polysemy polysemy-plugin polysemy-wire-zoo + proto-lens random random-shuffle raw-strings-qq resource-pool + resourcet retry ropes safe-exceptions saml2-web-sso + schema-profunctor scientific servant servant-openapi3 + servant-server servant-swagger-ui sodium-crypto-sign split ssl-util + statistics stomp-queue template template-haskell text + text-icu-translit time time-out time-units tinylog transformers + transitive-anns types-common types-common-aws types-common-journal + unliftio unordered-containers uri-bytestring uuid vector wai + wai-extra wai-middleware-gunzip wai-predicates wai-routing + wai-utilities wire-api wire-api-federation yaml zauth ]; executableHaskellDepends = [ - aeson - async - attoparsec - base - base16-bytestring - bilge - bloodhound - brig-types - bytestring - bytestring-conversion - case-insensitive - cassandra-util - containers - cookie - data-default - data-timeout - email-validate - exceptions - extended - extra - federator - filepath - galley-types - hscim - HsOpenSSL - http-api-data - http-client - http-client-tls - http-media - http-reverse-proxy - http-types - imports - jose - lens - lens-aeson - metrics-wai - mime - mime-mail - MonadRandom - mtl - network - network-uri - optparse-applicative - pem - pipes - polysemy - polysemy-wire-zoo - postie - process - proto-lens - QuickCheck - random - random-shuffle - raw-strings-qq - retry - safe - saml2-web-sso - servant - servant-client - servant-client-core - spar - streaming-commons - tasty - tasty-ant-xml - tasty-cannon - tasty-hunit - temporary - text - time - time-units - tinylog - transformers - types-common - types-common-aws - types-common-journal - unliftio - unordered-containers - uri-bytestring - uuid - vector - wai - wai-extra - wai-route - wai-utilities - warp - warp-tls - wire-api - wire-api-federation - yaml - zauth + aeson async attoparsec base base16-bytestring bilge bloodhound + brig-types bytestring bytestring-conversion case-insensitive + cassandra-util containers cookie data-default data-timeout + email-validate exceptions extended extra federator filepath + galley-types hscim HsOpenSSL http-api-data http-client + http-client-tls http-media http-reverse-proxy http-types imports + jose lens lens-aeson metrics-wai mime mime-mail MonadRandom mtl + network network-uri optparse-applicative pem pipes polysemy + polysemy-wire-zoo postie process proto-lens QuickCheck random + random-shuffle raw-strings-qq retry safe saml2-web-sso servant + servant-client servant-client-core spar streaming-commons tasty + tasty-ant-xml tasty-cannon tasty-hunit temporary text time + time-units tinylog transformers types-common types-common-aws + types-common-journal unliftio unordered-containers uri-bytestring + uuid vector wai wai-extra wai-route wai-utilities warp warp-tls + wire-api wire-api-federation yaml zauth ]; testHaskellDepends = [ - aeson - base - binary - brig-types - bytestring - containers - data-timeout - dns - dns-util - exceptions - HsOpenSSL - imports - lens - polysemy - polysemy-wire-zoo - tasty - tasty-hunit - tasty-quickcheck - time - tinylog - types-common - unliftio - uri-bytestring - uuid - wire-api + aeson base binary brig-types bytestring containers data-timeout dns + dns-util exceptions HsOpenSSL imports lens polysemy + polysemy-wire-zoo tasty tasty-hunit tasty-quickcheck time tinylog + types-common unliftio uri-bytestring uuid wire-api ]; description = "User Service"; license = lib.licenses.agpl3Only; diff --git a/services/cannon/default.nix b/services/cannon/default.nix index b1ff1ab1d2..e28fc3009d 100644 --- a/services/cannon/default.nix +++ b/services/cannon/default.nix @@ -2,54 +2,15 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, api-field-json-th -, async -, base -, bilge -, bytestring -, bytestring-conversion -, conduit -, criterion -, data-default -, data-timeout -, exceptions -, extended -, extra -, gitignoreSource -, gundeck-types -, hashable -, http-types -, imports -, lens -, lens-family-core -, lib -, metrics-wai -, mwc-random -, QuickCheck -, random -, retry -, safe-exceptions -, servant-conduit -, servant-server -, strict -, tasty -, tasty-hunit -, tasty-quickcheck -, text -, tinylog -, types-common -, unix -, unliftio -, uuid -, vector -, wai -, wai-extra -, wai-utilities -, warp -, websockets -, wire-api +{ mkDerivation, aeson, api-field-json-th, async, base, bilge +, bytestring, bytestring-conversion, conduit, criterion +, data-default, data-timeout, exceptions, extended, extra +, gitignoreSource, gundeck-types, hashable, http-types, imports +, lens, lens-family-core, lib, metrics-wai, mwc-random, QuickCheck +, random, retry, safe-exceptions, servant-conduit, servant-server +, strict, tasty, tasty-hunit, tasty-quickcheck, text, tinylog +, types-common, unix, unliftio, uuid, vector, wai, wai-extra +, wai-utilities, warp, websockets, wire-api }: mkDerivation { pname = "cannon"; @@ -58,59 +19,18 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - api-field-json-th - async - base - bilge - bytestring - bytestring-conversion - conduit - data-default - data-timeout - exceptions - extended - extra - gundeck-types - hashable - http-types - imports - lens - lens-family-core - metrics-wai - mwc-random - retry - safe-exceptions - servant-conduit - servant-server - strict - text - tinylog - types-common - unix - unliftio - vector - wai - wai-extra - wai-utilities - warp - websockets + aeson api-field-json-th async base bilge bytestring + bytestring-conversion conduit data-default data-timeout exceptions + extended extra gundeck-types hashable http-types imports lens + lens-family-core metrics-wai mwc-random retry safe-exceptions + servant-conduit servant-server strict text tinylog types-common + unix unliftio vector wai wai-extra wai-utilities warp websockets wire-api ]; executableHaskellDepends = [ base imports types-common ]; testHaskellDepends = [ - async - base - bytestring - imports - metrics-wai - QuickCheck - random - tasty - tasty-hunit - tasty-quickcheck - uuid - wire-api + async base bytestring imports metrics-wai QuickCheck random tasty + tasty-hunit tasty-quickcheck uuid wire-api ]; benchmarkHaskellDepends = [ async base criterion imports uuid ]; description = "Push Notification API"; diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 508eb00275..396d7c617b 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -203,104 +203,3 @@ executable cargohold ld-options: -static default-language: Haskell2010 - -executable cargohold-integration - main-is: Main.hs - other-modules: - API - API.Federation - API.Util - API.V3 - App - Metrics - Paths_cargohold - TestSetup - - hs-source-dirs: test/integration - default-extensions: - NoImplicitPrelude - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints -Wunused-packages - - build-depends: - aeson >=2.0.1.0 - , base >=4 && <5 - , bilge >=0.21 - , bytestring >=0.10 - , bytestring-conversion >=0.2 - , cargohold - , cargohold-types - , conduit - , containers - , cryptonite - , federator - , http-api-data - , http-client >=0.4 - , http-client-tls >=0.2 - , http-media - , http-types >=0.8 - , imports - , kan-extensions - , lens >=3.8 - , mime >=0.4 - , mmorph - , mtl - , optparse-applicative - , safe - , servant-client - , tagged >=0.8 - , tasty >=1.0 - , tasty-ant-xml - , tasty-hunit >=0.9 - , text >=1.1 - , time >=1.5 - , types-common >=0.7 - , uuid >=1.3 - , wai-utilities >=0.12 - , wire-api - , wire-api-federation - , yaml >=0.8 - - default-language: Haskell2010 diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 8b529f96f0..0e93bf3c69 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -2,74 +2,18 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, amazonka -, amazonka-s3 -, attoparsec -, auto-update -, base -, base64-bytestring -, bilge -, bytestring -, bytestring-conversion -, cargohold-types -, case-insensitive -, conduit -, conduit-extra -, containers -, cryptonite -, data-default -, errors -, exceptions -, extended -, federator -, gitignoreSource -, HsOpenSSL -, http-api-data -, http-client -, http-client-openssl -, http-client-tls -, http-media -, http-types -, http2-manager -, imports -, kan-extensions -, lens -, lib -, metrics-core -, metrics-wai -, mime -, mmorph -, mtl -, optparse-applicative -, resourcet -, retry -, safe -, servant -, servant-client -, servant-server -, tagged -, tasty -, tasty-ant-xml -, tasty-hunit -, text -, time -, tinylog -, transformers -, transitive-anns -, types-common -, types-common-aws -, unliftio -, unordered-containers -, uri-bytestring -, uuid -, wai -, wai-extra -, wai-utilities -, wire-api -, wire-api-federation -, yaml +{ mkDerivation, aeson, amazonka, amazonka-s3, attoparsec +, auto-update, base, base64-bytestring, bilge, bytestring +, bytestring-conversion, cargohold-types, case-insensitive, conduit +, conduit-extra, containers, cryptonite, data-default, errors +, exceptions, extended, gitignoreSource, HsOpenSSL, http-client +, http-client-openssl, http-types, http2-manager, imports +, kan-extensions, lens, lib, metrics-core, metrics-wai, mime +, resourcet, retry, servant, servant-client, servant-server, text +, time, tinylog, transformers, transitive-anns, types-common +, types-common-aws, unliftio, unordered-containers, uri-bytestring +, uuid, wai, wai-extra, wai-utilities, wire-api +, wire-api-federation, yaml }: mkDerivation { pname = "cargohold"; @@ -78,99 +22,19 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - amazonka - amazonka-s3 - attoparsec - auto-update - base - base64-bytestring - bilge - bytestring - bytestring-conversion - cargohold-types - case-insensitive - conduit - conduit-extra - containers - cryptonite - data-default - errors - exceptions - extended - HsOpenSSL - http-client - http-client-openssl - http-types - http2-manager - imports - kan-extensions - lens - metrics-core - metrics-wai - mime - resourcet - retry - servant - servant-client - servant-server - text - time - tinylog - transformers - transitive-anns - types-common - types-common-aws - unliftio - unordered-containers - uri-bytestring - uuid - wai - wai-extra - wai-utilities - wire-api - wire-api-federation - yaml - ]; - executableHaskellDepends = [ - aeson - base - bilge - bytestring - bytestring-conversion - cargohold-types - conduit - containers - cryptonite - federator - HsOpenSSL - http-api-data - http-client - http-client-tls - http-media - http-types - imports - kan-extensions - lens - mime - mmorph - mtl - optparse-applicative - safe - servant-client - tagged - tasty - tasty-ant-xml - tasty-hunit - text - time - types-common - uuid - wai-utilities - wire-api - wire-api-federation - yaml + aeson amazonka amazonka-s3 attoparsec auto-update base + base64-bytestring bilge bytestring bytestring-conversion + cargohold-types case-insensitive conduit conduit-extra containers + cryptonite data-default errors exceptions extended HsOpenSSL + http-client http-client-openssl http-types http2-manager imports + kan-extensions lens metrics-core metrics-wai mime resourcet retry + servant servant-client servant-server text time tinylog + transformers transitive-anns types-common types-common-aws unliftio + unordered-containers uri-bytestring uuid wai wai-extra + wai-utilities wire-api wire-api-federation yaml ]; + executableHaskellDepends = [ base HsOpenSSL imports types-common ]; description = "Asset Storage API"; license = lib.licenses.agpl3Only; + mainProgram = "cargohold"; } diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs deleted file mode 100644 index 4615fa52bf..0000000000 --- a/services/cargohold/test/integration/Main.hs +++ /dev/null @@ -1,83 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module Main - ( main, - ) -where - -import qualified API -import API.Federation (tests) -import qualified API.V3 -import qualified App -import Data.Proxy -import Data.Tagged -import Imports hiding (local) -import qualified Metrics -import Options.Applicative -import Test.Tasty -import Test.Tasty.Ingredients -import Test.Tasty.Options -import Test.Tasty.Runners -import Test.Tasty.Runners.AntXML -import TestSetup -import Util.Test - -newtype ServiceConfigFile = ServiceConfigFile String - deriving (Eq, Ord, Typeable) - -instance IsOption ServiceConfigFile where - defaultValue = ServiceConfigFile "/etc/wire/cargohold/conf/cargohold.yaml" - parseValue = fmap ServiceConfigFile . safeRead - optionName = pure "service-config" - optionHelp = pure "Service config file to read from" - optionCLParser = - fmap ServiceConfigFile $ - strOption $ - ( short (untag (pure 's' :: Tagged ServiceConfigFile Char)) - <> long (untag (optionName :: Tagged ServiceConfigFile String)) - <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) - ) - -main :: IO () -main = do - defaultMainWithIngredients ings $ - askOption $ \(IntegrationConfigFile configPath) -> - askOption $ \(ServiceConfigFile optsPath) -> - -- we treat the configuration file as a tasty "resource", so that we can - -- read it once before all tests - withResource - (createTestSetup optsPath configPath) - (const (pure ())) - $ \ts -> - testGroup - "Cargohold" - [ API.tests ts, - API.V3.tests ts, - Metrics.tests ts, - API.Federation.tests ts, - App.tests ts - ] - where - ings = - includingOptions - [ Option (Proxy :: Proxy ServiceConfigFile), - Option (Proxy :: Proxy IntegrationConfigFile) - ] - : listingTests - : composeReporters antXMLRunner consoleTestReporter - : defaultIngredients diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs deleted file mode 100644 index ae8d4f7362..0000000000 --- a/services/cargohold/test/integration/TestSetup.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module TestSetup - ( test, - tsManager, - tsEndpoint, - tsBrig, - tsOpts, - TestSetup (..), - Cargohold, - TestM, - runTestM, - viewUnversionedCargohold, - viewCargohold, - createTestSetup, - runFederationClient, - withFederationClient, - withFederationError, - apiVersion, - unversioned, - ) -where - -import Bilge hiding (body, responseBody) -import CargoHold.Options hiding (domain) -import Control.Exception (catch) -import Control.Lens -import Control.Monad.Codensity -import Control.Monad.Except -import Control.Monad.Morph -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as B8 -import Data.ByteString.Conversion -import qualified Data.Text as T -import Data.Text.Encoding -import Data.Yaml -import Imports -import Network.HTTP.Client hiding (responseBody) -import qualified Network.HTTP.Client as HTTP -import Network.HTTP.Client.TLS -import qualified Network.Wai.Utilities.Error as Wai -import Servant.Client.Streaming -import Test.Tasty -import Test.Tasty.HUnit -import Util.Options (Endpoint (..)) -import Util.Options.Common -import Util.Test -import Web.HttpApiData -import Wire.API.Federation.Domain -import Wire.API.Routes.Version - -type Cargohold = Request -> Request - -type TestM = ReaderT TestSetup Http - -mkRequest :: Endpoint -> Request -> Request -mkRequest (Endpoint h p) = Bilge.host (encodeUtf8 h) . Bilge.port p - -data TestSetup = TestSetup - { _tsManager :: Manager, - _tsEndpoint :: Endpoint, - _tsBrig :: Endpoint, - _tsOpts :: Opts - } - -makeLenses ''TestSetup - --- | Note: Apply this function last when composing (Request -> Request) functions -apiVersion :: ByteString -> Request -> Request -apiVersion newVersion r = r {HTTP.path = setVersion newVersion (HTTP.path r)} - where - setVersion :: ByteString -> ByteString -> ByteString - setVersion v p = - let p' = removeSlash' p - in v <> "/" <> fromMaybe p' (removeVersionPrefix p') - -removeSlash' :: ByteString -> ByteString -removeSlash' s = case B8.uncons s of - Just ('/', s') -> s' - _ -> s - -removeVersionPrefix :: ByteString -> Maybe ByteString -removeVersionPrefix bs = do - let (x, s) = B8.splitAt 1 bs - guard (x == B8.pack "v") - (_, s') <- B8.readInteger s - pure (B8.tail s') - --- | Note: Apply this function last when composing (Request -> Request) functions -unversioned :: Request -> Request -unversioned r = - r - { HTTP.path = - maybe - (HTTP.path r) - (B8.pack "/" <>) - (removeVersionPrefix . removeSlash' $ HTTP.path r) - } - -viewCargohold :: TestM Cargohold -viewCargohold = - fmap - (apiVersion (toHeader latestVersion) .) - viewUnversionedCargohold - where - latestVersion :: Version - latestVersion = maxBound - -viewUnversionedCargohold :: TestM Cargohold -viewUnversionedCargohold = mkRequest <$> view tsEndpoint - -runTestM :: TestSetup -> TestM a -> IO a -runTestM ts action = runHttpT (view tsManager ts) (runReaderT action ts) - -test :: IO TestSetup -> TestName -> TestM () -> TestTree -test s name action = testCase name $ do - ts <- s - runTestM ts action - -data IntegrationConfig = IntegrationConfig - -- internal endpoint - { cargohold :: Endpoint, - brig :: Endpoint - } - deriving (Show, Generic) - -instance FromJSON IntegrationConfig - -createTestSetup :: FilePath -> FilePath -> IO TestSetup -createTestSetup optsPath configPath = do - -- FUTUREWORK: It would actually be useful to read some - -- values from cargohold (max bytes, for instance) - -- so that tests do not need to keep those values - -- in sync and the user _knows_ what they are - m <- - newManager - tlsManagerSettings - { managerResponseTimeout = responseTimeoutMicro 300000000 - } - let localEndpoint p = Endpoint {_host = "127.0.0.1", _port = p} - iConf <- handleParseError =<< decodeFileEither configPath - opts <- decodeFileThrow optsPath - endpoint <- optOrEnv @IntegrationConfig (.cargohold) iConf (localEndpoint . read) "CARGOHOLD_WEB_PORT" - brigEndpoint <- optOrEnv @IntegrationConfig (.brig) iConf (localEndpoint . read) "BRIG_WEB_PORT" - pure $ - TestSetup - { _tsManager = m, - _tsEndpoint = endpoint, - _tsBrig = brigEndpoint, - _tsOpts = opts - } - -runFederationClient :: ClientM a -> ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -runFederationClient action = do - man <- view tsManager - Endpoint cHost cPort <- view tsEndpoint - domain <- view (tsOpts . settings . federationDomain) - let base = BaseUrl Http (T.unpack cHost) (fromIntegral cPort) "/federation" - let env = - (mkClientEnv man base) - { makeClientRequest = \burl req -> - let req' = defaultMakeClientRequest burl req - in req' - { requestHeaders = - (originDomainHeaderName, toByteString' domain) - : requestHeaders req' - } - } - - r <- lift . lift $ - Codensity $ \k -> - -- Servant's streaming client throws exceptions in IO for some reason - catch (withClientM action env k) (k . Left) - - either throwError pure r - -hoistFederation :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> ExceptT ClientError TestM a -hoistFederation action = do - env <- ask - hoist (liftIO . lowerCodensity) $ runReaderT action env - -withFederationClient :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM a -withFederationClient action = - runExceptT (hoistFederation action) >>= \case - Left err -> - liftIO . assertFailure $ - "Unexpected federation client error: " - <> displayException err - Right x -> pure x - -withFederationError :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM Wai.Error -withFederationError action = - runExceptT (hoistFederation action) - >>= liftIO . \case - Left (FailureResponse _ resp) -> case Aeson.eitherDecode (responseBody resp) of - Left err -> assertFailure $ "Error while parsing error response: " <> err - Right e -> (Wai.code e @?= responseStatusCode resp) $> e - Left err -> assertFailure $ "Unexpected federation client error: " <> displayException err - Right _ -> assertFailure "Unexpected success" diff --git a/services/federator/default.nix b/services/federator/default.nix index 44acd863cc..b19f016830 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -2,73 +2,19 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, async -, base -, bilge -, binary -, bytestring -, bytestring-conversion -, connection -, containers -, cryptonite -, data-default -, dns -, dns-util -, exceptions -, extended -, filepath -, gitignoreSource -, hinotify -, HsOpenSSL -, hspec -, hspec-core -, hspec-junit-formatter -, http-client -, http-client-tls -, http-media -, http-types -, http2 -, http2-manager -, imports -, interpolate -, kan-extensions -, lens -, lib -, metrics-core -, metrics-wai -, mtl -, optparse-applicative -, pem -, polysemy -, polysemy-wire-zoo -, prometheus-client -, QuickCheck -, random -, servant -, servant-client -, servant-client-core -, servant-server -, tasty -, tasty-hunit -, tasty-quickcheck -, temporary -, text -, tinylog -, transformers -, types-common -, unix -, uuid -, wai -, wai-extra -, wai-utilities -, warp -, warp-tls -, wire-api -, wire-api-federation -, x509 -, x509-validation +{ mkDerivation, aeson, async, base, bilge, binary, bytestring +, bytestring-conversion, connection, containers, cryptonite +, data-default, dns, dns-util, exceptions, extended, filepath +, gitignoreSource, hinotify, HsOpenSSL, hspec, hspec-core +, hspec-junit-formatter, http-client, http-client-tls, http-media +, http-types, http2, http2-manager, imports, interpolate +, kan-extensions, lens, lib, metrics-core, metrics-wai, mtl +, optparse-applicative, pem, polysemy, polysemy-wire-zoo +, prometheus-client, QuickCheck, random, servant, servant-client +, servant-client-core, servant-server, tasty, tasty-hunit +, tasty-quickcheck, temporary, text, tinylog, transformers +, types-common, unix, uuid, wai, wai-extra, wai-utilities, warp +, warp-tls, wire-api, wire-api-federation, x509, x509-validation , yaml }: mkDerivation { @@ -78,133 +24,32 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - async - base - bilge - binary - bytestring - bytestring-conversion - containers - data-default - dns - dns-util - exceptions - extended - filepath - hinotify - HsOpenSSL - http-client - http-media - http-types - http2 - http2-manager - imports - kan-extensions - lens - metrics-core - metrics-wai - mtl - pem - polysemy - polysemy-wire-zoo - prometheus-client - servant - servant-client - servant-client-core - servant-server - text - tinylog - transformers - types-common - unix - wai - wai-utilities - warp - wire-api - wire-api-federation - x509 - x509-validation + aeson async base bilge binary bytestring bytestring-conversion + containers data-default dns dns-util exceptions extended filepath + hinotify HsOpenSSL http-client http-media http-types http2 + http2-manager imports kan-extensions lens metrics-core metrics-wai + mtl pem polysemy polysemy-wire-zoo prometheus-client servant + servant-client servant-client-core servant-server text tinylog + transformers types-common unix wai wai-utilities warp wire-api + wire-api-federation x509 x509-validation ]; executableHaskellDepends = [ - aeson - async - base - bilge - binary - bytestring - bytestring-conversion - connection - cryptonite - dns-util - exceptions - HsOpenSSL - hspec - hspec-core - hspec-junit-formatter - http-client-tls - http-types - http2-manager - imports - kan-extensions - lens - optparse-applicative - polysemy - QuickCheck - random - servant-client-core - tasty-hunit - text - types-common - uuid - wai-utilities - wire-api - wire-api-federation - yaml + aeson async base bilge binary bytestring bytestring-conversion + connection cryptonite dns-util exceptions HsOpenSSL hspec + hspec-core hspec-junit-formatter http-client-tls http-types + http2-manager imports kan-extensions lens optparse-applicative + polysemy QuickCheck random servant-client-core tasty-hunit text + types-common uuid wai-utilities wire-api wire-api-federation yaml ]; testHaskellDepends = [ - aeson - base - bytestring - bytestring-conversion - containers - data-default - dns-util - filepath - HsOpenSSL - http-media - http-types - http2 - http2-manager - imports - interpolate - kan-extensions - mtl - polysemy - polysemy-wire-zoo - QuickCheck - servant - servant-client - servant-client-core - servant-server - tasty - tasty-hunit - tasty-quickcheck - temporary - text - tinylog - transformers - types-common - unix - wai - wai-extra - wai-utilities - warp - warp-tls - wire-api - wire-api-federation - x509-validation - yaml + aeson base bytestring bytestring-conversion containers data-default + dns-util filepath HsOpenSSL http-media http-types http2 + http2-manager imports interpolate kan-extensions mtl polysemy + polysemy-wire-zoo QuickCheck servant servant-client + servant-client-core servant-server tasty tasty-hunit + tasty-quickcheck temporary text tinylog transformers types-common + unix wai wai-extra wai-utilities warp warp-tls wire-api + wire-api-federation x509-validation yaml ]; description = "Federation Service"; license = lib.licenses.agpl3Only; diff --git a/services/galley/default.nix b/services/galley/default.nix index 68e29faede..afec2b8c3f 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -2,127 +2,30 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-qq -, amazonka -, amazonka-sqs -, amqp -, asn1-encoding -, asn1-types -, async -, base -, base64-bytestring -, bilge -, binary -, brig-types -, bytestring -, bytestring-conversion -, call-stack -, case-insensitive -, cassandra-util -, cassava -, cereal -, comonad -, conduit -, containers -, cookie -, cryptonite -, currency-codes -, data-default -, data-timeout -, either -, enclosed-exceptions -, errors -, exceptions -, extended -, extra -, federator -, filepath -, galley-types -, gitignoreSource -, gundeck-types -, HsOpenSSL -, hspec -, http-api-data -, http-client -, http-client-openssl -, http-client-tls -, http-media -, http-types -, http2-manager -, imports -, kan-extensions -, lens -, lens-aeson -, lib -, memory -, metrics-core -, metrics-wai -, mtl -, network -, network-uri -, optparse-applicative -, pem -, polysemy -, polysemy-wire-zoo -, process -, proto-lens -, protobuf -, QuickCheck -, quickcheck-instances -, random -, raw-strings-qq -, resourcet -, retry -, safe-exceptions -, saml2-web-sso -, schema-profunctor -, servant -, servant-client -, servant-client-core -, servant-server -, singletons -, sop-core -, split -, ssl-util -, stm -, streaming-commons -, tagged -, tasty -, tasty-ant-xml -, tasty-cannon -, tasty-hunit -, tasty-quickcheck -, temporary -, text -, time -, tinylog -, tls -, transformers -, transitive-anns -, types-common -, types-common-aws -, types-common-journal -, unix -, unliftio -, unordered-containers -, uri-bytestring -, uuid -, uuid-types -, vector -, wai -, wai-extra -, wai-middleware-gunzip -, wai-predicates -, wai-routing -, wai-utilities -, warp -, warp-tls -, wire-api -, wire-api-federation -, x509 -, yaml +{ mkDerivation, aeson, aeson-qq, amazonka, amazonka-sqs, amqp +, asn1-encoding, asn1-types, async, base, base64-bytestring, bilge +, binary, brig-types, bytestring, bytestring-conversion, call-stack +, case-insensitive, cassandra-util, cassava, cereal, comonad +, conduit, containers, cookie, cryptonite, currency-codes +, data-default, data-timeout, either, enclosed-exceptions, errors +, exceptions, extended, extra, federator, filepath, galley-types +, gitignoreSource, gundeck-types, HsOpenSSL, hspec, http-api-data +, http-client, http-client-openssl, http-client-tls, http-media +, http-types, http2-manager, imports, kan-extensions, lens +, lens-aeson, lib, memory, metrics-core, metrics-wai, mtl, network +, network-uri, optparse-applicative, pem, polysemy +, polysemy-wire-zoo, process, proto-lens, protobuf, QuickCheck +, quickcheck-instances, random, raw-strings-qq, resourcet, retry +, safe-exceptions, saml2-web-sso, schema-profunctor, servant +, servant-client, servant-client-core, servant-server, singletons +, sop-core, split, ssl-util, stm, streaming-commons, tagged, tasty +, tasty-ant-xml, tasty-cannon, tasty-hunit, tasty-quickcheck +, temporary, text, time, tinylog, tls, transformers +, transitive-anns, types-common, types-common-aws +, types-common-journal, unix, unliftio, unordered-containers +, uri-bytestring, uuid, uuid-types, vector, wai, wai-extra +, wai-middleware-gunzip, wai-predicates, wai-routing, wai-utilities +, warp, warp-tls, wire-api, wire-api-federation, x509, yaml }: mkDerivation { pname = "galley"; @@ -131,199 +34,45 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - amazonka - amazonka-sqs - amqp - asn1-encoding - asn1-types - async - base - base64-bytestring - bilge - brig-types - bytestring - bytestring-conversion - case-insensitive - cassandra-util - cassava - cereal - comonad - containers - cryptonite - currency-codes - data-default - data-timeout - either - enclosed-exceptions - errors - exceptions - extended - extra - galley-types - gundeck-types - HsOpenSSL - http-client - http-client-openssl - http-media - http-types - http2-manager - imports - kan-extensions - lens - metrics-core - metrics-wai - mtl - optparse-applicative - pem - polysemy - polysemy-wire-zoo - proto-lens - protobuf - raw-strings-qq - resourcet - retry - safe-exceptions - saml2-web-sso - schema-profunctor - servant - servant-client - servant-server - singletons - split - ssl-util - stm - tagged - text - time - tinylog - tls - transformers - transitive-anns - types-common - types-common-aws - types-common-journal - unliftio - uri-bytestring - uuid - wai - wai-extra - wai-middleware-gunzip - wai-predicates - wai-routing - wai-utilities - wire-api - wire-api-federation - x509 + aeson amazonka amazonka-sqs amqp asn1-encoding asn1-types async + base base64-bytestring bilge brig-types bytestring + bytestring-conversion case-insensitive cassandra-util cassava + cereal comonad containers cryptonite currency-codes data-default + data-timeout either enclosed-exceptions errors exceptions extended + extra galley-types gundeck-types HsOpenSSL http-client + http-client-openssl http-media http-types http2-manager imports + kan-extensions lens metrics-core metrics-wai mtl + optparse-applicative pem polysemy polysemy-wire-zoo proto-lens + protobuf raw-strings-qq resourcet retry safe-exceptions + saml2-web-sso schema-profunctor servant servant-client + servant-server singletons split ssl-util stm tagged text time + tinylog tls transformers transitive-anns types-common + types-common-aws types-common-journal unliftio uri-bytestring uuid + wai wai-extra wai-middleware-gunzip wai-predicates wai-routing + wai-utilities wire-api wire-api-federation x509 ]; executableHaskellDepends = [ - aeson - aeson-qq - async - base - base64-bytestring - bilge - binary - brig-types - bytestring - bytestring-conversion - call-stack - case-insensitive - cassandra-util - cassava - cereal - conduit - containers - cookie - currency-codes - data-default - data-timeout - errors - exceptions - extended - extra - federator - filepath - galley-types - HsOpenSSL - hspec - http-api-data - http-client - http-client-openssl - http-client-tls - http-media - http-types - imports - kan-extensions - lens - lens-aeson - memory - metrics-wai - mtl - network - network-uri - optparse-applicative - pem - process - proto-lens - protobuf - QuickCheck - quickcheck-instances - random - retry - saml2-web-sso - schema-profunctor - servant-client - servant-client-core - servant-server - singletons - sop-core - ssl-util - streaming-commons - tagged - tasty - tasty-ant-xml - tasty-cannon - tasty-hunit - temporary - text - time - tinylog - transformers - types-common - types-common-aws - types-common-journal - unix - unliftio - unordered-containers - uuid - vector - wai - wai-extra - wai-utilities - warp - warp-tls - wire-api - wire-api-federation - yaml + aeson aeson-qq async base base64-bytestring bilge binary brig-types + bytestring bytestring-conversion call-stack case-insensitive + cassandra-util cassava cereal conduit containers cookie + currency-codes data-default data-timeout errors exceptions extended + extra federator filepath galley-types HsOpenSSL hspec http-api-data + http-client http-client-openssl http-client-tls http-media + http-types imports kan-extensions lens lens-aeson memory + metrics-wai mtl network network-uri optparse-applicative pem + process proto-lens protobuf QuickCheck quickcheck-instances random + retry saml2-web-sso schema-profunctor servant-client + servant-client-core servant-server singletons sop-core ssl-util + streaming-commons tagged tasty tasty-ant-xml tasty-cannon + tasty-hunit temporary text time tinylog transformers types-common + types-common-aws types-common-journal unix unliftio + unordered-containers uuid vector wai wai-extra wai-utilities warp + warp-tls wire-api wire-api-federation yaml ]; testHaskellDepends = [ - base - containers - extra - galley-types - imports - lens - polysemy - polysemy-wire-zoo - QuickCheck - tasty - tasty-hunit - tasty-quickcheck - types-common - uuid-types - wire-api - wire-api-federation + base containers extra galley-types imports lens polysemy + polysemy-wire-zoo QuickCheck tasty tasty-hunit tasty-quickcheck + types-common uuid-types wire-api wire-api-federation ]; description = "Conversations"; license = lib.licenses.agpl3Only; diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index ddf49dc9fa..752401d397 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -2,83 +2,21 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-pretty -, amazonka -, amazonka-core -, amazonka-sns -, amazonka-sqs -, async -, attoparsec -, auto-update -, base -, base16-bytestring -, bilge -, bytestring -, bytestring-conversion -, cassandra-util -, containers -, criterion -, data-default -, errors -, exceptions -, extended -, extra -, gitignoreSource -, gundeck-types -, hedis -, HsOpenSSL -, http-client -, http-client-tls -, http-types -, imports -, kan-extensions -, lens -, lens-aeson -, lib -, metrics-core -, metrics-wai -, MonadRandom -, mtl -, multiset -, network -, network-uri -, optparse-applicative -, psqueues -, QuickCheck -, quickcheck-instances -, quickcheck-state-machine -, random -, raw-strings-qq -, resourcet -, retry -, safe -, safe-exceptions -, scientific -, servant-server -, tagged -, tasty -, tasty-ant-xml -, tasty-hunit -, tasty-quickcheck -, text -, time -, tinylog -, tls -, types-common -, types-common-aws -, unliftio -, unordered-containers -, uuid -, wai -, wai-extra -, wai-middleware-gunzip -, wai-predicates -, wai-routing -, wai-utilities -, websockets -, wire-api +{ mkDerivation, aeson, aeson-pretty, amazonka, amazonka-core +, amazonka-sns, amazonka-sqs, async, attoparsec, auto-update, base +, base16-bytestring, bilge, bytestring, bytestring-conversion +, cassandra-util, containers, criterion, data-default, errors +, exceptions, extended, extra, gitignoreSource, gundeck-types +, hedis, HsOpenSSL, http-client, http-client-tls, http-types +, imports, kan-extensions, lens, lens-aeson, lib, metrics-core +, metrics-wai, MonadRandom, mtl, multiset, network, network-uri +, optparse-applicative, psqueues, QuickCheck, quickcheck-instances +, quickcheck-state-machine, random, raw-strings-qq, resourcet +, retry, safe, safe-exceptions, scientific, servant-server, tagged +, tasty, tasty-ant-xml, tasty-hunit, tasty-quickcheck, text, time +, tinylog, tls, types-common, types-common-aws, unliftio +, unordered-containers, uuid, wai, wai-extra, wai-middleware-gunzip +, wai-predicates, wai-routing, wai-utilities, websockets, wire-api , yaml }: mkDerivation { @@ -88,143 +26,37 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - amazonka - amazonka-core - amazonka-sns - amazonka-sqs - async - attoparsec - auto-update - base - bilge - bytestring - bytestring-conversion - cassandra-util - containers - data-default - errors - exceptions - extended - extra - gundeck-types - hedis - http-client - http-client-tls - http-types - imports - lens - lens-aeson - metrics-core - metrics-wai - mtl - network-uri - psqueues - raw-strings-qq - resourcet - retry - safe-exceptions - servant-server - text - time - tinylog - tls - types-common - types-common-aws - unliftio - unordered-containers - uuid - wai - wai-extra - wai-middleware-gunzip - wai-predicates - wai-routing - wai-utilities - wire-api - yaml + aeson amazonka amazonka-core amazonka-sns amazonka-sqs async + attoparsec auto-update base bilge bytestring bytestring-conversion + cassandra-util containers data-default errors exceptions extended + extra gundeck-types hedis http-client http-client-tls http-types + imports lens lens-aeson metrics-core metrics-wai mtl network-uri + psqueues raw-strings-qq resourcet retry safe-exceptions + servant-server text time tinylog tls types-common types-common-aws + unliftio unordered-containers uuid wai wai-extra + wai-middleware-gunzip wai-predicates wai-routing wai-utilities + wire-api yaml ]; executableHaskellDepends = [ - aeson - async - base - base16-bytestring - bilge - bytestring - bytestring-conversion - cassandra-util - containers - exceptions - gundeck-types - HsOpenSSL - http-client - http-client-tls - imports - kan-extensions - lens - lens-aeson - metrics-wai - network - network-uri - optparse-applicative - random - retry - safe - tagged - tasty - tasty-ant-xml - tasty-hunit - text - tinylog - types-common - uuid - wai-utilities - websockets - wire-api - yaml + aeson async base base16-bytestring bilge bytestring + bytestring-conversion cassandra-util containers exceptions + gundeck-types HsOpenSSL http-client http-client-tls imports + kan-extensions lens lens-aeson metrics-wai network network-uri + optparse-applicative random retry safe tagged tasty tasty-ant-xml + tasty-hunit text tinylog types-common uuid wai-utilities websockets + wire-api yaml ]; testHaskellDepends = [ - aeson - aeson-pretty - amazonka - async - base - containers - exceptions - gundeck-types - HsOpenSSL - imports - lens - metrics-wai - MonadRandom - mtl - multiset - network-uri - QuickCheck - quickcheck-instances - quickcheck-state-machine - scientific - tasty - tasty-hunit - tasty-quickcheck - text - time - tinylog - types-common - wai-utilities + aeson aeson-pretty amazonka async base containers exceptions + gundeck-types HsOpenSSL imports lens metrics-wai MonadRandom mtl + multiset network-uri QuickCheck quickcheck-instances + quickcheck-state-machine scientific tasty tasty-hunit + tasty-quickcheck text time tinylog types-common wai-utilities wire-api ]; benchmarkHaskellDepends = [ - amazonka - base - criterion - gundeck-types - HsOpenSSL - imports - lens - random - text - types-common - uuid + amazonka base criterion gundeck-types HsOpenSSL imports lens random + text types-common uuid ]; description = "Push Notification Hub"; license = lib.licenses.agpl3Only; diff --git a/services/proxy/default.nix b/services/proxy/default.nix index e3301202ba..7d33a03398 100644 --- a/services/proxy/default.nix +++ b/services/proxy/default.nix @@ -2,35 +2,12 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bilge -, bytestring -, case-insensitive -, configurator -, data-default -, exceptions -, extended -, gitignoreSource -, http-client -, http-client-tls -, http-reverse-proxy -, http-types -, imports -, lens -, lib -, metrics-wai -, retry -, text -, tinylog -, types-common -, unliftio-core -, wai -, wai-predicates -, wai-routing -, wai-utilities -, wire-api +{ mkDerivation, aeson, base, bilge, bytestring, case-insensitive +, configurator, data-default, exceptions, extended, gitignoreSource +, http-client, http-client-tls, http-reverse-proxy, http-types +, imports, lens, lib, metrics-wai, retry, text, tinylog +, types-common, unliftio-core, wai, wai-predicates, wai-routing +, wai-utilities, wire-api }: mkDerivation { pname = "proxy"; @@ -39,32 +16,11 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - base - bilge - bytestring - case-insensitive - configurator - data-default - exceptions - extended - http-client - http-client-tls - http-reverse-proxy - http-types - imports - lens - metrics-wai - retry - text - tinylog - types-common - unliftio-core - wai - wai-predicates - wai-routing - wai-utilities - wire-api + aeson base bilge bytestring case-insensitive configurator + data-default exceptions extended http-client http-client-tls + http-reverse-proxy http-types imports lens metrics-wai retry text + tinylog types-common unliftio-core wai wai-predicates wai-routing + wai-utilities wire-api ]; executableHaskellDepends = [ base imports types-common ]; license = lib.licenses.agpl3Only; diff --git a/services/spar/default.nix b/services/spar/default.nix index ffc27016e3..2c650a3fa4 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -2,83 +2,21 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-qq -, async -, base -, base64-bytestring -, bilge -, brig-types -, bytestring -, bytestring-conversion -, case-insensitive -, cassandra-util -, cassava -, conduit -, containers -, cookie -, cryptonite -, data-default -, email-validate -, exceptions -, extended -, galley-types -, gitignoreSource -, hscim -, HsOpenSSL -, hspec -, hspec-core -, hspec-discover -, hspec-junit-formatter -, hspec-wai -, http-api-data -, http-client -, http-types -, imports -, iso639 -, lens -, lens-aeson -, lib -, metrics-wai -, MonadRandom -, mtl -, network-uri -, openapi3 -, optparse-applicative -, polysemy -, polysemy-check -, polysemy-plugin -, polysemy-wire-zoo -, QuickCheck -, random -, raw-strings-qq -, retry -, saml2-web-sso -, servant -, servant-multipart -, servant-openapi3 -, servant-server -, silently -, tasty-hunit -, text -, text-latin1 -, time -, tinylog -, transformers -, types-common -, uri-bytestring -, uuid -, vector -, wai -, wai-extra -, wai-utilities -, warp -, wire-api -, x509 -, xml-conduit -, yaml -, zauth +{ mkDerivation, aeson, aeson-qq, async, base, base64-bytestring +, bilge, brig-types, bytestring, bytestring-conversion +, case-insensitive, cassandra-util, cassava, conduit, containers +, cookie, cryptonite, data-default, email-validate, exceptions +, extended, galley-types, gitignoreSource, hscim, HsOpenSSL, hspec +, hspec-core, hspec-discover, hspec-junit-formatter, hspec-wai +, http-api-data, http-client, http-types, imports, iso639, lens +, lens-aeson, lib, metrics-wai, MonadRandom, mtl, network-uri +, openapi3, optparse-applicative, polysemy, polysemy-check +, polysemy-plugin, polysemy-wire-zoo, QuickCheck, random +, raw-strings-qq, retry, saml2-web-sso, servant, servant-multipart +, servant-openapi3, servant-server, silently, tasty-hunit, text +, text-latin1, time, tinylog, transformers, types-common +, uri-bytestring, uuid, vector, wai, wai-extra, wai-utilities, warp +, wire-api, x509, xml-conduit, yaml, zauth }: mkDerivation { pname = "spar"; @@ -87,150 +25,36 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - base - base64-bytestring - bilge - brig-types - bytestring - bytestring-conversion - case-insensitive - cassandra-util - containers - cookie - cryptonite - data-default - exceptions - extended - galley-types - hscim - hspec - http-types - imports - lens - metrics-wai - mtl - network-uri - optparse-applicative - polysemy - polysemy-check - polysemy-plugin - polysemy-wire-zoo - QuickCheck - raw-strings-qq - saml2-web-sso - servant-multipart - servant-server - text - text-latin1 - time - tinylog - transformers - types-common - uri-bytestring - uuid - wai - wai-utilities - warp - wire-api - x509 - yaml + aeson base base64-bytestring bilge brig-types bytestring + bytestring-conversion case-insensitive cassandra-util containers + cookie cryptonite data-default exceptions extended galley-types + hscim hspec http-types imports lens metrics-wai mtl network-uri + optparse-applicative polysemy polysemy-check polysemy-plugin + polysemy-wire-zoo QuickCheck raw-strings-qq saml2-web-sso + servant-multipart servant-server text text-latin1 time tinylog + transformers types-common uri-bytestring uuid wai wai-utilities + warp wire-api x509 yaml ]; executableHaskellDepends = [ - aeson - aeson-qq - async - base - base64-bytestring - bilge - brig-types - bytestring - bytestring-conversion - case-insensitive - cassandra-util - cassava - conduit - containers - cookie - cryptonite - email-validate - exceptions - extended - galley-types - hscim - HsOpenSSL - hspec - hspec-core - hspec-junit-formatter - hspec-wai - http-api-data - http-client - http-types - imports - iso639 - lens - lens-aeson - MonadRandom - mtl - optparse-applicative - polysemy - polysemy-plugin - polysemy-wire-zoo - QuickCheck - random - raw-strings-qq - retry - saml2-web-sso - servant - servant-server - silently - tasty-hunit - text - time - tinylog - transformers - types-common - uri-bytestring - uuid - vector - wai-extra - wai-utilities - warp - wire-api - xml-conduit - yaml - zauth + aeson aeson-qq async base base64-bytestring bilge brig-types + bytestring bytestring-conversion case-insensitive cassandra-util + cassava conduit containers cookie cryptonite email-validate + exceptions extended galley-types hscim HsOpenSSL hspec hspec-core + hspec-junit-formatter hspec-wai http-api-data http-client + http-types imports iso639 lens lens-aeson MonadRandom mtl + optparse-applicative polysemy polysemy-plugin polysemy-wire-zoo + QuickCheck random raw-strings-qq retry saml2-web-sso servant + servant-server silently tasty-hunit text time tinylog transformers + types-common uri-bytestring uuid vector wai-extra wai-utilities + warp wire-api xml-conduit yaml zauth ]; executableToolDepends = [ hspec-discover ]; testHaskellDepends = [ - aeson - aeson-qq - base - brig-types - bytestring-conversion - cookie - hscim - hspec - imports - lens - lens-aeson - metrics-wai - mtl - network-uri - openapi3 - polysemy - polysemy-plugin - polysemy-wire-zoo - QuickCheck - saml2-web-sso - servant - servant-openapi3 - time - tinylog - types-common - uri-bytestring - uuid - wire-api + aeson aeson-qq base brig-types bytestring-conversion cookie hscim + hspec imports lens lens-aeson metrics-wai mtl network-uri openapi3 + polysemy polysemy-plugin polysemy-wire-zoo QuickCheck saml2-web-sso + servant servant-openapi3 time tinylog types-common uri-bytestring + uuid wire-api ]; testToolDepends = [ hspec-discover ]; description = "User Service for SSO (Single Sign-On) provisioning and authentication"; diff --git a/tools/db/assets/default.nix b/tools/db/assets/default.nix index 05c5497cc4..dec1ceaba7 100644 --- a/tools/db/assets/default.nix +++ b/tools/db/assets/default.nix @@ -2,21 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, attoparsec -, base -, bytestring-conversion -, cassandra-util -, conduit -, gitignoreSource -, imports -, lens -, lib -, optparse-applicative -, text -, tinylog -, types-common -, wire-api +{ mkDerivation, attoparsec, base, bytestring-conversion +, cassandra-util, conduit, gitignoreSource, imports, lens, lib +, optparse-applicative, text, tinylog, types-common, wire-api }: mkDerivation { pname = "assets"; @@ -25,17 +13,8 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - attoparsec - base - bytestring-conversion - cassandra-util - conduit - imports - lens - optparse-applicative - text - tinylog - types-common + attoparsec base bytestring-conversion cassandra-util conduit + imports lens optparse-applicative text tinylog types-common wire-api ]; executableHaskellDepends = [ base ]; diff --git a/tools/db/auto-whitelist/default.nix b/tools/db/auto-whitelist/default.nix index d749f584c9..c1fa285838 100644 --- a/tools/db/auto-whitelist/default.nix +++ b/tools/db/auto-whitelist/default.nix @@ -2,19 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, cassandra-util -, extra -, gitignoreSource -, imports -, lens -, lib -, optparse-applicative -, tinylog -, types-common -, unliftio -, wire-api +{ mkDerivation, base, cassandra-util, extra, gitignoreSource +, imports, lens, lib, optparse-applicative, tinylog, types-common +, unliftio, wire-api }: mkDerivation { pname = "auto-whitelist"; @@ -23,16 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - cassandra-util - extra - imports - lens - optparse-applicative - tinylog - types-common - unliftio - wire-api + base cassandra-util extra imports lens optparse-applicative tinylog + types-common unliftio wire-api ]; description = "Backfill service tables"; license = lib.licenses.agpl3Only; diff --git a/tools/db/find-undead/default.nix b/tools/db/find-undead/default.nix index 926bd90968..4ad610a591 100644 --- a/tools/db/find-undead/default.nix +++ b/tools/db/find-undead/default.nix @@ -2,23 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bloodhound -, cassandra-util -, conduit -, containers -, gitignoreSource -, http-client -, imports -, lens -, lib -, optparse-applicative -, text -, tinylog -, uuid -, wire-api +{ mkDerivation, aeson, base, bloodhound, cassandra-util, conduit +, containers, gitignoreSource, http-client, imports, lens, lib +, optparse-applicative, text, tinylog, uuid, wire-api }: mkDerivation { pname = "find-undead"; @@ -27,20 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - aeson - base - bloodhound - cassandra-util - conduit - containers - http-client - imports - lens - optparse-applicative - text - tinylog - uuid - wire-api + aeson base bloodhound cassandra-util conduit containers http-client + imports lens optparse-applicative text tinylog uuid wire-api ]; description = "Backfill billing_team_member table"; license = lib.licenses.agpl3Only; diff --git a/tools/db/inconsistencies/default.nix b/tools/db/inconsistencies/default.nix index 2ad3a98e5e..668bae4edb 100644 --- a/tools/db/inconsistencies/default.nix +++ b/tools/db/inconsistencies/default.nix @@ -2,23 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, brig -, bytestring -, cassandra-util -, conduit -, extended -, extra -, gitignoreSource -, imports -, lib -, optparse-applicative -, text -, tinylog -, types-common -, unliftio +{ mkDerivation, aeson, base, brig, bytestring, cassandra-util +, conduit, extended, extra, gitignoreSource, imports, lib +, optparse-applicative, text, tinylog, types-common, unliftio , wire-api }: mkDerivation { @@ -28,20 +14,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - aeson - base - brig - bytestring - cassandra-util - conduit - extended - extra - imports - optparse-applicative - text - tinylog - types-common - unliftio + aeson base brig bytestring cassandra-util conduit extended extra + imports optparse-applicative text tinylog types-common unliftio wire-api ]; description = "Find handles which belong to deleted users"; diff --git a/tools/db/migrate-sso-feature-flag/default.nix b/tools/db/migrate-sso-feature-flag/default.nix index d5fb6b1b20..6df60eb9eb 100644 --- a/tools/db/migrate-sso-feature-flag/default.nix +++ b/tools/db/migrate-sso-feature-flag/default.nix @@ -2,20 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, cassandra-util -, conduit -, galley -, gitignoreSource -, imports -, lens -, lib -, optparse-applicative -, tinylog -, types-common -, unliftio -, wire-api +{ mkDerivation, base, cassandra-util, conduit, galley +, gitignoreSource, imports, lens, lib, optparse-applicative +, tinylog, types-common, unliftio, wire-api }: mkDerivation { pname = "migrate-sso-feature-flag"; @@ -24,17 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - cassandra-util - conduit - galley - imports - lens - optparse-applicative - tinylog - types-common - unliftio - wire-api + base cassandra-util conduit galley imports lens + optparse-applicative tinylog types-common unliftio wire-api ]; description = "Backfill sso feature flag into teams that already have an IdP"; license = lib.licenses.agpl3Only; diff --git a/tools/db/move-team/default.nix b/tools/db/move-team/default.nix index 31fdb38ae6..ea18d4c6aa 100644 --- a/tools/db/move-team/default.nix +++ b/tools/db/move-team/default.nix @@ -2,32 +2,11 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bytestring -, cassandra-util -, conduit -, containers -, filepath -, galley -, gitignoreSource -, imports -, iproute -, lens -, lib -, megaparsec -, optparse-applicative -, process -, raw-strings-qq -, stache -, text -, time -, tinylog -, types-common -, uuid -, vector -, wire-api +{ mkDerivation, aeson, base, bytestring, cassandra-util, conduit +, containers, filepath, galley, gitignoreSource, imports, iproute +, lens, lib, megaparsec, optparse-applicative, process +, raw-strings-qq, stache, text, time, tinylog, types-common, uuid +, vector, wire-api }: mkDerivation { pname = "move-team"; @@ -36,40 +15,14 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - base - bytestring - cassandra-util - conduit - containers - filepath - galley - imports - iproute - lens - megaparsec - optparse-applicative - process - raw-strings-qq - stache - text - time - tinylog - types-common - uuid - vector + aeson base bytestring cassandra-util conduit containers filepath + galley imports iproute lens megaparsec optparse-applicative process + raw-strings-qq stache text time tinylog types-common uuid vector wire-api ]; executableHaskellDepends = [ - base - cassandra-util - imports - lens - optparse-applicative - process - tinylog - types-common - uuid + base cassandra-util imports lens optparse-applicative process + tinylog types-common uuid ]; description = "Export a team from one backend, or import it into another"; license = lib.licenses.agpl3Only; diff --git a/tools/db/repair-brig-clients-table/default.nix b/tools/db/repair-brig-clients-table/default.nix index ea9dcfe43c..76f9b76074 100644 --- a/tools/db/repair-brig-clients-table/default.nix +++ b/tools/db/repair-brig-clients-table/default.nix @@ -2,17 +2,8 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, cassandra-util -, conduit -, gitignoreSource -, imports -, lens -, lib -, optparse-applicative -, time -, tinylog +{ mkDerivation, base, cassandra-util, conduit, gitignoreSource +, imports, lens, lib, optparse-applicative, time, tinylog , types-common }: mkDerivation { @@ -22,15 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - cassandra-util - conduit - imports - lens - optparse-applicative - time - tinylog - types-common + base cassandra-util conduit imports lens optparse-applicative time + tinylog types-common ]; description = "Removes and reports entries from brig.clients that have been accidentally upserted."; license = lib.licenses.agpl3Only; diff --git a/tools/db/repair-handles/default.nix b/tools/db/repair-handles/default.nix index c97deb7b45..fbf4216050 100644 --- a/tools/db/repair-handles/default.nix +++ b/tools/db/repair-handles/default.nix @@ -2,22 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, brig -, cassandra-util -, conduit -, containers -, gitignoreSource -, imports -, lens -, lib -, mtl -, optparse-applicative -, text -, tinylog -, types-common -, uuid +{ mkDerivation, base, brig, cassandra-util, conduit, containers +, gitignoreSource, imports, lens, lib, mtl, optparse-applicative +, text, tinylog, types-common, uuid }: mkDerivation { pname = "repair-handles"; @@ -26,19 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - brig - cassandra-util - conduit - containers - imports - lens - mtl - optparse-applicative - text - tinylog - types-common - uuid + base brig cassandra-util conduit containers imports lens mtl + optparse-applicative text tinylog types-common uuid ]; description = "Repair inconsistencies between tables user and user_handle"; license = lib.licenses.agpl3Only; diff --git a/tools/db/service-backfill/default.nix b/tools/db/service-backfill/default.nix index c778afe2db..44a13363d2 100644 --- a/tools/db/service-backfill/default.nix +++ b/tools/db/service-backfill/default.nix @@ -2,19 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, cassandra-util -, conduit -, gitignoreSource -, imports -, lens -, lib -, optparse-applicative -, tinylog -, types-common -, unliftio -, wire-api +{ mkDerivation, base, cassandra-util, conduit, gitignoreSource +, imports, lens, lib, optparse-applicative, tinylog, types-common +, unliftio, wire-api }: mkDerivation { pname = "service-backfill"; @@ -23,16 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - cassandra-util - conduit - imports - lens - optparse-applicative - tinylog - types-common - unliftio - wire-api + base cassandra-util conduit imports lens optparse-applicative + tinylog types-common unliftio wire-api ]; description = "Backfill service tables"; license = lib.licenses.agpl3Only; diff --git a/tools/fedcalls/default.nix b/tools/fedcalls/default.nix index f1738ca4df..9ae8764d73 100644 --- a/tools/fedcalls/default.nix +++ b/tools/fedcalls/default.nix @@ -2,17 +2,8 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, containers -, gitignoreSource -, imports -, language-dot -, lens -, lib -, mtl -, servant -, wire-api +{ mkDerivation, base, containers, gitignoreSource, imports +, language-dot, lens, lib, mtl, servant, wire-api }: mkDerivation { pname = "fedcalls"; @@ -21,14 +12,7 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - containers - imports - language-dot - lens - mtl - servant - wire-api + base containers imports language-dot lens mtl servant wire-api ]; description = "Generate a dot file from swagger docs representing calls to federated instances"; license = lib.licenses.agpl3Only; diff --git a/tools/mlsstats/default.nix b/tools/mlsstats/default.nix index 7c8c906810..fdc805d838 100644 --- a/tools/mlsstats/default.nix +++ b/tools/mlsstats/default.nix @@ -2,28 +2,11 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, amazonka -, amazonka-s3 -, base -, base64-bytestring -, bytestring -, cassandra-util -, conduit -, filepath -, gitignoreSource -, http-types -, imports -, lens -, lib -, optparse-applicative -, schema-profunctor -, text -, time -, tinylog -, types-common -, wire-api +{ mkDerivation, aeson, amazonka, amazonka-s3, base +, base64-bytestring, bytestring, cassandra-util, conduit, filepath +, gitignoreSource, http-types, imports, lens, lib +, optparse-applicative, schema-profunctor, text, time, tinylog +, types-common, wire-api }: mkDerivation { pname = "mlsstats"; @@ -32,25 +15,10 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - amazonka - amazonka-s3 - base - base64-bytestring - bytestring - cassandra-util - conduit - filepath - http-types - imports - lens - optparse-applicative - schema-profunctor - text - time - tinylog - types-common - wire-api + aeson amazonka amazonka-s3 base base64-bytestring bytestring + cassandra-util conduit filepath http-types imports lens + optparse-applicative schema-profunctor text time tinylog + types-common wire-api ]; executableHaskellDepends = [ base imports optparse-applicative ]; license = lib.licenses.agpl3Only; diff --git a/tools/rabbitmq-consumer/default.nix b/tools/rabbitmq-consumer/default.nix index 1da708042e..49362b3281 100644 --- a/tools/rabbitmq-consumer/default.nix +++ b/tools/rabbitmq-consumer/default.nix @@ -2,21 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, aeson-pretty -, amqp -, base -, bytestring -, gitignoreSource -, imports -, lib -, network -, optparse-applicative -, text -, types-common -, wire-api -, wire-api-federation +{ mkDerivation, aeson, aeson-pretty, amqp, base, bytestring +, gitignoreSource, imports, lib, network, optparse-applicative +, text, types-common, wire-api, wire-api-federation }: mkDerivation { pname = "rabbitmq-consumer"; @@ -25,18 +13,8 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - aeson-pretty - amqp - base - bytestring - imports - network - optparse-applicative - text - types-common - wire-api - wire-api-federation + aeson aeson-pretty amqp base bytestring imports network + optparse-applicative text types-common wire-api wire-api-federation ]; executableHaskellDepends = [ base ]; description = "CLI tool to consume messages from a RabbitMQ queue"; diff --git a/tools/rex/default.nix b/tools/rex/default.nix index 02d05d765d..240f1220f1 100644 --- a/tools/rex/default.nix +++ b/tools/rex/default.nix @@ -2,27 +2,10 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, async -, attoparsec -, base -, bytestring -, clock -, dns -, exceptions -, gitignoreSource -, http-types -, iproute -, lib -, mtl -, network -, optparse-applicative -, prometheus -, text -, tinylog -, unordered-containers -, wai -, warp +{ mkDerivation, async, attoparsec, base, bytestring, clock, dns +, exceptions, gitignoreSource, http-types, iproute, lib, mtl +, network, optparse-applicative, prometheus, text, tinylog +, unordered-containers, wai, warp }: mkDerivation { pname = "rex"; @@ -31,24 +14,9 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - async - attoparsec - base - bytestring - clock - dns - exceptions - http-types - iproute - mtl - network - optparse-applicative - prometheus - text - tinylog - unordered-containers - wai - warp + async attoparsec base bytestring clock dns exceptions http-types + iproute mtl network optparse-applicative prometheus text tinylog + unordered-containers wai warp ]; description = "Scrape and expose restund metrics for prometheus"; license = lib.licenses.agpl3Only; diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 2c5867d329..ae0958f790 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -2,57 +2,16 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bilge -, brig-types -, bytestring -, bytestring-conversion -, containers -, cookie -, data-default -, errors -, exceptions -, extended -, extra -, galley-types -, gitignoreSource -, HsOpenSSL -, http-client -, http-client-tls -, http-types -, imports -, lens -, lens-aeson -, lib -, metrics-wai -, mtl -, openapi3 -, optparse-applicative -, random -, retry -, schema-profunctor -, servant -, servant-openapi3 -, servant-server -, servant-swagger-ui -, split -, tagged -, tasty -, tasty-ant-xml -, tasty-hunit -, text -, tinylog -, transformers -, types-common -, unliftio -, uuid -, wai -, wai-routing -, wai-utilities -, wire-api -, yaml +{ mkDerivation, aeson, base, bilge, brig-types, bytestring +, bytestring-conversion, containers, cookie, data-default, errors +, exceptions, extended, extra, galley-types, gitignoreSource +, HsOpenSSL, http-client, http-client-tls, http-types, imports +, lens, lens-aeson, lib, metrics-wai, mtl, openapi3 +, optparse-applicative, random, retry, schema-profunctor, servant +, servant-openapi3, servant-server, servant-swagger-ui, split +, tagged, tasty, tasty-ant-xml, tasty-hunit, text, tinylog +, transformers, types-common, unliftio, uuid, wai, wai-routing +, wai-utilities, wire-api, yaml }: mkDerivation { pname = "stern"; @@ -61,73 +20,19 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson - base - bilge - brig-types - bytestring - bytestring-conversion - containers - data-default - errors - exceptions - extended - galley-types - http-client - http-types - imports - lens - metrics-wai - mtl - openapi3 - schema-profunctor - servant - servant-openapi3 - servant-server - servant-swagger-ui - split - text - tinylog - transformers - types-common - unliftio - uuid - wai - wai-routing - wai-utilities - wire-api - yaml + aeson base bilge brig-types bytestring bytestring-conversion + containers data-default errors exceptions extended galley-types + http-client http-types imports lens metrics-wai mtl openapi3 + schema-profunctor servant servant-openapi3 servant-server + servant-swagger-ui split text tinylog transformers types-common + unliftio uuid wai wai-routing wai-utilities wire-api yaml ]; executableHaskellDepends = [ - aeson - base - bilge - brig-types - bytestring-conversion - containers - cookie - exceptions - extra - HsOpenSSL - http-client - http-client-tls - imports - lens - lens-aeson - optparse-applicative - random - retry - schema-profunctor - tagged - tasty - tasty-ant-xml - tasty-hunit - text - tinylog - types-common - uuid - wire-api - yaml + aeson base bilge brig-types bytestring-conversion containers cookie + exceptions extra HsOpenSSL http-client http-client-tls imports lens + lens-aeson optparse-applicative random retry schema-profunctor + tagged tasty tasty-ant-xml tasty-hunit text tinylog types-common + uuid wire-api yaml ]; testHaskellDepends = [ base tasty tasty-hunit wire-api ]; license = lib.licenses.agpl3Only; diff --git a/tools/test-stats/default.nix b/tools/test-stats/default.nix index fe6dee90c2..18377bb34c 100644 --- a/tools/test-stats/default.nix +++ b/tools/test-stats/default.nix @@ -2,19 +2,9 @@ # This file is generated by running hack/bin/generate-local-nix-packages.sh and # must be regenerated whenever local packages are added or removed, or # dependencies are added or removed. -{ mkDerivation -, base -, bytestring -, gitignoreSource -, imports -, lib -, monoidal-containers -, optparse-generic -, postgresql-simple -, prometheus-client -, text -, time -, xml +{ mkDerivation, base, bytestring, gitignoreSource, imports, lib +, monoidal-containers, optparse-generic, postgresql-simple +, prometheus-client, text, time, xml }: mkDerivation { pname = "test-stats"; @@ -23,16 +13,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base - bytestring - imports - monoidal-containers - optparse-generic - postgresql-simple - prometheus-client - text - time - xml + base bytestring imports monoidal-containers optparse-generic + postgresql-simple prometheus-client text time xml ]; description = "Test run statistics"; license = lib.licenses.agpl3Only; From 8c53d14daac3749df29fb352d9a6e1850f333f36 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Thu, 16 Nov 2023 17:17:15 +1000 Subject: [PATCH 02/22] WPB-5382: WIP, getting the code into shape, lots of errors to go --- integration/test/API/Cargohold.hs | 73 +--- integration/test/Test/Cargohold.hs | 15 - integration/test/Test/Cargohold/API.hs | 63 +--- .../test/Test/Cargohold/API/Federation.hs | 41 ++- integration/test/Test/Cargohold/API/Util.hs | 328 +++++++++--------- integration/test/Test/Cargohold/API/V3.hs | 43 ++- integration/test/Test/Cargohold/App.hs | 6 +- integration/test/Test/Cargohold/Metrics.hs | 3 +- integration/test/Testlib/HTTP.hs | 3 + 9 files changed, 241 insertions(+), 334 deletions(-) diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index 0224f6b4d3..44b235b266 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -10,12 +10,12 @@ import Data.Text.Encoding import Data.Time.Clock import GHC.Stack import Network.HTTP.Client qualified as HTTP +import Test.Cargohold.API.Util import Testlib.Prelude -import Wire.API.Asset (AssetRetention, assetRetentionSeconds) type LByteString = LBS.ByteString -uploadAssetV3 :: (HasCallStack, MakesValue user) => user -> Bool -> AssetRetention -> MIME.MIMEType -> LByteString -> App Response +uploadAssetV3 :: (HasCallStack, MakesValue user) => user -> Bool -> Maybe NominalDiffTime -> MIME.MIMEType -> LByteString -> App Response uploadAssetV3 user isPublic retention mimeType bdy = do uid <- user & objId req <- baseRequest user Cargohold (ExplicitVersion 1) "/assets/v3" @@ -24,8 +24,7 @@ uploadAssetV3 user isPublic retention mimeType bdy = do & zUser uid & addBody body multipartMixedMime where - ret = assetRetentionSeconds retention - body = buildUploadAssetRequestBody isPublic ret bdy mimeType + body = buildUploadAssetRequestBody isPublic retention bdy mimeType multipartMixedMime :: String multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary @@ -71,72 +70,6 @@ buildUploadAssetRequestBody isPublic mbRetention body mimeType = multipartBoundary :: String multipartBoundary = "frontier" --- | Build a complete @multipart/mixed@ request body for a one-shot, --- non-resumable asset upload. -buildMultipartBody :: Aeson.Value -> LByteString -> MIME.MIMEType -> HTTP.RequestBody -buildMultipartBody header body bodyMimeType = - HTTP.RequestBodyLBS . toLazyByteString $ render - where - headerJson = Aeson.encode header - - render :: Builder - render = renderBody <> endMultipartBody - - endMultipartBody :: Builder - endMultipartBody = lineBreak <> boundary <> stringUtf8 "--" <> lineBreak - - renderBody :: Builder - renderBody = mconcat $ map renderPart multipartContent - - renderPart :: MIME.MIMEValue -> Builder - renderPart v = - boundary - <> lineBreak - <> (contentType . MIME.mime_val_type) v - <> lineBreak - <> (headers . MIME.mime_val_headers) v - <> lineBreak - <> lineBreak - <> (content . MIME.mime_val_content) v - <> lineBreak - - boundary :: Builder - boundary = stringUtf8 "--" <> stringUtf8 multipartBoundary - - lineBreak :: Builder - lineBreak = stringUtf8 "\r\n" - - contentType :: MIME.Type -> Builder - contentType t = stringUtf8 "Content-Type: " <> (encodeUtf8Builder . MIME.showType) t - - headers :: [MIME.MIMEParam] -> Builder - headers [] = mempty - headers (x : xs) = renderHeader x <> headers xs - - renderHeader :: MIME.MIMEParam -> Builder - renderHeader p = - encodeUtf8Builder (MIME.paramName p) - <> stringUtf8 ": " - <> encodeUtf8Builder (MIME.paramValue p) - - content :: MIME.MIMEContent -> Builder - content (MIME.Single c) = encodeUtf8Builder c - content (MIME.Multi _) = error "Not implemented." - - multipartContent :: [MIME.MIMEValue] - multipartContent = - [ part (MIME.Application (T.pack "json")) headerJson, - part bodyMimeType body - ] - - part :: MIME.MIMEType -> LByteString -> MIME.MIMEValue - part mtype c = - MIME.nullMIMEValue - { MIME.mime_val_type = MIME.Type mtype [], - MIME.mime_val_headers = [MIME.MIMEParam (T.pack "Content-Length") ((T.pack . show . LBS.length) c)], - MIME.mime_val_content = MIME.Single ((decodeUtf8 . LBS.toStrict) c) - } - downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response downloadAsset user assetDomain key zHostHeader trans = do uid <- objId user diff --git a/integration/test/Test/Cargohold.hs b/integration/test/Test/Cargohold.hs index 3c59eaeebe..bc30b8b271 100644 --- a/integration/test/Test/Cargohold.hs +++ b/integration/test/Test/Cargohold.hs @@ -1,16 +1 @@ module Test.Cargohold where - -import API.Brig -import API.Brig qualified as API -import API.Gundeck -import Control.Lens hiding ((.=)) -import Control.Monad.Codensity -import Control.Monad.Reader -import Data.Aeson hiding ((.=)) -import Data.ProtoLens.Labels () -import Data.Time.Clock.POSIX -import Data.Time.Clock.System -import Data.Time.Format -import SetupHelpers -import Testlib.Prelude -import Testlib.ResourcePool diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index ff390950c3..50cd6db6e0 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -37,57 +37,10 @@ import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types qualified as HTTP import Testlib.Prelude import Testlib.Types -import Wire.API.Asset qualified as V3 -------------------------------------------------------------------------------- -- Simple (single-step) uploads -testSimpleRoundtrip :: HasCallStack => App () -testSimpleRoundtrip = do - let def = V3.defAssetSettings - let rets = [minBound ..] - let sets = def : map (\r -> def & V3.setAssetRetention ?~ r) rets - mapM_ simpleRoundtrip sets - where - simpleRoundtrip sets = do - uid <- randomUser - uid2 <- liftIO $ Id <$> nextRandom - -- Initial upload - let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple (path "/assets/v3") uid sets bdy - lookup "Date" (responseHeaders r1) - let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime - -- Potentially check for the expires header - when (isJust $ V3.assetRetentionSeconds =<< (sets ^. V3.setAssetRetention)) $ do - liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) - -- Lookup with token and download via redirect. - r2 <- - downloadAsset uid loc (Just tok) lookup "Date" (responseHeaders r4) - let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime - liftIO $ assertBool "bad date" (utc' >= utc) - testDownloadWithAcceptHeader :: HasCallStack => App () testDownloadWithAcceptHeader = do assetId <- liftIO $ Id <$> nextRandom @@ -110,10 +63,11 @@ testSimpleTokens = do uploadSimple (path "/assets/v3") uid sets bdy r1.json %. "key" + <*> r1.json %. "token" + <*> r1.json %. "expires" -- No access without token from other user (opaque 404) downloadAsset uid2 loc () !!! const 404 @@ -205,8 +159,11 @@ testDownloadURLOverride = do uploadRes.json %. "key" + <*> uploadRes.json %. "token" + <*> uploadRes.json %. "expires" -- Lookup with token and get download URL. Should return the -- S3DownloadEndpoint, but not try to use it. diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs index a693a50e42..c60d93301e 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -17,26 +17,25 @@ module Test.Cargohold.API.Federation where -import Test.Cargohold.API.Util -import Control.Lens -import Crypto.Random -import Data.UUID.V4 import API.Brig qualified as BrigP import API.BrigInternal qualified as BrigI import API.Common qualified as API import API.GalleyInternal qualified as GalleyI import Control.Concurrent (threadDelay) +import Control.Lens +import Crypto.Random import Data.Aeson.Types hiding ((.=)) import Data.Set qualified as Set import Data.String.Conversions import Data.UUID qualified as UUID +import Data.UUID.V4 import Data.UUID.V4 qualified as UUID +import Data.Vector.Internal.Check (HasCallStack) import GHC.Stack import SetupHelpers +import Test.Cargohold.API.Util import Testlib.Assertions import Testlib.Prelude -import Data.Vector.Internal.Check (HasCallStack) -import Wire.API.Asset (AssetRetention(AssetVolatile)) testGetAssetAvailablePrivate :: HasCallStack => App () testGetAssetAvailablePrivate = getAssetAvailable False @@ -50,7 +49,8 @@ getAssetAvailable isPublicAsset = do ast :: Asset <- responseJsonError =<< uploadAssetV3 uid isPublicAsset (Just AssetVolatile) applicationOctetStream bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) + + -- check that asset is not available + liftIO $ ok @?= False + +testLargeAsset :: HasCallStack => App () +testLargeAsset = do + -- Initial upload + let settings = + defAssetSettings + & set setAssetRetention (Just AssetVolatile) + uid <- randomUser -- generate random bytes let size = 1024 * 1024 bs <- liftIO $ getRandomBytes size @@ -120,7 +130,8 @@ User ast :: Asset <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) - - (Request -> Request) -> - UserId -> - AssetSettings -> - (MIME.Type, ByteString) -> - App (Response (Maybe Lazy.ByteString)) -uploadSimple c usr sts (ct, bs) = - let mp = buildMultipartBody sts ct (Lazy.fromStrict bs) - in uploadRaw c usr (toLazyByteString mp) - -decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response b -> a +uploadSimple :: + (HasCallStack, MakesValue user, MakesValue settings) => + user -> + settings -> + (MIME.MIMEType, String) -> + App Response +uploadSimple usr sts (ct, bs) = + uploadRaw usr $ buildMultipartBody sts (Lazy8.pack bs) ct + +decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response -> a decodeHeaderOrFail h = fromMaybe (error $ "decodeHeaderOrFail: missing or invalid header: " ++ show h) . fromByteString . getHeader' h -uploadRaw :: HasCallStack => - (Request -> Request) -> - UserId -> +-- | Like 'getHeader', but if no value exists for the given key, return the +-- static ByteString \"NO_HEADER_VALUE\". +getHeader' :: HeaderName -> Response -> ByteString +getHeader' h = fromMaybe (cs "NO_HEADER_VALUE") . getHeader h + +getHeader :: HeaderName -> Response -> Maybe ByteString +getHeader h = fmap snd . find ((h ==) . fst) . headers + +uploadRaw :: + (HasCallStack, MakesValue user) => + user -> Lazy.ByteString -> - App (Response (Maybe Lazy.ByteString)) -uploadRaw c usr bs = do - cargohold' <- viewUnversionedCargohold - post $ - apiVersion "v1" - . c - . cargohold' - . method POST - . zUser usr - . zConn "conn" - . content "multipart/mixed" - . lbytes bs - -getContentType :: Response a -> Maybe MIME.Type -getContentType = MIME.parseContentType . decodeLatin1 . getHeader' "Content-Type" + App Response +uploadRaw usr bs = do + req <- baseRequest usr Cargohold (ExplicitVersion 1) "assets/v3" + submit "POST" $ + req + & contentTypeMixed + & (\r -> r {HTTP.requestBody = HTTP.RequestBodyLBS bs}) + +getContentType :: Response -> Maybe MIME.Type +getContentType = MIME.parseContentType . decodeLatin1 . getHeader' (cs "Content-Type") applicationText :: MIME.Type -applicationText = MIME.Type (MIME.Application "text") [] +applicationText = MIME.Type (MIME.Application $ cs "text") [] applicationOctetStream :: MIME.Type -applicationOctetStream = MIME.Type (MIME.Application "octet-stream") [] - -zUser :: UserId -> Request -> Request -zUser = header "Z-User" . UUID.toASCIIBytes . toUUID - -zConn :: ByteString -> Request -> Request -zConn = header "Z-Connection" - -deleteAssetV3 :: HasCallStack => UserId -> Qualified AssetKey -> App (Response (Maybe Lazy.ByteString)) -deleteAssetV3 u k = do - c <- viewUnversionedCargohold - delete $ apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] - -deleteAsset :: HasCallStack => UserId -> Qualified AssetKey -> App (Response (Maybe Lazy.ByteString)) -deleteAsset u k = do - c <- viewCargohold - delete $ - c - . zUser u - . paths - [ "assets", - toByteString' (qDomain k), - toByteString' (qUnqualified k) - ] - -class IsAssetLocation key where - locationPath :: key -> Request -> Request - -instance IsAssetLocation AssetKey where - locationPath k = - apiVersion "v1" - . paths ["assets", "v3", toByteString' k] - -instance IsAssetLocation (Qualified AssetKey) where - locationPath k = - apiVersion "v2" - . paths ["assets", toByteString' (qDomain k), toByteString' (qUnqualified k)] - -instance IsAssetLocation ByteString where - locationPath = path +applicationOctetStream = MIME.Type (MIME.Application $ cs "octet-stream") [] + +deleteAssetV3 :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response +deleteAssetV3 user key = do + k <- key %. "id" & asString + req <- baseRequest user Cargohold (ExplicitVersion 1) $ "assets/v3/" <> k + submit "DELETE" req + +deleteAsset :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response +deleteAsset user key = do + k <- key %. "id" & asString + d <- key %. "domain" & asString + req <- baseRequest user Cargohold Versioned $ "/assets/" <> d <> "/" <> show k + submit "DELETE" req class IsAssetToken tok where - tokenParam :: tok -> Request -> Request - -instance IsAssetToken () where - tokenParam _ = id - -instance IsAssetToken (Maybe AssetToken) where - tokenParam = maybe id (header "Asset-Token" . toByteString') - -instance IsAssetToken (Request -> Request) where - tokenParam = id - -downloadAssetWith :: - (HasCallStack, IsAssetLocation loc, IsAssetToken tok) => - (Request -> Request) -> - UserId -> - loc -> - tok -> - App (Response (Maybe LByteString)) -downloadAssetWith r uid loc tok = do - c <- viewUnversionedCargohold - get $ - c - . r - . zUser uid - . locationPath loc - . tokenParam tok - . noRedirect - -downloadAsset :: - (HasCallStack, IsAssetLocation loc, IsAssetToken tok) => - UserId -> - loc -> - tok -> - App (Response (Maybe LByteString)) -downloadAsset = downloadAssetWith id - -postToken :: HasCallStack => UserId -> AssetKey -> App (Response (Maybe LByteString)) -postToken uid key = do - c <- viewCargohold - post $ - c - . zUser uid - . paths ["assets", toByteString' key, "token"] - -deleteToken :: HasCallStack => UserId -> AssetKey -> App`` (Response (Maybe LByteString)) -deleteToken uid key = do - c <- viewCargohold - delete $ - c - . zUser uid - . paths ["assets", toByteString' key, "token"] - -viewFederationDomain :: HasCallStack => App Domain -viewFederationDomain = view (tsOpts . settings . federationDomain) - --------------------------------------------------------------------------------- --- Mocking utilities - -withSettingsOverrides :: HasCallStack => (Opts -> Opts) -> App a -> App a -withSettingsOverrides f action = do - ts <- ask - let opts = f (view tsOpts ts) - liftIO . lowerCodensity $ do - (app, _) <- mkApp opts - p <- withMockServer app - liftIO $ runTestM (ts & tsEndpoint %~ setLocalEndpoint p) action - -setLocalEndpoint :: Word16 -> Endpoint -> Endpoint -setLocalEndpoint p = (port .~ p) . (host .~ "127.0.0.1") - -withMockFederator :: HasCallStack => - (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> - App a -> - App (a, [FederatedRequest]) -withMockFederator respond action = do - withTempMockFederator [] respond $ \p -> - withSettingsOverrides - (federator . _Just %~ setLocalEndpoint (fromIntegral p)) - action + tokenParam :: tok -> HTTP.Request -> HTTP.Request + +instance IsAssetToken (Maybe String) where + tokenParam = maybe id (header "Asset-Token") + +header :: String -> Request -> Request +header name req = + req {requestHeaders = (cs name, _) : requestHeaders req} + +downloadAssetWithAssetKey :: + (HasCallStack, MakesValue user) => + (HTTP.Request -> HTTP.Request) -> + user -> + String -> + App Response +downloadAssetWithAssetKey r user tok = do + req <- baseRequest user Cargohold (ExplicitVersion 1) $ "asserts/v3/" <> tok + submit "GET" $ + req + & tokenParam tok + +downloadAssetWithQualifiedAssetKey :: + (HasCallStack, MakesValue tok, MakesValue user) => + (HTTP.Request -> HTTP.Request) -> + user -> + Maybe String -> + App Response +downloadAssetWithQualifiedAssetKey r user tok = do + dom <- tok %. "domain" & asString + key <- tok %. "id" & asString + req <- baseRequest user Cargohold (ExplicitVersion 2) $ "assets/" <> dom <> "/" <> key + submit "GET" $ + req + & tokenParam tok + +postToken :: (MakesValue user, HasCallStack) => user -> String -> App Response +postToken user key = do + req <- baseRequest user Cargohold Versioned $ "assets/" <> key <> "/token" + submit "POST" req + +deleteToken :: (MakesValue user, HasCallStack) => user -> String -> App Response +deleteToken user key = do + req <- baseRequest user Cargohold Versioned $ "asserts/" <> key <> "/token" + submit "DELETE" req + +-- | Build a complete @multipart/mixed@ request body for a one-shot, +-- non-resumable asset upload. +buildMultipartBody :: Value -> Lazy.ByteString -> MIME.MIMEType -> Lazy.ByteString +buildMultipartBody header body bodyMimeType = toLazyByteString render + where + headerJson = Aeson.encode header + + render :: Builder + render = renderBody <> endMultipartBody + + endMultipartBody :: Builder + endMultipartBody = lineBreak <> boundary <> stringUtf8 "--" <> lineBreak + + renderBody :: Builder + renderBody = mconcat $ map renderPart multipartContent + + renderPart :: MIME.MIMEValue -> Builder + renderPart v = + boundary + <> lineBreak + <> (contentType . MIME.mime_val_type) v + <> lineBreak + <> (headers . MIME.mime_val_headers) v + <> lineBreak + <> lineBreak + <> (content . MIME.mime_val_content) v + <> lineBreak + + boundary :: Builder + boundary = stringUtf8 "--" <> stringUtf8 multipartBoundary + + lineBreak :: Builder + lineBreak = stringUtf8 "\r\n" + + contentType :: MIME.Type -> Builder + contentType t = stringUtf8 "Content-Type: " <> (encodeUtf8Builder . MIME.showType) t + + headers :: [MIME.MIMEParam] -> Builder + headers [] = mempty + headers (x : xs) = renderHeader x <> headers xs + + renderHeader :: MIME.MIMEParam -> Builder + renderHeader p = + encodeUtf8Builder (MIME.paramName p) + <> stringUtf8 ": " + <> encodeUtf8Builder (MIME.paramValue p) + + content :: MIME.MIMEContent -> Builder + content (MIME.Single c) = encodeUtf8Builder c + content (MIME.Multi _) = error "Not implemented." + + multipartContent :: [MIME.MIMEValue] + multipartContent = + [ part (MIME.Application (T.pack "json")) headerJson, + part bodyMimeType body + ] + + part :: MIME.MIMEType -> Lazy.ByteString -> MIME.MIMEValue + part mtype c = + MIME.nullMIMEValue + { MIME.mime_val_type = MIME.Type mtype [], + MIME.mime_val_headers = [MIME.MIMEParam (T.pack "Content-Length") ((T.pack . show . LBS.length) c)], + MIME.mime_val_content = MIME.Single ((decodeUtf8 . LBS.toStrict) c) + } diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index c217dc6fa6..436dae2ebc 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -19,40 +19,46 @@ module Test.Cargohold.API.V3 where -import Control.Lens hiding (sets) -import qualified Data.ByteString.Char8 as C8 +import Control.Lens hiding (sets, (.=)) +import Data.ByteString.Char8 qualified as C8 import Data.Time.Clock import Data.Time.Format -import Data.UUID.V4 -import Network.HTTP.Client (parseUrlThrow) +import Network.HTTP.Client (parseUrlThrow, requestBody) import Network.HTTP.Types.Status (status200) -import Testlib.Types +import SetupHelpers +import Test.Cargohold.API.Util import Testlib.Prelude +import Testlib.Types -------------------------------------------------------------------------------- -- Simple (single-step) uploads testSimpleRoundtrip :: HasCallStack => App () testSimpleRoundtrip = do - let def = defAssetSettings - let rets = [minBound ..] - let sets = def : map (\r -> def & setAssetRetention ?~ r) rets + let defSettings = + [ "public" .= False + ] + let rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] + let sets = + fmap object $ + defSettings : map (\r -> defSettings <> ["retention" .= r]) rets mapM_ simpleRoundtrip sets where simpleRoundtrip sets = do - uid <- randomUser - uid2 <- liftIO $ Id <$> nextRandom + uid <- randomUser OwnDomain def + uid2 <- randomId -- Initial upload let bdy = (applicationText, "Hello World") r1 <- - uploadSimple (path "/assets/v3") uid sets bdy - r1.json %. "key" - <*> r1.json %. "token" - <*> r1.json %. "expires" - let key = qUnqualified qKey + (key, tok, expires) <- + (,,) + <$> r1.json %. "key" + <*> r1.json %. "token" + <*> r1.json %. "expires" -- Check mandatory Date header let Just date = C8.unpack <$> lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime @@ -77,7 +83,8 @@ testSimpleRoundtrip = do deleteAssetV3 uid key !!! const 200 === statusCode r4 <- downloadAsset uid key (Just tok) - lookup "Date" (responseHeaders r4) let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime liftIO $ assertBool "bad date" (utc' >= utc) diff --git a/integration/test/Test/Cargohold/App.hs b/integration/test/Test/Cargohold/App.hs index 24ef8236de..f35b903651 100644 --- a/integration/test/Test/Cargohold/App.hs +++ b/integration/test/Test/Cargohold/App.hs @@ -5,8 +5,8 @@ module Test.Cargohold.App where import Control.Exception import Control.Lens import Data.ByteString.Conversion -import qualified Data.Map as Map -import qualified Data.Text as T +import Data.Map qualified as Map +import Data.Text qualified as T import Testlib.Prelude testMultiIngressCloudFrontFails :: HasCallStack => App () @@ -43,7 +43,7 @@ multiIngressMap = toAWSEndpoint :: ByteString -> AWSEndpoint toAWSEndpoint = fromJust . fromByteString -testMultiIngressS3DownloadEndpointFails :: HasCallStack => App () +testMultiIngressS3DownloadEndpointFails :: HasCallStack => App () testMultiIngressS3DownloadEndpointFails = do ts <- ask let opts = diff --git a/integration/test/Test/Cargohold/Metrics.hs b/integration/test/Test/Cargohold/Metrics.hs index 6689b62c0a..c88d6cff92 100644 --- a/integration/test/Test/Cargohold/Metrics.hs +++ b/integration/test/Test/Cargohold/Metrics.hs @@ -16,8 +16,9 @@ -- with this program. If not, see . module Test.Cargohold.Metrics where -import Testlib.Prelude + import Data.String.Conversions +import Testlib.Prelude testPrometheusMetrics :: HasCallStack => App () testPrometheusMetrics = do diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 2227d43942..cd36db7fc4 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -79,6 +79,9 @@ addQueryParams params req = contentTypeJSON :: HTTP.Request -> HTTP.Request contentTypeJSON = addHeader "Content-Type" "application/json" +contentTypeMixed :: HTTP.Request -> HTTP.Request +contentTypeMixed = addHeader "Content-Type" "multipart/mixed" + bindResponse :: HasCallStack => App Response -> (Response -> App a) -> App a bindResponse m k = m >>= \r -> withResponse r k From 13511971904023aad8c98a47541ccb5db6fac1a5 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 17 Nov 2023 17:06:43 +1000 Subject: [PATCH 03/22] WPB-5382: More updates to the tests after wading through a sea of errors --- integration/test/API/Cargohold.hs | 58 ++++--- integration/test/SetupHelpers.hs | 7 + .../test/Test/Cargohold/API/Federation.hs | 130 +++++++------- integration/test/Test/Cargohold/API/Util.hs | 161 +++++++++--------- integration/test/Test/Cargohold/API/V3.hs | 88 +++++----- 5 files changed, 230 insertions(+), 214 deletions(-) diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index 44b235b266..a0db6a655a 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -2,29 +2,27 @@ module API.Cargohold where import Codec.MIME.Type qualified as MIME import Data.Aeson qualified as Aeson -import Data.ByteString.Builder import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBSC import Data.Text qualified as T -import Data.Text.Encoding -import Data.Time.Clock import GHC.Stack import Network.HTTP.Client qualified as HTTP import Test.Cargohold.API.Util import Testlib.Prelude +import UnliftIO (catch) type LByteString = LBS.ByteString -uploadAssetV3 :: (HasCallStack, MakesValue user) => user -> Bool -> Maybe NominalDiffTime -> MIME.MIMEType -> LByteString -> App Response +uploadAssetV3 :: (HasCallStack, MakesValue user, MakesValue assetRetention) => user -> Bool -> assetRetention -> MIME.MIMEType -> LByteString -> App Response uploadAssetV3 user isPublic retention mimeType bdy = do uid <- user & objId req <- baseRequest user Cargohold (ExplicitVersion 1) "/assets/v3" + body <- buildUploadAssetRequestBody isPublic retention bdy mimeType submit "POST" $ req & zUser uid & addBody body multipartMixedMime where - body = buildUploadAssetRequestBody isPublic retention bdy mimeType multipartMixedMime :: String multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary @@ -32,16 +30,17 @@ uploadAsset :: (HasCallStack, MakesValue user) => user -> App Response uploadAsset user = do uid <- user & objId req <- baseRequest user Cargohold Versioned "/assets" + bdy <- txtAsset submit "POST" $ req & zUser uid - & addBody txtAsset multipartMixedMime + & addBody bdy multipartMixedMime where - txtAsset :: HTTP.RequestBody + txtAsset :: HasCallStack => App HTTP.RequestBody txtAsset = buildUploadAssetRequestBody True - Nothing + (Nothing :: Maybe String) (LBSC.pack "Hello World!") textPlainMime @@ -56,28 +55,31 @@ uploadAsset user = do mimeTypeToString :: MIME.MIMEType -> String mimeTypeToString = T.unpack . MIME.showMIMEType -buildUploadAssetRequestBody :: Bool -> Maybe NominalDiffTime -> LByteString -> MIME.MIMEType -> HTTP.RequestBody -buildUploadAssetRequestBody isPublic mbRetention body mimeType = - buildMultipartBody header body mimeType - where - header :: Aeson.Value - header = - Aeson.object - [ "public" .= isPublic, - "retention" .= mbRetention - ] - -multipartBoundary :: String -multipartBoundary = "frontier" +buildUploadAssetRequestBody :: + (HasCallStack, MakesValue assetRetention) => + Bool -> + assetRetention -> + LByteString -> + MIME.MIMEType -> + App HTTP.RequestBody +buildUploadAssetRequestBody isPublic retention body mimeType = do + mbRetention <- make retention + let header' :: Aeson.Value + header' = + Aeson.object + [ "public" .= isPublic, + "retention" .= mbRetention + ] + HTTP.RequestBodyLBS <$> buildMultipartBody header' body mimeType -downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response -downloadAsset user assetDomain key zHostHeader trans = do +downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue tok) => user -> key -> tok -> App Response +downloadAsset user key tok = do uid <- objId user - domain <- objDomain assetDomain - key' <- asString key - req <- baseRequest user Cargohold Versioned $ "/assets/" ++ domain ++ "/" ++ key' + domain <- (pure <$> objDomain key) `catch` (\(_e@(AssertionFailure {})) -> pure Nothing) + key' <- (key %. "id" & asString) `catch` (\(_e@(AssertionFailure {})) -> asString key) + tok' <- pure <$> asString tok + req <- baseRequest user Cargohold Versioned $ "/assets" ++ (maybe "" (\d -> "/" ++ d) domain) ++ "/" ++ key' submit "GET" $ req & zUser uid - & zHost zHostHeader - & trans + & tokenParam tok' diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 95694cfaf9..7ae16b04bb 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -8,8 +8,11 @@ import API.BrigInternal import API.Common import API.Galley import Control.Monad.Reader +import Crypto.Random (getRandomBytes) import Data.Aeson hiding ((.=)) import Data.Aeson.Types qualified as Aeson +import Data.ByteString.Base64 qualified as B64Url +import Data.ByteString.Char8 (unpack) import Data.Default import Data.Function import Data.UUID.V1 (nextUUID) @@ -163,6 +166,10 @@ createMLSOne2OnePartner domain other convDomain = loop then pure u else loop +-- Copied from `src/CargoHold/API/V3.hs` and inlined to avoid pulling in `types-common` +randomToken :: HasCallStack => App String +randomToken = liftIO (unpack . B64Url.encode <$> getRandomBytes 16) + randomId :: HasCallStack => App String randomId = liftIO (show <$> nextRandom) diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs index c60d93301e..dbdb11f94a 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -17,20 +17,13 @@ module Test.Cargohold.API.Federation where -import API.Brig qualified as BrigP -import API.BrigInternal qualified as BrigI -import API.Common qualified as API -import API.GalleyInternal qualified as GalleyI -import Control.Concurrent (threadDelay) -import Control.Lens +import API.Cargohold +import Control.Lens hiding ((.=)) import Crypto.Random import Data.Aeson.Types hiding ((.=)) -import Data.Set qualified as Set import Data.String.Conversions -import Data.UUID qualified as UUID +import Data.Time import Data.UUID.V4 -import Data.UUID.V4 qualified as UUID -import Data.Vector.Internal.Check (HasCallStack) import GHC.Stack import SetupHelpers import Test.Cargohold.API.Util @@ -43,44 +36,45 @@ testGetAssetAvailablePrivate = getAssetAvailable False testGetAssetAvailablePublic :: HasCallStack => App () testGetAssetAvailablePublic = getAssetAvailable True -getAssetAvailable :: Bool -> App () +getAssetAvailable :: HasCallStack => Bool -> App () getAssetAvailable isPublicAsset = do - uid <- randomUser - ast :: Asset <- - responseJsonError - =<< uploadAssetV3 uid isPublicAsset (Just AssetVolatile) applicationOctetStream bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) - -- check that asset is available - liftIO $ ok @?= True + assertBool "check that asset is available" ok + where + assetVolatileSeconds :: NominalDiffTime + assetVolatileSeconds = 28 * 24 * 3600 -- 28 days testGetAssetNotAvailable :: HasCallStack => App () testGetAssetNotAvailable = do - uid <- liftIO $ Id <$> nextRandom + uid <- randomId token <- randToken - assetId <- liftIO $ Id <$> nextRandom + assetId <- randomId let key = AssetKeyV3 assetId AssetPersistent let ga = - GetAsset - { user = uid, - token = Just token, - key = key - } + object + [ "user" .= _ uid, + "token" .= _ (Just token), + "key" .= _ key + ] ok <- withFederationClient $ available <$> runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) @@ -94,7 +88,7 @@ testGetAssetWrongToken = do let bdy = (applicationOctetStream, "Hello World") settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) uid <- randomUser - ast :: Asset <- + ast :: Value <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings bdy runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) @@ -127,21 +121,21 @@ testLargeAsset = do let size = 1024 * 1024 bs <- liftIO $ getRandomBytes size - ast :: Asset <- + ast :: Value <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) liftIO . runResourceT $ connect source sinkList @@ -160,21 +154,21 @@ testStreamAsset = do defAssetSettings & set setAssetRetention (Just AssetVolatile) uid <- randomUser - ast :: Asset <- + ast :: Value <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings bdy runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) liftIO . runResourceT $ connect source sinkLazy @@ -186,13 +180,13 @@ testStreamAssetNotAvailable = do token <- randToken assetId <- liftIO $ Id <$> nextRandom - let key = AssetKeyV3 assetId AssetPersistent + key <- ast %. "key" & asString let ga = - GetAsset - { user = uid, - token = Just token, - key = key - } + object + [ "user" .= _ uid, + "token" .= _ (Just tok), + "key" .= _ key + ] err <- withFederationError $ do runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) liftIO $ do @@ -205,7 +199,7 @@ testStreamAssetWrongToken = do let bdy = (applicationOctetStream, "Hello World") settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) uid <- randomUser - ast :: Asset <- + ast :: Value <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings bdy (MIME.MIMEType, String) -> App Response -uploadSimple usr sts (ct, bs) = - uploadRaw usr $ buildMultipartBody sts (Lazy8.pack bs) ct +uploadSimple usr sts (ct, bs) = do + body <- buildMultipartBody sts (Lazy8.pack bs) ct + uploadRaw usr body decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response -> a decodeHeaderOrFail h = @@ -71,13 +72,13 @@ uploadRaw usr bs = do & (\r -> r {HTTP.requestBody = HTTP.RequestBodyLBS bs}) getContentType :: Response -> Maybe MIME.Type -getContentType = MIME.parseContentType . decodeLatin1 . getHeader' (cs "Content-Type") +getContentType = MIME.parseContentType . decodeLatin1 . getHeader' (mk $ cs "Content-Type") applicationText :: MIME.Type applicationText = MIME.Type (MIME.Application $ cs "text") [] -applicationOctetStream :: MIME.Type -applicationOctetStream = MIME.Type (MIME.Application $ cs "octet-stream") [] +applicationOctetStream :: MIME.MIMEType +applicationOctetStream = MIME.Application $ cs "octet-stream" deleteAssetV3 :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response deleteAssetV3 user key = do @@ -92,15 +93,12 @@ deleteAsset user key = do req <- baseRequest user Cargohold Versioned $ "/assets/" <> d <> "/" <> show k submit "DELETE" req -class IsAssetToken tok where - tokenParam :: tok -> HTTP.Request -> HTTP.Request +tokenParam :: Maybe String -> Request -> Request +tokenParam = maybe id (header "Asset-Token") -instance IsAssetToken (Maybe String) where - tokenParam = maybe id (header "Asset-Token") - -header :: String -> Request -> Request -header name req = - req {requestHeaders = (cs name, _) : requestHeaders req} +header :: String -> String -> Request -> Request +header name value req = + req {requestHeaders = (mk $ cs name, cs value) : requestHeaders req} downloadAssetWithAssetKey :: (HasCallStack, MakesValue user) => @@ -110,9 +108,7 @@ downloadAssetWithAssetKey :: App Response downloadAssetWithAssetKey r user tok = do req <- baseRequest user Cargohold (ExplicitVersion 1) $ "asserts/v3/" <> tok - submit "GET" $ - req - & tokenParam tok + submit "GET" $ r $ req & tokenParam (pure tok) downloadAssetWithQualifiedAssetKey :: (HasCallStack, MakesValue tok, MakesValue user) => @@ -140,65 +136,70 @@ deleteToken user key = do -- | Build a complete @multipart/mixed@ request body for a one-shot, -- non-resumable asset upload. -buildMultipartBody :: Value -> Lazy.ByteString -> MIME.MIMEType -> Lazy.ByteString -buildMultipartBody header body bodyMimeType = toLazyByteString render - where - headerJson = Aeson.encode header - - render :: Builder - render = renderBody <> endMultipartBody - - endMultipartBody :: Builder - endMultipartBody = lineBreak <> boundary <> stringUtf8 "--" <> lineBreak - - renderBody :: Builder - renderBody = mconcat $ map renderPart multipartContent - - renderPart :: MIME.MIMEValue -> Builder - renderPart v = - boundary - <> lineBreak - <> (contentType . MIME.mime_val_type) v - <> lineBreak - <> (headers . MIME.mime_val_headers) v - <> lineBreak - <> lineBreak - <> (content . MIME.mime_val_content) v - <> lineBreak - - boundary :: Builder - boundary = stringUtf8 "--" <> stringUtf8 multipartBoundary - - lineBreak :: Builder - lineBreak = stringUtf8 "\r\n" - - contentType :: MIME.Type -> Builder - contentType t = stringUtf8 "Content-Type: " <> (encodeUtf8Builder . MIME.showType) t - - headers :: [MIME.MIMEParam] -> Builder - headers [] = mempty - headers (x : xs) = renderHeader x <> headers xs - - renderHeader :: MIME.MIMEParam -> Builder - renderHeader p = - encodeUtf8Builder (MIME.paramName p) - <> stringUtf8 ": " - <> encodeUtf8Builder (MIME.paramValue p) - - content :: MIME.MIMEContent -> Builder - content (MIME.Single c) = encodeUtf8Builder c - content (MIME.Multi _) = error "Not implemented." - - multipartContent :: [MIME.MIMEValue] - multipartContent = - [ part (MIME.Application (T.pack "json")) headerJson, - part bodyMimeType body - ] - - part :: MIME.MIMEType -> Lazy.ByteString -> MIME.MIMEValue - part mtype c = - MIME.nullMIMEValue - { MIME.mime_val_type = MIME.Type mtype [], - MIME.mime_val_headers = [MIME.MIMEParam (T.pack "Content-Length") ((T.pack . show . LBS.length) c)], - MIME.mime_val_content = MIME.Single ((decodeUtf8 . LBS.toStrict) c) - } +buildMultipartBody :: (HasCallStack, MakesValue header) => header -> Lazy.ByteString -> MIME.MIMEType -> App Lazy.ByteString +buildMultipartBody header' body bodyMimeType = do + h <- make header' + let headerJson = Aeson.encode h + + render :: Builder + render = renderBody <> endMultipartBody + + endMultipartBody :: Builder + endMultipartBody = lineBreak <> boundary <> stringUtf8 "--" <> lineBreak + + renderBody :: Builder + renderBody = mconcat $ renderPart <$> multipartContent + + renderPart :: MIME.MIMEValue -> Builder + renderPart v = + boundary + <> lineBreak + <> (contentType . MIME.mime_val_type) v + <> lineBreak + <> (headers . MIME.mime_val_headers) v + <> lineBreak + <> lineBreak + <> (content . MIME.mime_val_content) v + <> lineBreak + + boundary :: Builder + boundary = stringUtf8 "--" <> stringUtf8 multipartBoundary + + lineBreak :: Builder + lineBreak = stringUtf8 "\r\n" + + contentType :: MIME.Type -> Builder + contentType t = stringUtf8 "Content-Type: " <> (encodeUtf8Builder . MIME.showType) t + + headers :: [MIME.MIMEParam] -> Builder + headers [] = mempty + headers (x : xs) = renderHeader x <> headers xs + + renderHeader :: MIME.MIMEParam -> Builder + renderHeader p = + encodeUtf8Builder (MIME.paramName p) + <> stringUtf8 ": " + <> encodeUtf8Builder (MIME.paramValue p) + + content :: MIME.MIMEContent -> Builder + content (MIME.Single c) = encodeUtf8Builder c + content (MIME.Multi _) = error "Not implemented." + + multipartContent :: [MIME.MIMEValue] + multipartContent = + [ part (MIME.Application (T.pack "json")) headerJson, + part bodyMimeType body + ] + + part :: MIME.MIMEType -> Lazy.ByteString -> MIME.MIMEValue + part mtype c = + MIME.nullMIMEValue + { MIME.mime_val_type = MIME.Type mtype [], + MIME.mime_val_headers = [MIME.MIMEParam (T.pack "Content-Length") ((T.pack . show . LBS.length) c)], + MIME.mime_val_content = MIME.Single ((decodeUtf8 . LBS.toStrict) c) + } + + pure $ toLazyByteString render + +multipartBoundary :: String +multipartBoundary = "frontier" diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index 436dae2ebc..f79fc6adea 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -19,16 +19,19 @@ module Test.Cargohold.API.V3 where -import Control.Lens hiding (sets, (.=)) +import API.Cargohold +import Codec.MIME.Type (mimeType, showMIMEType) +import Data.Aeson.KeyMap qualified as KM import Data.ByteString.Char8 qualified as C8 -import Data.Time.Clock +import Data.CaseInsensitive +import Data.String.Conversions +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) import Data.Time.Format -import Network.HTTP.Client (parseUrlThrow, requestBody) -import Network.HTTP.Types.Status (status200) +import Network.HTTP.Client import SetupHelpers import Test.Cargohold.API.Util import Testlib.Prelude -import Testlib.Types -------------------------------------------------------------------------------- -- Simple (single-step) uploads @@ -39,52 +42,61 @@ testSimpleRoundtrip = do [ "public" .= False ] let rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] - let sets = + let allSets = fmap object $ - defSettings : map (\r -> defSettings <> ["retention" .= r]) rets - mapM_ simpleRoundtrip sets + defSettings : fmap (\r -> defSettings <> ["retention" .= r]) rets + mapM_ simpleRoundtrip allSets where + simpleRoundtrip :: HasCallStack => Value -> App () simpleRoundtrip sets = do uid <- randomUser OwnDomain def uid2 <- randomId -- Initial upload - let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple uid sets bdy - r1.json %. "key" - <*> r1.json %. "token" - <*> r1.json %. "expires" + <*> (r1.json %. "token" >>= asString) + <*> (lookupField r1.json "expires" >>= maybe (pure Nothing) (fmap pure . asString)) -- Check mandatory Date header - let Just date = C8.unpack <$> lookup "Date" (responseHeaders r1) - let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime + let Just date = C8.unpack <$> lookup (mk $ cs "Date") r1.headers + parseTime = parseTimeOrError False defaultTimeLocale rfc822DateFormat + utc = parseTime date :: UTCTime + expires' = parseTime <$> expires :: Maybe UTCTime -- Potentially check for the expires header - when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do - liftIO $ assertBool "invalid expiration" (Just utc < expires) + case sets of + -- We don't care what the rentention value is here, + -- we're just checking to see if other checks need + -- to be done. + Object o -> case KM.lookup (fromString "retention") o of + Nothing -> pure () + Just r -> do + assertBool "invalid expiration" (Just utc < expires') + _ -> pure () -- Lookup with token and download via redirect. - r2 <- - downloadAsset uid key (Just tok) >= asString + assertBool "User mismatch" $ getHeader (mk $ cs "x-amz-meta-user") r3 == pure (cs uid') + assertBool "Data mismatch" $ r3.body == cs "Hello World" -- Delete (forbidden for other users) - deleteAssetV3 uid2 key !!! const 403 === statusCode + deleteAssetV3 uid2 key >>= \r -> r.status `shouldMatchInt` 403 -- Delete (allowed for creator) - deleteAssetV3 uid key !!! const 200 === statusCode - r4 <- - downloadAsset uid key (Just tok) - lookup "Date" (responseHeaders r4) + deleteAssetV3 uid key >>= \r -> r.status `shouldMatchInt` 200 + r4 <- downloadAsset uid key tok + r4.status `shouldMatchInt` 404 + let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime - liftIO $ assertBool "bad date" (utc' >= utc) + assertBool "bad date" (utc' >= utc) From bff38672ec4fe17319dc60c3034745d7411f9bd4 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 22 Nov 2023 10:02:56 +1000 Subject: [PATCH 04/22] WPB-5382: Compiling tests, but they have several failures to sort out --- integration/integration.cabal | 1 - integration/test/API/Cargohold.hs | 52 ++- integration/test/Test/Cargohold/API.hs | 439 +++++++++--------- integration/test/Test/Cargohold/API/Util.hs | 49 +- integration/test/Test/Cargohold/API/V3.hs | 12 +- integration/test/Test/Cargohold/App.hs | 61 --- services/cargohold/test/integration/API.hs | 396 ++++++++++++++++ .../test/integration}/API/Federation.hs | 208 +++++---- .../cargohold/test/integration/API/Util.hs | 237 ++++++++++ services/cargohold/test/integration/API/V3.hs | 98 ++++ services/cargohold/test/integration/App.hs | 79 ++++ services/cargohold/test/integration/Main.hs | 83 ++++ .../cargohold/test/integration/Metrics.hs | 38 ++ .../cargohold/test/integration/TestSetup.hs | 216 +++++++++ 14 files changed, 1575 insertions(+), 394 deletions(-) create mode 100644 services/cargohold/test/integration/API.hs rename {integration/test/Test/Cargohold => services/cargohold/test/integration}/API/Federation.hs (56%) create mode 100644 services/cargohold/test/integration/API/Util.hs create mode 100644 services/cargohold/test/integration/API/V3.hs create mode 100644 services/cargohold/test/integration/App.hs create mode 100644 services/cargohold/test/integration/Main.hs create mode 100644 services/cargohold/test/integration/Metrics.hs create mode 100644 services/cargohold/test/integration/TestSetup.hs diff --git a/integration/integration.cabal b/integration/integration.cabal index 984e314dfa..1ec7aab6ac 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -107,7 +107,6 @@ library Test.Brig Test.Cargohold Test.Cargohold.API - Test.Cargohold.API.Federation Test.Cargohold.API.Util Test.Cargohold.API.V3 Test.Cargohold.App diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index a0db6a655a..1daf7ec2ec 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -1,5 +1,6 @@ module API.Cargohold where +import API.Federator import Codec.MIME.Type qualified as MIME import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS @@ -13,6 +14,14 @@ import UnliftIO (catch) type LByteString = LBS.ByteString +getFederationAsset :: (HasCallStack, MakesValue asset) => asset -> App Response +getFederationAsset ga = do + req <- rawBaseRequestF OwnDomain cargohold "federation/get-asset" + bdy <- make ga + submit "POST" $ + req + & addBody (HTTP.RequestBodyLBS $ encode bdy) "application/json" + uploadAssetV3 :: (HasCallStack, MakesValue user, MakesValue assetRetention) => user -> Bool -> assetRetention -> MIME.MIMEType -> LByteString -> App Response uploadAssetV3 user isPublic retention mimeType bdy = do uid <- user & objId @@ -72,14 +81,39 @@ buildUploadAssetRequestBody isPublic retention body mimeType = do ] HTTP.RequestBodyLBS <$> buildMultipartBody header' body mimeType -downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue tok) => user -> key -> tok -> App Response -downloadAsset user key tok = do - uid <- objId user - domain <- (pure <$> objDomain key) `catch` (\(_e@(AssertionFailure {})) -> pure Nothing) - key' <- (key %. "id" & asString) `catch` (\(_e@(AssertionFailure {})) -> asString key) - tok' <- pure <$> asString tok - req <- baseRequest user Cargohold Versioned $ "/assets" ++ (maybe "" (\d -> "/" ++ d) domain) ++ "/" ++ key' +class IsAssetLocation key where + locationPathFragment :: key -> App String + +instance {-# OVERLAPS #-} IsAssetLocation String where + locationPathFragment = pure + +-- Pick out a path from the value +instance MakesValue loc => IsAssetLocation loc where + locationPathFragment v = + qualifiedFrag `catch` (\(_e :: SomeException) -> unqualifiedFrag) + where + qualifiedFrag = do + domain <- v %. "domain" & asString + key <- v %. "key" & asString + pure $ "v2/assets/" <> domain <> "/" <> key + unqualifiedFrag = do + key <- asString v + pure $ "v1/asssets/v3/" <> key + +downloadAsset' :: (HasCallStack, MakesValue user, IsAssetLocation loc, IsAssetToken tok) => user -> loc -> tok -> App Response +downloadAsset' user loc tok = do + locPath <- locationPathFragment loc + req <- baseRequest user Cargohold Unversioned $ locPath + let req' = req & tokenParam tok + print req' + submit "GET" req' + +downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response +downloadAsset user assetDomain key zHostHeader trans = do + domain <- objDomain assetDomain + key' <- asString key + req <- baseRequest user Cargohold Versioned $ "/assets/" ++ domain ++ "/" ++ key' submit "GET" $ req - & zUser uid - & tokenParam tok' + & zHost zHostHeader + & trans diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 50cd6db6e0..9de64f1ade 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -19,115 +19,122 @@ module Test.Cargohold.API where +import API.Cargohold import Codec.MIME.Type qualified as MIME -import Control.Exception (throw) import Control.Lens hiding (sets, (.=)) import Data.Aeson qualified as Aeson -import Data.ByteString.Builder +import Data.Aeson.Types (Pair) import Data.ByteString.Char8 qualified as C8 -import Data.ByteString.Conversion -import Data.Text.Encoding.Error qualified as Text -import Data.Text.Lazy.Encoding qualified as LText -import Data.Time.Clock -import Data.Time.Format -import Data.UUID.V4 -import Data.Vector.Internal.Check (HasCallStack) +import Data.ByteString.Lazy qualified as LBS hiding (replicate) +import Data.CaseInsensitive (mk) +import Data.String.Conversions import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types qualified as HTTP +import SetupHelpers (randomId, randomUser) +import Test.Cargohold.API.Util import Testlib.Prelude -import Testlib.Types +import UnliftIO.Concurrent -------------------------------------------------------------------------------- -- Simple (single-step) uploads testDownloadWithAcceptHeader :: HasCallStack => App () testDownloadWithAcceptHeader = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - domain <- viewFederationDomain - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key domain - downloadAssetWith (header "Accept" "image/jpeg") uid qkey () - !!! const 404 - === statusCode + assetId <- randomId + uid <- randomId + domain <- make OtherDomain + let key = "3-2-" <> assetId + qkey = object ["domain" .= domain, "id" .= key] + res <- downloadAssetWithQualifiedAssetKey (header "Accept" "image/jpeg") uid qkey () + res.status `shouldMatchInt` 404 + +queryItem :: ByteString -> Maybe ByteString -> HTTP.Request -> HTTP.Request +queryItem k v r = + HTTP.setQueryString ((k, v) : queryItems) r + where + queryItems = HTTP.parseQuery $ HTTP.queryString r + +get' :: HTTP.Request -> (HTTP.Request -> HTTP.Request) -> App Response +get' r f = submit "GET" $ f r testSimpleTokens :: HasCallStack => App () testSimpleTokens = do - uid <- randomUser - uid2 <- liftIO $ Id <$> nextRandom + uid <- randomUser OwnDomain def + uid2 <- randomId -- Initial upload - let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) + let sets = object ["public" .= False, "rentention" .= "volatile"] let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple (path "/assets/v3") uid sets bdy - r1.json %. "key" <*> r1.json %. "token" <*> r1.json %. "expires" + qKey <- key %. "id" & asString -- No access without token from other user (opaque 404) - downloadAsset uid2 loc () - !!! const 404 - === statusCode + downloadAsset' uid2 loc () >>= \r -> r.status `shouldMatchInt` 404 -- No access with empty token query parameter from other user (opaque 404) - downloadAsset uid2 loc (queryItem' "asset_token" Nothing) - !!! const 404 - === statusCode + downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \r -> r.status `shouldMatchInt` 404 -- No access with wrong token (opaque 404) - downloadAsset uid2 loc (Just (AssetToken "abc123")) - !!! const 404 - === statusCode + downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \r -> r.status `shouldMatchInt` 404 -- No access with wrong token as query parameter (opaque 404) - downloadAsset uid2 loc (queryItem "asset_token" "acb123") - !!! const 404 - === statusCode + downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> r.status `shouldMatchInt` 404 -- Token renewal fails if not done by owner - postToken uid2 (qUnqualified key) !!! do - const 403 === statusCode - const (Just "unauthorised") === fmap label . responseJsonMaybe + postToken uid2 qKey >>= \r -> do + r.status `shouldMatchInt` 403 + label <- traverse ((%. "label") >=> asString) r.jsonBody + label `shouldMatch` "unauthorised" -- Token renewal succeeds if done by owner - r2 <- postToken uid (qUnqualified key) responseJsonMaybe r2 - liftIO $ assertBool "token unchanged" (tok /= tok') + r2 <- postToken uid qKey + r2.status `shouldMatchInt` 200 + let Just tok' = r2.jsonBody <&> \t -> object ["token" .= t] + assertBool "token unchanged" (tok /= tok') -- Download by owner with new token. - r3 <- - downloadAsset uid loc (Just tok') getHeader (mk $ cs "content-type") r4 + r4ContentType `shouldMatch` Just (show applicationOctetStream) + let r4Tok :: Maybe String + r4Tok = cs @_ @String <$> getHeader (mk $ cs "x-amz-meta-token") r4 + r4Tok `shouldMatch` Just tok' + let r4User :: Maybe String + r4User = cs @_ @String <$> getHeader (mk $ cs "x-amz-meta-user") r4 + r4User `shouldMatch` Just uid + cs @_ @String r4.body `shouldMatch` "Hello World" -- Verify access without token if the request comes from the creator. - downloadAsset uid loc () - !!! const 302 - === statusCode + downloadAsset' uid loc () >>= \r -> r.status `shouldMatchInt` 302 -- Verify access with new token from a different user. - downloadAsset uid2 loc (Just tok') - !!! const 302 - === statusCode + downloadAsset' uid2 loc tok' >>= \r -> r.status `shouldMatchInt` 302 -- Verify access with new token as query parameter from a different user - downloadAsset uid2 loc (queryItem "asset_token" (toByteString' tok')) - !!! const 302 - === statusCode + downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure . cs $ Aeson.encode tok')) >>= \r -> r.status `shouldMatchInt` 302 -- Delete Token fails if not done by owner - deleteToken uid2 (qUnqualified key) !!! do - const 403 === statusCode - const (Just "unauthorised") === fmap label . responseJsonMaybe + deleteToken uid2 qKey >>= \r -> do + r.status `shouldMatchInt` 403 + label <- traverse ((%. "label") >=> asString) r.jsonBody + label `shouldMatch` "unauthorised" -- Delete Token succeeds by owner - deleteToken uid (qUnqualified key) !!! do - const 200 === statusCode - const Nothing === responseBody + deleteToken uid qKey >>= \r -> do + r.status `shouldMatchInt` 200 + cs @_ @String r.body `shouldMatch` "" -- Access without token from different user (asset is now "public") - downloadAsset uid2 loc () !!! do - const 302 === statusCode - const Nothing === responseBody + downloadAsset' uid2 loc () >>= \r -> do + r.status `shouldMatchInt` 302 + cs @_ @String r.body `shouldMatch` "" + +defAssetSettings' :: [Pair] +defAssetSettings' = ["public" .= False] + +defAssetSettings :: Value +defAssetSettings = object defAssetSettings' -- S3 closes idle connections after ~5 seconds, before the http-client 'Manager' -- does. If such a closed connection is reused for an upload, no problems should @@ -137,45 +144,45 @@ testSimpleS3ClosedConnectionReuse = go >> wait >> go where wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 go = do - uid <- randomUser - let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) - let part2 = (MIME.Type (MIME.Text "plain") [], C8.replicate 100000 'c') - uploadSimple (path "/assets/v3") uid sets part2 - !!! const 201 - === statusCode + uid <- randomUser OwnDomain def + let sets = object $ defAssetSettings' <> ["retention" .= "volatile"] + let part2 = (MIME.Text $ cs "plain", replicate 100000 'c') + uploadSimple uid sets part2 >>= \r -> r.status `shouldMatchInt` 201 + +cargoholdOverride :: Value -> App Value +cargoholdOverride v = case v of + Object o -> print o >> pure v + _ -> pure v testDownloadURLOverride :: HasCallStack => App () testDownloadURLOverride = do - -- This is a .example domain, it shouldn't resolve. But it is also not - -- supposed to be used by cargohold to make connections. - let downloadEndpoint = "external-s3-url.example" - withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do - uid <- randomUser - + startDynamicBackends [def {cargoholdCfg = cargoholdOverride}] $ \[d] -> do + -- This is a .example domain, it shouldn't resolve. But it is also not + -- supposed to be used by cargohold to make connections. + let downloadEndpoint = "external-s3-url.example" + -- withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do + uid <- randomUser d def -- Upload, should work, shouldn't try to use the S3DownloadEndpoint let bdy = (applicationText, "Hello World") - uploadRes <- - uploadSimple (path "/assets/v3") uid V3.defAssetSettings bdy - uploadRes.json %. "key" - <*> uploadRes.json %. "token" - <*> uploadRes.json %. "expires" - + <*> (uploadRes.json %. "token" & asString) + <*> lookupField uploadRes.json "expires" -- Lookup with token and get download URL. Should return the -- S3DownloadEndpoint, but not try to use it. - downloadURLRes <- - downloadAsset uid loc (Just tok) App () testUploadCompatibility = do - uid <- randomUser + uid <- randomUser OwnDomain def -- Initial upload - r1 <- - uploadRaw (path "/assets/v3") uid exampleMultipart - App () testRemoteDownloadWrongDomain = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "invalid.example.com") - downloadAsset uid qkey () !!! do - const 422 === statusCode - -testRemoteDownloadNoAsset :: HasCallStack => App () -testRemoteDownloadNoAsset = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "faraway.example.com") - respond req - | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse False)) - | otherwise = - throw - . MockErrorResponse HTTP.status404 - . LText.decodeUtf8With Text.lenientDecode - . Aeson.encode - $ assetNotFound - (_, reqs) <- withMockFederator respond $ do - downloadAsset uid qkey () !!! do - const 404 === statusCode - localDomain <- viewFederationDomain - liftIO $ - reqs - @?= [ FederatedRequest - { frOriginDomain = localDomain, - frTargetDomain = Domain "faraway.example.com", - frComponent = Cargohold, - frRPC = "get-asset", - frBody = Aeson.encode (GetAsset uid key Nothing) - } + assetId <- randomId + uid <- randomId + let key = toJSON $ "3-2-" <> assetId + qkey = + object + [ "id" .= key, + "domain" .= "invalid.example.com" ] + res <- downloadAsset' uid qkey () + res.status `shouldMatchInt` 422 -testRemoteDownloadFederationFailure :: HasCallStack => App () -testRemoteDownloadFederationFailure = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "faraway.example.com") - respond req - | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse True)) - | otherwise = throw (MockErrorResponse HTTP.status500 "mock error") - (resp, _) <- - withMockFederator respond $ do - responseJsonError - =<< downloadAsset uid qkey () - App () -testRemoteDownloadShort = remoteDownload "asset content" +-- testRemoteDownloadNoAsset :: HasCallStack => App () +-- testRemoteDownloadNoAsset = do +-- assetId <- randomId +-- uid <- randomId +-- let key = "3-2-" <> assetId +-- qkey = object +-- [ "domain" .= "faraway.example.com" +-- , "id" .= key +-- ] +-- respond req +-- | frRPC req == "get-asset" = +-- pure ("application" // "json", Aeson.encode (GetAssetResponse False)) +-- | otherwise = +-- throw +-- . MockErrorResponse HTTP.status404 +-- . LText.decodeUtf8With Text.lenientDecode +-- . Aeson.encode +-- $ assetNotFound +-- (_, reqs) <- withMockFederator respond $ do +-- downloadAsset' uid qkey () !!! do +-- const 404 === statusCode +-- localDomain <- viewFederationDomain +-- liftIO $ +-- reqs +-- @?= undefined +-- -- [ FederatedRequest +-- -- { frOriginDomain = localDomain, +-- -- frTargetDomain = Domain "faraway.example.com", +-- -- frComponent = Cargohold, +-- -- frRPC = "get-asset", +-- -- frBody = Aeson.encode (GetAsset uid key Nothing) +-- -- } +-- -- ] -testRemoteDownloadLong :: HasCallStack => App () -testRemoteDownloadLong = remoteDownload $ toLazyByteString $ mconcat $ replicate 20000 $ byteString "hello world\n" +-- testRemoteDownloadFederationFailure :: HasCallStack => App () +-- testRemoteDownloadFederationFailure = do +-- assetId <- randomId +-- uid <- randomId +-- let key = "3-2-" <> assetId +-- qkey = object +-- [ "domain" .= "faraway.example.com" +-- , "id" .= key +-- ] +-- respond req +-- | frRPC req == "get-asset" = +-- pure ("application" // "json", Aeson.encode (GetAssetResponse True)) +-- | otherwise = throw (MockErrorResponse HTTP.status500 "mock error") +-- -- (resp, _) <- +-- -- withMockFederator respond $ do +-- -- responseJsonError +-- res <- downloadAsset' uid qkey () +-- res.status `shouldMatchInt` 500 +-- resJ <- maybe (assertFailure "No JSON body") pure res.jsonBody +-- asString (resJ %. "label") `shouldMatch` "mock-error" +-- asString (resJ %. "message") `shouldMatch` "mock error" -remoteDownload :: HasCallStack => LByteString -> App () -remoteDownload assetContent = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom +-- testRemoteDownloadShort :: HasCallStack => App () +-- testRemoteDownloadShort = remoteDownload $ cs "asset content" - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "faraway.example.com") - respond req - | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse True)) - | otherwise = pure ("application" // "octet-stream", assetContent) - (_, reqs) <- withMockFederator respond $ do - downloadAsset uid qkey () !!! do - const 200 === statusCode - const (Just assetContent) === responseBody +-- testRemoteDownloadLong :: HasCallStack => App () +-- testRemoteDownloadLong = remoteDownload $ toLazyByteString $ mconcat $ replicate 20000 $ builder "hello world\n" - localDomain <- viewFederationDomain - let ga = Aeson.encode (GetAsset uid key Nothing) - liftIO $ - reqs - @?= [ FederatedRequest - { frOriginDomain = localDomain, - frTargetDomain = Domain "faraway.example.com", - frComponent = Cargohold, - frRPC = "get-asset", - frBody = ga - }, - FederatedRequest - { frOriginDomain = localDomain, - frTargetDomain = Domain "faraway.example.com", - frComponent = Cargohold, - frRPC = "stream-asset", - frBody = ga - } - ] +-- remoteDownload :: HasCallStack => LBS.ByteString -> App () +-- remoteDownload assetContent = do +-- assetId <- randomId +-- uid <- randomId +-- +-- let key = "3-2-" <> assetId +-- qkey = object ["domain" .= "faraway.example.com", "id" .= key] +-- respond req +-- | frRPC req == "get-asset" = +-- pure ("application" // "json", Aeson.encode (GetAssetResponse True)) +-- | otherwise = pure ("application" // "octet-stream", assetContent) +-- (_, reqs) <- withMockFederator respond $ do +-- res <- downloadAsset' uid qkey () +-- res.status `shouldMatchInt` 200 +-- res.responseBody `shouldMatch` assetContent +-- +-- let ga = object [ "user" .= uid, "key" .= key ] +-- liftIO $ +-- reqs +-- @?= undefined +-- -- [ FederatedRequest +-- -- { frOriginDomain = localDomain, +-- -- frTargetDomain = Domain "faraway.example.com", +-- -- frComponent = Cargohold, +-- -- frRPC = "get-asset", +-- -- frBody = ga +-- -- }, +-- -- FederatedRequest +-- -- { frOriginDomain = localDomain, +-- -- frTargetDomain = Domain "faraway.example.com", +-- -- frComponent = Cargohold, +-- -- frRPC = "stream-asset", +-- -- frBody = ga +-- -- } +-- -- ] diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index f1d1968097..1d61a4473e 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -34,6 +34,7 @@ import Network.HTTP.Client (Request (requestHeaders)) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types.Header import Testlib.Prelude +import qualified Data.Aeson.KeyMap as Aeson uploadSimple :: (HasCallStack, MakesValue user, MakesValue settings) => @@ -74,12 +75,15 @@ uploadRaw usr bs = do getContentType :: Response -> Maybe MIME.Type getContentType = MIME.parseContentType . decodeLatin1 . getHeader' (mk $ cs "Content-Type") -applicationText :: MIME.Type -applicationText = MIME.Type (MIME.Application $ cs "text") [] +applicationText :: MIME.MIMEType +applicationText = MIME.Application $ cs "text" applicationOctetStream :: MIME.MIMEType applicationOctetStream = MIME.Application $ cs "octet-stream" +applicationOctetStream' :: MIME.Type +applicationOctetStream' = MIME.Type applicationOctetStream [] + deleteAssetV3 :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response deleteAssetV3 user key = do k <- key %. "id" & asString @@ -93,9 +97,6 @@ deleteAsset user key = do req <- baseRequest user Cargohold Versioned $ "/assets/" <> d <> "/" <> show k submit "DELETE" req -tokenParam :: Maybe String -> Request -> Request -tokenParam = maybe id (header "Asset-Token") - header :: String -> String -> Request -> Request header name value req = req {requestHeaders = (mk $ cs name, cs value) : requestHeaders req} @@ -108,21 +109,45 @@ downloadAssetWithAssetKey :: App Response downloadAssetWithAssetKey r user tok = do req <- baseRequest user Cargohold (ExplicitVersion 1) $ "asserts/v3/" <> tok - submit "GET" $ r $ req & tokenParam (pure tok) + submit "GET" $ r $ req & tokenParam tok + +class IsAssetToken tok where + tokenParam :: tok -> Request -> Request + +instance IsAssetToken () where + tokenParam _ = id + +instance IsAssetToken String where + tokenParam = header "Asset-Token" + +instance IsAssetToken Value where + tokenParam v = + case v of + String s -> header h $ cs s + Object o -> maybe id tokenParam $ Aeson.lookup (fromString "token") o + _ -> error "Non-matching Asset-Token value" + where + h = "Asset-Token" + +instance IsAssetToken (Request -> Request) where + tokenParam = id + downloadAssetWithQualifiedAssetKey :: - (HasCallStack, MakesValue tok, MakesValue user) => + (HasCallStack, IsAssetToken tok, MakesValue key, MakesValue user) => (HTTP.Request -> HTTP.Request) -> user -> - Maybe String -> + key -> + tok -> App Response -downloadAssetWithQualifiedAssetKey r user tok = do - dom <- tok %. "domain" & asString - key <- tok %. "id" & asString - req <- baseRequest user Cargohold (ExplicitVersion 2) $ "assets/" <> dom <> "/" <> key +downloadAssetWithQualifiedAssetKey r user key tok = do + dom <- key %. "domain" & asString + keyId <- key %. "id" & asString + req <- baseRequest user Cargohold (ExplicitVersion 2) $ "assets/" <> dom <> "/" <> keyId submit "GET" $ req & tokenParam tok + & r postToken :: (MakesValue user, HasCallStack) => user -> String -> App Response postToken user key = do diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index f79fc6adea..07a7f854f0 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -20,7 +20,7 @@ module Test.Cargohold.API.V3 where import API.Cargohold -import Codec.MIME.Type (mimeType, showMIMEType) +import Codec.MIME.Type (showMIMEType) import Data.Aeson.KeyMap qualified as KM import Data.ByteString.Char8 qualified as C8 import Data.CaseInsensitive @@ -52,9 +52,10 @@ testSimpleRoundtrip = do uid <- randomUser OwnDomain def uid2 <- randomId -- Initial upload - let bdy = (mimeType applicationText, "Hello World") + let bdy = (applicationText, "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 + print r1.jsonBody -- use v3 path instead of the one returned in the header (key, tok, expires) <- (,,) @@ -73,11 +74,12 @@ testSimpleRoundtrip = do -- to be done. Object o -> case KM.lookup (fromString "retention") o of Nothing -> pure () - Just r -> do + Just _r -> do assertBool "invalid expiration" (Just utc < expires') _ -> pure () -- Lookup with token and download via redirect. - r2 <- downloadAsset uid key tok + r2 <- downloadAsset' uid key tok + print r2.body r2.status `shouldMatchInt` 302 assertBool "Response body should be empty" $ r2.body == mempty @@ -95,7 +97,7 @@ testSimpleRoundtrip = do deleteAssetV3 uid2 key >>= \r -> r.status `shouldMatchInt` 403 -- Delete (allowed for creator) deleteAssetV3 uid key >>= \r -> r.status `shouldMatchInt` 200 - r4 <- downloadAsset uid key tok + r4 <- downloadAsset' uid key tok r4.status `shouldMatchInt` 404 let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime diff --git a/integration/test/Test/Cargohold/App.hs b/integration/test/Test/Cargohold/App.hs index f35b903651..66e3d5f455 100644 --- a/integration/test/Test/Cargohold/App.hs +++ b/integration/test/Test/Cargohold/App.hs @@ -1,64 +1,3 @@ {-# OPTIONS_GHC -Wno-unused-do-bind #-} module Test.Cargohold.App where - -import Control.Exception -import Control.Lens -import Data.ByteString.Conversion -import Data.Map qualified as Map -import Data.Text qualified as T -import Testlib.Prelude - -testMultiIngressCloudFrontFails :: HasCallStack => App () -testMultiIngressCloudFrontFails = do - ts <- ask - let opts = - view tsOpts ts - & (Opts.aws . Opts.cloudFront) ?~ cloudFrontOptions - & (Opts.aws . Opts.multiIngress) ?~ multiIngressMap - msg <- - liftIO $ - catch - (newEnv opts >> pure "No exception") - (\(SomeException e) -> pure $ displayException e) - liftIO $ - assertBool - "Check error message" - (containsString "Invalid configuration: multiIngress and cloudFront cannot be combined!" msg) - where - cloudFrontOptions :: CloudFrontOpts - cloudFrontOptions = - CloudFrontOpts - { _domain = Domain (T.pack "example.com"), - _keyPairId = KeyPairId (T.pack "anyId"), - _privateKey = "any/path" - } - -multiIngressMap :: Map String AWSEndpoint -multiIngressMap = - Map.singleton - "red.example.com" - (toAWSEndpoint "http://s3-download.red.example.com") - -toAWSEndpoint :: ByteString -> AWSEndpoint -toAWSEndpoint = fromJust . fromByteString - -testMultiIngressS3DownloadEndpointFails :: HasCallStack => App () -testMultiIngressS3DownloadEndpointFails = do - ts <- ask - let opts = - view tsOpts ts - & (Opts.aws . Opts.s3DownloadEndpoint) ?~ toAWSEndpoint "http://fake-s3:4570" - & (Opts.aws . Opts.multiIngress) ?~ multiIngressMap - msg <- - liftIO $ - catch - (newEnv opts >> pure "No exception") - (\(SomeException e) -> pure $ displayException e) - liftIO $ - assertBool - "Check error message" - (containsString "Invalid configuration: multiIngress and s3DownloadEndpoint cannot be combined!" msg) - -containsString :: String -> String -> Bool -xs `containsString` ys = any (xs `isPrefixOf`) (tails ys) diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs new file mode 100644 index 0000000000..47428f0ea3 --- /dev/null +++ b/services/cargohold/test/integration/API.hs @@ -0,0 +1,396 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . + +module API (tests) where + +import API.Util +import Bilge hiding (body) +import Bilge.Assert +import CargoHold.API.Error +import CargoHold.Options (aws, s3DownloadEndpoint) +import CargoHold.Types +import qualified CargoHold.Types.V3 as V3 +import qualified Codec.MIME.Type as MIME +import Control.Exception (throw) +import Control.Lens hiding (sets, (.=)) +import qualified Data.Aeson as Aeson +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Conversion +import Data.Domain +import Data.Id +import Data.Qualified +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Lazy.Encoding as LText +import Data.Time.Clock +import Data.Time.Format +import Data.UUID.V4 +import Federator.MockServer +import Imports hiding (head) +import Network.HTTP.Client (parseUrlThrow) +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Media ((//)) +import qualified Network.HTTP.Types as HTTP +import Network.Wai.Utilities (Error (label)) +import qualified Network.Wai.Utilities.Error as Wai +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Util.Options +import Wire.API.Federation.API.Cargohold +import Wire.API.Federation.Component + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "API Integration" + [ testGroup + "simple" + [ test s "roundtrip" testSimpleRoundtrip, + test s "download with accept header" testDownloadWithAcceptHeader, + test s "tokens" testSimpleTokens, + test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, + test s "client-compatibility" testUploadCompatibility, + test s "download url override" testDownloadURLOverride + ], + testGroup + "remote" + [ test s "remote download wrong domain" testRemoteDownloadWrongDomain, + test s "remote download no asset" testRemoteDownloadNoAsset, + test s "federator failure on remote download" testRemoteDownloadFederationFailure, + test s "remote download" (testRemoteDownload "asset content"), + test s "large remote download" $ + testRemoteDownload + ( toLazyByteString + (mconcat (replicate 20000 (byteString "hello world\n"))) + ) + ] + ] + +-------------------------------------------------------------------------------- +-- Simple (single-step) uploads + +testSimpleRoundtrip :: TestM () +testSimpleRoundtrip = do + let def = V3.defAssetSettings + let rets = [minBound ..] + let sets = def : map (\r -> def & V3.setAssetRetention ?~ r) rets + mapM_ simpleRoundtrip sets + where + simpleRoundtrip sets = do + uid <- randomUser + uid2 <- liftIO $ Id <$> nextRandom + -- Initial upload + let bdy = (applicationText, "Hello World") + r1 <- + uploadSimple (path "/assets/v3") uid sets bdy + lookup "Date" (responseHeaders r1) + let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime + -- Potentially check for the expires header + when (isJust $ V3.assetRetentionSeconds =<< (sets ^. V3.setAssetRetention)) $ do + liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) + -- Lookup with token and download via redirect. + r2 <- + downloadAsset uid loc (Just tok) lookup "Date" (responseHeaders r4) + let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime + liftIO $ assertBool "bad date" (utc' >= utc) + +testDownloadWithAcceptHeader :: TestM () +testDownloadWithAcceptHeader = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + domain <- viewFederationDomain + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key domain + downloadAssetWith (header "Accept" "image/jpeg") uid qkey () + !!! const 404 === statusCode + +testSimpleTokens :: TestM () +testSimpleTokens = do + uid <- randomUser + uid2 <- liftIO $ Id <$> nextRandom + -- Initial upload + let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) + let bdy = (applicationText, "Hello World") + r1 <- + uploadSimple (path "/assets/v3") uid sets bdy + responseJsonMaybe r2 + liftIO $ assertBool "token unchanged" (tok /= tok') + -- Download by owner with new token. + r3 <- + downloadAsset uid loc (Just tok') > wait >> go + where + wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 + go = do + uid <- randomUser + let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) + let part2 = (MIME.Type (MIME.Text "plain") [], C8.replicate 100000 'c') + uploadSimple (path "/assets/v3") uid sets part2 + !!! const 201 === statusCode + +testDownloadURLOverride :: TestM () +testDownloadURLOverride = do + -- This is a .example domain, it shouldn't resolve. But it is also not + -- supposed to be used by cargohold to make connections. + let downloadEndpoint = "external-s3-url.example" + withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do + uid <- randomUser + + -- Upload, should work, shouldn't try to use the S3DownloadEndpoint + let bdy = (applicationText, "Hello World") + uploadRes <- + uploadSimple (path "/assets/v3") uid V3.defAssetSettings bdy + nextRandom + uid <- liftIO $ Id <$> nextRandom + + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "invalid.example.com") + downloadAsset uid qkey () !!! do + const 422 === statusCode + +testRemoteDownloadNoAsset :: TestM () +testRemoteDownloadNoAsset = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "faraway.example.com") + respond req + | frRPC req == "get-asset" = + pure ("application" // "json", Aeson.encode (GetAssetResponse False)) + | otherwise = + throw + . MockErrorResponse HTTP.status404 + . LText.decodeUtf8With Text.lenientDecode + . Aeson.encode + $ assetNotFound + (_, reqs) <- withMockFederator respond $ do + downloadAsset uid qkey () !!! do + const 404 === statusCode + localDomain <- viewFederationDomain + liftIO $ + reqs + @?= [ FederatedRequest + { frOriginDomain = localDomain, + frTargetDomain = Domain "faraway.example.com", + frComponent = Cargohold, + frRPC = "get-asset", + frBody = Aeson.encode (GetAsset uid key Nothing) + } + ] + +testRemoteDownloadFederationFailure :: TestM () +testRemoteDownloadFederationFailure = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "faraway.example.com") + respond req + | frRPC req == "get-asset" = + pure ("application" // "json", Aeson.encode (GetAssetResponse True)) + | otherwise = throw (MockErrorResponse HTTP.status500 "mock error") + (resp, _) <- + withMockFederator respond $ do + responseJsonError + =<< downloadAsset uid qkey () TestM () +testRemoteDownload assetContent = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "faraway.example.com") + respond req + | frRPC req == "get-asset" = + pure ("application" // "json", Aeson.encode (GetAssetResponse True)) + | otherwise = pure ("application" // "octet-stream", assetContent) + (_, reqs) <- withMockFederator respond $ do + downloadAsset uid qkey () !!! do + const 200 === statusCode + const (Just assetContent) === responseBody + + localDomain <- viewFederationDomain + let ga = Aeson.encode (GetAsset uid key Nothing) + liftIO $ + reqs + @?= [ FederatedRequest + { frOriginDomain = localDomain, + frTargetDomain = Domain "faraway.example.com", + frComponent = Cargohold, + frRPC = "get-asset", + frBody = ga + }, + FederatedRequest + { frOriginDomain = localDomain, + frTargetDomain = Domain "faraway.example.com", + frComponent = Cargohold, + frRPC = "stream-asset", + frBody = ga + } + ] diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/services/cargohold/test/integration/API/Federation.hs similarity index 56% rename from integration/test/Test/Cargohold/API/Federation.hs rename to services/cargohold/test/integration/API/Federation.hs index dbdb11f94a..d7bf5c87cf 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/services/cargohold/test/integration/API/Federation.hs @@ -15,66 +15,92 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Cargohold.API.Federation where - -import API.Cargohold -import Control.Lens hiding ((.=)) +module API.Federation (tests) where + +import API.Util +import Bilge +import Bilge.Assert +import CargoHold.API.V3 (randToken) +import Conduit +import Control.Lens import Crypto.Random -import Data.Aeson.Types hiding ((.=)) -import Data.String.Conversions -import Data.Time +import Data.Id +import Data.Qualified import Data.UUID.V4 -import GHC.Stack -import SetupHelpers -import Test.Cargohold.API.Util -import Testlib.Assertions -import Testlib.Prelude - -testGetAssetAvailablePrivate :: HasCallStack => App () -testGetAssetAvailablePrivate = getAssetAvailable False - -testGetAssetAvailablePublic :: HasCallStack => App () -testGetAssetAvailablePublic = getAssetAvailable True - -getAssetAvailable :: HasCallStack => Bool -> App () -getAssetAvailable isPublicAsset = do - uid <- randomUser OwnDomain def - resp <- uploadAssetV3 uid isPublicAsset (Just assetVolatileSeconds) applicationOctetStream bdy - resp.status `shouldMatchInt` 201 - ast <- resp.json +import Imports +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai.Utilities.Error as Wai +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Wire.API.Asset +import Wire.API.Federation.API +import Wire.API.Federation.API.Cargohold +import Wire.API.Routes.AssetBody + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "API Federation" + [ testGroup + "get-asset" + [ test s "private asset is available" (testGetAssetAvailable False), + test s "public asset is available" (testGetAssetAvailable True), + test s "not available" testGetAssetNotAvailable, + test s "wrong token" testGetAssetWrongToken + ], + testGroup + "stream-asset" + [ test s "streaming large asset" testLargeAsset, + test s "stream an asset" testStreamAsset, + test s "stream asset not available" testStreamAssetNotAvailable, + test s "stream asset wrong token" testStreamAssetWrongToken + ] + ] + +testGetAssetAvailable :: Bool -> TestM () +testGetAssetAvailable isPublicAsset = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + settings = + defAssetSettings + & set setAssetRetention (Just AssetVolatile) + & set setAssetPublic isPublicAsset + uid <- randomUser + ast :: Asset <- + responseJsonError + =<< uploadSimple (path "/assets/v3") uid settings bdy + runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) - assertBool "check that asset is available" ok - where - assetVolatileSeconds :: NominalDiffTime - assetVolatileSeconds = 28 * 24 * 3600 -- 28 days + -- check that asset is available + liftIO $ ok @?= True -testGetAssetNotAvailable :: HasCallStack => App () +testGetAssetNotAvailable :: TestM () testGetAssetNotAvailable = do - uid <- randomId + uid <- liftIO $ Id <$> nextRandom token <- randToken - assetId <- randomId + assetId <- liftIO $ Id <$> nextRandom let key = AssetKeyV3 assetId AssetPersistent let ga = - object - [ "user" .= _ uid, - "token" .= _ (Just token), - "key" .= _ key - ] + GetAsset + { user = uid, + token = Just token, + key = key + } ok <- withFederationClient $ available <$> runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) @@ -82,27 +108,26 @@ testGetAssetNotAvailable = do -- check that asset is not available liftIO $ ok @?= False -testGetAssetWrongToken :: HasCallStack => App () +testGetAssetWrongToken :: TestM () testGetAssetWrongToken = do -- Initial upload let bdy = (applicationOctetStream, "Hello World") settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) uid <- randomUser - ast :: Value <- + ast :: Asset <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) @@ -110,7 +135,7 @@ testGetAssetWrongToken = do -- check that asset is not available liftIO $ ok @?= False -testLargeAsset :: HasCallStack => App () +testLargeAsset :: TestM () testLargeAsset = do -- Initial upload let settings = @@ -121,21 +146,20 @@ testLargeAsset = do let size = 1024 * 1024 bs <- liftIO $ getRandomBytes size - ast :: Value <- + ast :: Asset <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) - runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) liftIO . runResourceT $ connect source sinkList @@ -146,7 +170,7 @@ testLargeAsset = do (length chunks > minNumChunks) mconcat chunks @?= bs -testStreamAsset :: HasCallStack => App () +testStreamAsset :: TestM () testStreamAsset = do -- Initial upload let bdy = (applicationOctetStream, "Hello World") @@ -154,66 +178,64 @@ testStreamAsset = do defAssetSettings & set setAssetRetention (Just AssetVolatile) uid <- randomUser - ast :: Value <- + ast :: Asset <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) liftIO . runResourceT $ connect source sinkLazy liftIO $ respBody @?= "Hello World" -testStreamAssetNotAvailable :: HasCallStack => App () +testStreamAssetNotAvailable :: TestM () testStreamAssetNotAvailable = do uid <- liftIO $ Id <$> nextRandom token <- randToken assetId <- liftIO $ Id <$> nextRandom - key <- ast %. "key" & asString + let key = AssetKeyV3 assetId AssetPersistent let ga = - object - [ "user" .= _ uid, - "token" .= _ (Just tok), - "key" .= _ key - ] + GetAsset + { user = uid, + token = Just token, + key = key + } err <- withFederationError $ do runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) liftIO $ do Wai.code err @?= HTTP.notFound404 Wai.label err @?= "not-found" -testStreamAssetWrongToken :: HasCallStack => App () +testStreamAssetWrongToken :: TestM () testStreamAssetWrongToken = do -- Initial upload let bdy = (applicationOctetStream, "Hello World") settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) uid <- randomUser - ast :: Value <- + ast :: Asset <- responseJsonError =<< uploadSimple (path "/assets/v3") uid settings bdy - +-- +-- 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 . + +module API.Util where + +import Bilge hiding (body, host, port) +import qualified Bilge +import CargoHold.Options +import CargoHold.Run +import qualified Codec.MIME.Parse as MIME +import qualified Codec.MIME.Type as MIME +import Control.Lens hiding ((.=)) +import Control.Monad.Codensity +import Data.Aeson (object, (.=)) +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as C +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as Lazy +import Data.Domain +import Data.Id +import Data.Qualified +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import qualified Data.UUID as UUID +import Data.UUID.V4 (nextRandom) +import Federator.MockServer +import Imports hiding (head) +import qualified Network.HTTP.Media as HTTP +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method +import Network.Wai.Utilities.MockServer +import Safe (readNote) +import TestSetup +import Util.Options +import Wire.API.Asset + +-- Copied wholesale from gundeck/test/integration/API.hs +-- This is needed because it sets up the email on the user, verifiying it. +-- The changes to the asset routes forbidding non-verified users from uploading +-- assets breaks a lot of existing tests. +-- +-- FUTUREWORK: Move all the cargohold tests to the new integration test suite. +-- https://wearezeta.atlassian.net/browse/WPB-5382 +randomUser :: TestM UserId +randomUser = do + (Endpoint (encodeUtf8 -> eHost) ePort) <- view tsBrig + e <- liftIO $ mkEmail "success" "simulator.amazonses.com" + let p = + object + [ "name" .= e, + "email" .= e, + "password" .= ("secret-8-chars-long-at-least" :: Text) + ] + r <- post (Bilge.host eHost . Bilge.port ePort . path "/i/users" . json p) + pure + . readNote "unable to parse Location header" + . C.unpack + $ getHeader' "Location" r + where + mkEmail loc dom = do + uid <- nextRandom + pure $ loc <> "+" <> UUID.toText uid <> "@" <> dom + +uploadSimple :: + (Request -> Request) -> + UserId -> + AssetSettings -> + (MIME.Type, ByteString) -> + TestM (Response (Maybe Lazy.ByteString)) +uploadSimple c usr sts (ct, bs) = + let mp = buildMultipartBody sts ct (Lazy.fromStrict bs) + in uploadRaw c usr (toLazyByteString mp) + +decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response b -> a +decodeHeaderOrFail h = + fromMaybe (error $ "decodeHeaderOrFail: missing or invalid header: " ++ show h) + . fromByteString + . getHeader' h + +uploadRaw :: + (Request -> Request) -> + UserId -> + Lazy.ByteString -> + TestM (Response (Maybe Lazy.ByteString)) +uploadRaw c usr bs = do + cargohold' <- viewUnversionedCargohold + post $ + apiVersion "v1" + . c + . cargohold' + . method POST + . zUser usr + . zConn "conn" + . content "multipart/mixed" + . lbytes bs + +getContentType :: Response a -> Maybe MIME.Type +getContentType = MIME.parseContentType . decodeLatin1 . getHeader' "Content-Type" + +applicationText :: MIME.Type +applicationText = MIME.Type (MIME.Application "text") [] + +applicationOctetStream :: MIME.Type +applicationOctetStream = MIME.Type (MIME.Application "octet-stream") [] + +zUser :: UserId -> Request -> Request +zUser = header "Z-User" . UUID.toASCIIBytes . toUUID + +zConn :: ByteString -> Request -> Request +zConn = header "Z-Connection" + +deleteAssetV3 :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) +deleteAssetV3 u k = do + c <- viewUnversionedCargohold + delete $ apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] + +deleteAsset :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) +deleteAsset u k = do + c <- viewCargohold + delete $ + c + . zUser u + . paths + [ "assets", + toByteString' (qDomain k), + toByteString' (qUnqualified k) + ] + +class IsAssetLocation key where + locationPath :: key -> Request -> Request + +instance IsAssetLocation AssetKey where + locationPath k = + apiVersion "v1" + . paths ["assets", "v3", toByteString' k] + +instance IsAssetLocation (Qualified AssetKey) where + locationPath k = + apiVersion "v2" + . paths ["assets", toByteString' (qDomain k), toByteString' (qUnqualified k)] + +instance IsAssetLocation ByteString where + locationPath = path + +class IsAssetToken tok where + tokenParam :: tok -> Request -> Request + +instance IsAssetToken () where + tokenParam _ = id + +instance IsAssetToken (Maybe AssetToken) where + tokenParam = maybe id (header "Asset-Token" . toByteString') + +instance IsAssetToken (Request -> Request) where + tokenParam = id + +downloadAssetWith :: + (IsAssetLocation loc, IsAssetToken tok) => + (Request -> Request) -> + UserId -> + loc -> + tok -> + TestM (Response (Maybe LByteString)) +downloadAssetWith r uid loc tok = do + c <- viewUnversionedCargohold + get $ + c + . r + . zUser uid + . locationPath loc + . tokenParam tok + . noRedirect + +downloadAsset :: + (IsAssetLocation loc, IsAssetToken tok) => + UserId -> + loc -> + tok -> + TestM (Response (Maybe LByteString)) +downloadAsset = downloadAssetWith id + +postToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) +postToken uid key = do + c <- viewCargohold + post $ + c + . zUser uid + . paths ["assets", toByteString' key, "token"] + +deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) +deleteToken uid key = do + c <- viewCargohold + delete $ + c + . zUser uid + . paths ["assets", toByteString' key, "token"] + +viewFederationDomain :: TestM Domain +viewFederationDomain = view (tsOpts . settings . federationDomain) + +-------------------------------------------------------------------------------- +-- Mocking utilities + +withSettingsOverrides :: (Opts -> Opts) -> TestM a -> TestM a +withSettingsOverrides f action = do + ts <- ask + let opts = f (view tsOpts ts) + liftIO . lowerCodensity $ do + (app, _) <- mkApp opts + p <- withMockServer app + liftIO $ runTestM (ts & tsEndpoint %~ setLocalEndpoint p) action + +setLocalEndpoint :: Word16 -> Endpoint -> Endpoint +setLocalEndpoint p = (port .~ p) . (host .~ "127.0.0.1") + +withMockFederator :: + (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> + TestM a -> + TestM (a, [FederatedRequest]) +withMockFederator respond action = do + withTempMockFederator [] respond $ \p -> + withSettingsOverrides + (federator . _Just %~ setLocalEndpoint (fromIntegral p)) + action diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs new file mode 100644 index 0000000000..5560905f92 --- /dev/null +++ b/services/cargohold/test/integration/API/V3.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . + +module API.V3 (tests) where + +import API.Util +import Bilge hiding (body) +import Bilge.Assert +import Control.Lens hiding (sets) +import qualified Data.ByteString.Char8 as C8 +import Data.Id +import Data.Qualified +import Data.Time.Clock +import Data.Time.Format +import Data.UUID.V4 +import Imports hiding (head) +import Network.HTTP.Client (parseUrlThrow) +import Network.HTTP.Types.Status (status200) +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Wire.API.Asset + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "API Integration v3" + [ testGroup + "simple" + [test s "roundtrip using v3 API" testSimpleRoundtrip] + ] + +-------------------------------------------------------------------------------- +-- Simple (single-step) uploads + +testSimpleRoundtrip :: TestM () +testSimpleRoundtrip = do + let def = defAssetSettings + let rets = [minBound ..] + let sets = def : map (\r -> def & setAssetRetention ?~ r) rets + mapM_ simpleRoundtrip sets + where + simpleRoundtrip sets = do + uid <- randomUser + uid2 <- liftIO $ Id <$> nextRandom + -- Initial upload + let bdy = (applicationText, "Hello World") + r1 <- + uploadSimple (path "/assets/v3") uid sets bdy + lookup "Date" (responseHeaders r1) + let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime + -- Potentially check for the expires header + when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do + liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) + -- Lookup with token and download via redirect. + r2 <- + downloadAsset uid key (Just tok) lookup "Date" (responseHeaders r4) + let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime + liftIO $ assertBool "bad date" (utc' >= utc) diff --git a/services/cargohold/test/integration/App.hs b/services/cargohold/test/integration/App.hs new file mode 100644 index 0000000000..016de02496 --- /dev/null +++ b/services/cargohold/test/integration/App.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -Wno-unused-do-bind #-} + +module App (tests) where + +import CargoHold.App (newEnv) +import CargoHold.CloudFront +import CargoHold.Options as Opts +import Control.Exception +import Control.Lens +import Data.ByteString.Conversion +import qualified Data.Map as Map +import qualified Data.Text as T +import Imports +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Util.Options + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "Configuration sanity checks" + [ test s "multiIngress and cloudFront cannot be combined" testMultiIngressCloudFrontFails, + test s "multiIngress and s3DownloadEndpoint cannot be combined" testMultiIngressS3DownloadEndpointFails + ] + +testMultiIngressCloudFrontFails :: TestM () +testMultiIngressCloudFrontFails = do + ts <- ask + let opts = + view tsOpts ts + & (Opts.aws . Opts.cloudFront) ?~ cloudFrontOptions + & (Opts.aws . Opts.multiIngress) ?~ multiIngressMap + msg <- + liftIO $ + catch + (newEnv opts >> pure "No exception") + (\(SomeException e) -> pure $ displayException e) + liftIO $ + assertBool + "Check error message" + (containsString "Invalid configuration: multiIngress and cloudFront cannot be combined!" msg) + where + cloudFrontOptions :: CloudFrontOpts + cloudFrontOptions = + CloudFrontOpts + { _domain = Domain (T.pack "example.com"), + _keyPairId = KeyPairId (T.pack "anyId"), + _privateKey = "any/path" + } + +multiIngressMap :: Map String AWSEndpoint +multiIngressMap = + Map.singleton + "red.example.com" + (toAWSEndpoint "http://s3-download.red.example.com") + +toAWSEndpoint :: ByteString -> AWSEndpoint +toAWSEndpoint = fromJust . fromByteString + +testMultiIngressS3DownloadEndpointFails :: TestM () +testMultiIngressS3DownloadEndpointFails = do + ts <- ask + let opts = + view tsOpts ts + & (Opts.aws . Opts.s3DownloadEndpoint) ?~ toAWSEndpoint "http://fake-s3:4570" + & (Opts.aws . Opts.multiIngress) ?~ multiIngressMap + msg <- + liftIO $ + catch + (newEnv opts >> pure "No exception") + (\(SomeException e) -> pure $ displayException e) + liftIO $ + assertBool + "Check error message" + (containsString "Invalid configuration: multiIngress and s3DownloadEndpoint cannot be combined!" msg) + +containsString :: String -> String -> Bool +xs `containsString` ys = any (xs `isPrefixOf`) (tails ys) diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs new file mode 100644 index 0000000000..4615fa52bf --- /dev/null +++ b/services/cargohold/test/integration/Main.hs @@ -0,0 +1,83 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . + +module Main + ( main, + ) +where + +import qualified API +import API.Federation (tests) +import qualified API.V3 +import qualified App +import Data.Proxy +import Data.Tagged +import Imports hiding (local) +import qualified Metrics +import Options.Applicative +import Test.Tasty +import Test.Tasty.Ingredients +import Test.Tasty.Options +import Test.Tasty.Runners +import Test.Tasty.Runners.AntXML +import TestSetup +import Util.Test + +newtype ServiceConfigFile = ServiceConfigFile String + deriving (Eq, Ord, Typeable) + +instance IsOption ServiceConfigFile where + defaultValue = ServiceConfigFile "/etc/wire/cargohold/conf/cargohold.yaml" + parseValue = fmap ServiceConfigFile . safeRead + optionName = pure "service-config" + optionHelp = pure "Service config file to read from" + optionCLParser = + fmap ServiceConfigFile $ + strOption $ + ( short (untag (pure 's' :: Tagged ServiceConfigFile Char)) + <> long (untag (optionName :: Tagged ServiceConfigFile String)) + <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) + ) + +main :: IO () +main = do + defaultMainWithIngredients ings $ + askOption $ \(IntegrationConfigFile configPath) -> + askOption $ \(ServiceConfigFile optsPath) -> + -- we treat the configuration file as a tasty "resource", so that we can + -- read it once before all tests + withResource + (createTestSetup optsPath configPath) + (const (pure ())) + $ \ts -> + testGroup + "Cargohold" + [ API.tests ts, + API.V3.tests ts, + Metrics.tests ts, + API.Federation.tests ts, + App.tests ts + ] + where + ings = + includingOptions + [ Option (Proxy :: Proxy ServiceConfigFile), + Option (Proxy :: Proxy IntegrationConfigFile) + ] + : listingTests + : composeReporters antXMLRunner consoleTestReporter + : defaultIngredients diff --git a/services/cargohold/test/integration/Metrics.hs b/services/cargohold/test/integration/Metrics.hs new file mode 100644 index 0000000000..0ffbeeab63 --- /dev/null +++ b/services/cargohold/test/integration/Metrics.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . + +module Metrics + ( tests, + ) +where + +import Bilge +import Bilge.Assert +import Imports +import Test.Tasty +import TestSetup + +tests :: IO TestSetup -> TestTree +tests s = testGroup "Metrics" [test s "prometheus" testPrometheusMetrics] + +testPrometheusMetrics :: TestM () +testPrometheusMetrics = do + cargohold <- viewUnversionedCargohold + get (cargohold . path "/i/metrics") !!! do + const 200 === statusCode + -- Should contain the request duration metric in its output + const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs new file mode 100644 index 0000000000..ae8d4f7362 --- /dev/null +++ b/services/cargohold/test/integration/TestSetup.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . + +module TestSetup + ( test, + tsManager, + tsEndpoint, + tsBrig, + tsOpts, + TestSetup (..), + Cargohold, + TestM, + runTestM, + viewUnversionedCargohold, + viewCargohold, + createTestSetup, + runFederationClient, + withFederationClient, + withFederationError, + apiVersion, + unversioned, + ) +where + +import Bilge hiding (body, responseBody) +import CargoHold.Options hiding (domain) +import Control.Exception (catch) +import Control.Lens +import Control.Monad.Codensity +import Control.Monad.Except +import Control.Monad.Morph +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as B8 +import Data.ByteString.Conversion +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Yaml +import Imports +import Network.HTTP.Client hiding (responseBody) +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client.TLS +import qualified Network.Wai.Utilities.Error as Wai +import Servant.Client.Streaming +import Test.Tasty +import Test.Tasty.HUnit +import Util.Options (Endpoint (..)) +import Util.Options.Common +import Util.Test +import Web.HttpApiData +import Wire.API.Federation.Domain +import Wire.API.Routes.Version + +type Cargohold = Request -> Request + +type TestM = ReaderT TestSetup Http + +mkRequest :: Endpoint -> Request -> Request +mkRequest (Endpoint h p) = Bilge.host (encodeUtf8 h) . Bilge.port p + +data TestSetup = TestSetup + { _tsManager :: Manager, + _tsEndpoint :: Endpoint, + _tsBrig :: Endpoint, + _tsOpts :: Opts + } + +makeLenses ''TestSetup + +-- | Note: Apply this function last when composing (Request -> Request) functions +apiVersion :: ByteString -> Request -> Request +apiVersion newVersion r = r {HTTP.path = setVersion newVersion (HTTP.path r)} + where + setVersion :: ByteString -> ByteString -> ByteString + setVersion v p = + let p' = removeSlash' p + in v <> "/" <> fromMaybe p' (removeVersionPrefix p') + +removeSlash' :: ByteString -> ByteString +removeSlash' s = case B8.uncons s of + Just ('/', s') -> s' + _ -> s + +removeVersionPrefix :: ByteString -> Maybe ByteString +removeVersionPrefix bs = do + let (x, s) = B8.splitAt 1 bs + guard (x == B8.pack "v") + (_, s') <- B8.readInteger s + pure (B8.tail s') + +-- | Note: Apply this function last when composing (Request -> Request) functions +unversioned :: Request -> Request +unversioned r = + r + { HTTP.path = + maybe + (HTTP.path r) + (B8.pack "/" <>) + (removeVersionPrefix . removeSlash' $ HTTP.path r) + } + +viewCargohold :: TestM Cargohold +viewCargohold = + fmap + (apiVersion (toHeader latestVersion) .) + viewUnversionedCargohold + where + latestVersion :: Version + latestVersion = maxBound + +viewUnversionedCargohold :: TestM Cargohold +viewUnversionedCargohold = mkRequest <$> view tsEndpoint + +runTestM :: TestSetup -> TestM a -> IO a +runTestM ts action = runHttpT (view tsManager ts) (runReaderT action ts) + +test :: IO TestSetup -> TestName -> TestM () -> TestTree +test s name action = testCase name $ do + ts <- s + runTestM ts action + +data IntegrationConfig = IntegrationConfig + -- internal endpoint + { cargohold :: Endpoint, + brig :: Endpoint + } + deriving (Show, Generic) + +instance FromJSON IntegrationConfig + +createTestSetup :: FilePath -> FilePath -> IO TestSetup +createTestSetup optsPath configPath = do + -- FUTUREWORK: It would actually be useful to read some + -- values from cargohold (max bytes, for instance) + -- so that tests do not need to keep those values + -- in sync and the user _knows_ what they are + m <- + newManager + tlsManagerSettings + { managerResponseTimeout = responseTimeoutMicro 300000000 + } + let localEndpoint p = Endpoint {_host = "127.0.0.1", _port = p} + iConf <- handleParseError =<< decodeFileEither configPath + opts <- decodeFileThrow optsPath + endpoint <- optOrEnv @IntegrationConfig (.cargohold) iConf (localEndpoint . read) "CARGOHOLD_WEB_PORT" + brigEndpoint <- optOrEnv @IntegrationConfig (.brig) iConf (localEndpoint . read) "BRIG_WEB_PORT" + pure $ + TestSetup + { _tsManager = m, + _tsEndpoint = endpoint, + _tsBrig = brigEndpoint, + _tsOpts = opts + } + +runFederationClient :: ClientM a -> ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a +runFederationClient action = do + man <- view tsManager + Endpoint cHost cPort <- view tsEndpoint + domain <- view (tsOpts . settings . federationDomain) + let base = BaseUrl Http (T.unpack cHost) (fromIntegral cPort) "/federation" + let env = + (mkClientEnv man base) + { makeClientRequest = \burl req -> + let req' = defaultMakeClientRequest burl req + in req' + { requestHeaders = + (originDomainHeaderName, toByteString' domain) + : requestHeaders req' + } + } + + r <- lift . lift $ + Codensity $ \k -> + -- Servant's streaming client throws exceptions in IO for some reason + catch (withClientM action env k) (k . Left) + + either throwError pure r + +hoistFederation :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> ExceptT ClientError TestM a +hoistFederation action = do + env <- ask + hoist (liftIO . lowerCodensity) $ runReaderT action env + +withFederationClient :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM a +withFederationClient action = + runExceptT (hoistFederation action) >>= \case + Left err -> + liftIO . assertFailure $ + "Unexpected federation client error: " + <> displayException err + Right x -> pure x + +withFederationError :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM Wai.Error +withFederationError action = + runExceptT (hoistFederation action) + >>= liftIO . \case + Left (FailureResponse _ resp) -> case Aeson.eitherDecode (responseBody resp) of + Left err -> assertFailure $ "Error while parsing error response: " <> err + Right e -> (Wai.code e @?= responseStatusCode resp) $> e + Left err -> assertFailure $ "Unexpected federation client error: " <> displayException err + Right _ -> assertFailure "Unexpected success" From bb1f754390e1bd12b5ed30b8fcd358dff9bec721 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 22 Nov 2023 12:52:08 +1000 Subject: [PATCH 05/22] One test down, 5 more to go --- integration/test/API/Cargohold.hs | 6 +++++- integration/test/Test/Cargohold/API.hs | 18 +++++++----------- integration/test/Test/Cargohold/API/Util.hs | 3 +-- 3 files changed, 13 insertions(+), 14 deletions(-) diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index 1daf7ec2ec..aa177cfbce 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -7,6 +7,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBSC import Data.Text qualified as T import GHC.Stack +import Network.HTTP.Client (Request (redirectCount)) import Network.HTTP.Client qualified as HTTP import Test.Cargohold.API.Util import Testlib.Prelude @@ -100,11 +101,14 @@ instance MakesValue loc => IsAssetLocation loc where key <- asString v pure $ "v1/asssets/v3/" <> key +noRedirect :: Request -> Request +noRedirect r = r {redirectCount = 0} + downloadAsset' :: (HasCallStack, MakesValue user, IsAssetLocation loc, IsAssetToken tok) => user -> loc -> tok -> App Response downloadAsset' user loc tok = do locPath <- locationPathFragment loc req <- baseRequest user Cargohold Unversioned $ locPath - let req' = req & tokenParam tok + let req' = req & tokenParam tok & noRedirect print req' submit "GET" req' diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 9de64f1ade..110cdd9992 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -149,17 +149,15 @@ testSimpleS3ClosedConnectionReuse = go >> wait >> go let part2 = (MIME.Text $ cs "plain", replicate 100000 'c') uploadSimple uid sets part2 >>= \r -> r.status `shouldMatchInt` 201 -cargoholdOverride :: Value -> App Value -cargoholdOverride v = case v of - Object o -> print o >> pure v - _ -> pure v - testDownloadURLOverride :: HasCallStack => App () testDownloadURLOverride = do - startDynamicBackends [def {cargoholdCfg = cargoholdOverride}] $ \[d] -> do - -- This is a .example domain, it shouldn't resolve. But it is also not - -- supposed to be used by cargohold to make connections. - let downloadEndpoint = "external-s3-url.example" + -- This is a .example domain, it shouldn't resolve. But it is also not + -- supposed to be used by cargohold to make connections. + let downloadEndpoint = "external-s3-url.example" + -- Stick the protocol on here, as the checks don't want to see it, + -- they are just looking for the host name. + f = setField "aws.s3DownloadEndpoint" ("https://" <> downloadEndpoint) + startDynamicBackends [def {cargoholdCfg = f}] $ \[d] -> do -- withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do uid <- randomUser d def -- Upload, should work, shouldn't try to use the S3DownloadEndpoint @@ -174,8 +172,6 @@ testDownloadURLOverride = do <*> lookupField uploadRes.json "expires" -- Lookup with token and get download URL. Should return the -- S3DownloadEndpoint, but not try to use it. - print loc - print tok downloadURLRes <- downloadAsset' uid loc tok downloadURLRes.status `shouldMatchInt` 302 cs @_ @String downloadURLRes.body `shouldMatch` "" diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 1d61a4473e..5967a9ca09 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -20,6 +20,7 @@ module Test.Cargohold.API.Util where import Codec.MIME.Parse qualified as MIME import Codec.MIME.Type qualified as MIME import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as Aeson import Data.ByteString.Builder import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as LBS @@ -34,7 +35,6 @@ import Network.HTTP.Client (Request (requestHeaders)) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types.Header import Testlib.Prelude -import qualified Data.Aeson.KeyMap as Aeson uploadSimple :: (HasCallStack, MakesValue user, MakesValue settings) => @@ -132,7 +132,6 @@ instance IsAssetToken Value where instance IsAssetToken (Request -> Request) where tokenParam = id - downloadAssetWithQualifiedAssetKey :: (HasCallStack, IsAssetToken tok, MakesValue key, MakesValue user) => (HTTP.Request -> HTTP.Request) -> From c195fa3020bad18ce3c0b841629996c9a53d621a Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 22 Nov 2023 17:26:19 +1000 Subject: [PATCH 06/22] Fixing more tests, now only a couple are broken --- integration/test/Test/Cargohold/API.hs | 41 ++++++++++----------- integration/test/Test/Cargohold/API/Util.hs | 7 ++-- integration/test/Test/Cargohold/API/V3.hs | 19 +++++----- 3 files changed, 32 insertions(+), 35 deletions(-) diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 110cdd9992..e5680f9d49 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -22,7 +22,6 @@ module Test.Cargohold.API where import API.Cargohold import Codec.MIME.Type qualified as MIME import Control.Lens hiding (sets, (.=)) -import Data.Aeson qualified as Aeson import Data.Aeson.Types (Pair) import Data.ByteString.Char8 qualified as C8 import Data.ByteString.Lazy qualified as LBS hiding (replicate) @@ -42,8 +41,8 @@ import UnliftIO.Concurrent testDownloadWithAcceptHeader :: HasCallStack => App () testDownloadWithAcceptHeader = do assetId <- randomId - uid <- randomId - domain <- make OtherDomain + uid <- randomUser OwnDomain def + domain <- make OwnDomain let key = "3-2-" <> assetId qkey = object ["domain" .= domain, "id" .= key] res <- downloadAssetWithQualifiedAssetKey (header "Accept" "image/jpeg") uid qkey () @@ -61,7 +60,7 @@ get' r f = submit "GET" $ f r testSimpleTokens :: HasCallStack => App () testSimpleTokens = do uid <- randomUser OwnDomain def - uid2 <- randomId + uid2 <- randomUser OwnDomain def -- Initial upload let sets = object ["public" .= False, "rentention" .= "volatile"] let bdy = (applicationText, "Hello World") @@ -70,12 +69,10 @@ testSimpleTokens = do loc <- maybe (assertFailure "Could not get \"Location\" header from the request") (pure . cs @_ @String) $ getHeader (mk $ cs "Location") r1 - (key, tok, _expires) <- - (,,) - <$> r1.json %. "key" + (key, tok) <- + (,) + <$> asString (r1.json %. "key") <*> r1.json %. "token" - <*> r1.json %. "expires" - qKey <- key %. "id" & asString -- No access without token from other user (opaque 404) downloadAsset' uid2 loc () >>= \r -> r.status `shouldMatchInt` 404 -- No access with empty token query parameter from other user (opaque 404) @@ -85,15 +82,15 @@ testSimpleTokens = do -- No access with wrong token as query parameter (opaque 404) downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> r.status `shouldMatchInt` 404 -- Token renewal fails if not done by owner - postToken uid2 qKey >>= \r -> do + postToken uid2 key >>= \r -> do r.status `shouldMatchInt` 403 label <- traverse ((%. "label") >=> asString) r.jsonBody label `shouldMatch` "unauthorised" -- Token renewal succeeds if done by owner - r2 <- postToken uid qKey + r2 <- postToken uid key r2.status `shouldMatchInt` 200 - let Just tok' = r2.jsonBody <&> \t -> object ["token" .= t] - assertBool "token unchanged" (tok /= tok') + tok' <- r2.jsonBody %. "token" & asString + assertBool "token unchanged" (tok /= String (cs tok')) -- Download by owner with new token. r3 <- downloadAsset' uid loc tok' r3.status `shouldMatchInt` 302 @@ -102,27 +99,29 @@ testSimpleTokens = do r4.status `shouldMatchInt` 200 let r4ContentType :: Maybe String r4ContentType = cs @_ @String <$> getHeader (mk $ cs "content-type") r4 - r4ContentType `shouldMatch` Just (show applicationOctetStream) + r4ContentType `shouldMatch` Just (cs @_ @String $ MIME.showMIMEType applicationOctetStream) let r4Tok :: Maybe String r4Tok = cs @_ @String <$> getHeader (mk $ cs "x-amz-meta-token") r4 r4Tok `shouldMatch` Just tok' let r4User :: Maybe String r4User = cs @_ @String <$> getHeader (mk $ cs "x-amz-meta-user") r4 - r4User `shouldMatch` Just uid + r4User `shouldMatch` fmap Just (uid %. "id") cs @_ @String r4.body `shouldMatch` "Hello World" -- Verify access without token if the request comes from the creator. downloadAsset' uid loc () >>= \r -> r.status `shouldMatchInt` 302 -- Verify access with new token from a different user. downloadAsset' uid2 loc tok' >>= \r -> r.status `shouldMatchInt` 302 -- Verify access with new token as query parameter from a different user - downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure . cs $ Aeson.encode tok')) >>= \r -> r.status `shouldMatchInt` 302 + print tok' + downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) + >>= \r -> r.status `shouldMatchInt` 302 -- Delete Token fails if not done by owner - deleteToken uid2 qKey >>= \r -> do + deleteToken uid2 key >>= \r -> do r.status `shouldMatchInt` 403 label <- traverse ((%. "label") >=> asString) r.jsonBody label `shouldMatch` "unauthorised" -- Delete Token succeeds by owner - deleteToken uid qKey >>= \r -> do + deleteToken uid key >>= \r -> do r.status `shouldMatchInt` 200 cs @_ @String r.body `shouldMatch` "" -- Access without token from different user (asset is now "public") @@ -204,7 +203,7 @@ testUploadCompatibility = do r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' locHeader r2)) r3.status `shouldMatchInt` 200 assertBool "Content types should match" $ getContentType r3 == Just applicationOctetStream' - decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` uid + decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id") cs @_ @String r3.body `shouldMatch` Just "test" where exampleMultipart :: LBS.ByteString @@ -230,11 +229,11 @@ testUploadCompatibility = do testRemoteDownloadWrongDomain :: HasCallStack => App () testRemoteDownloadWrongDomain = do assetId <- randomId - uid <- randomId + uid <- randomUser OwnDomain def let key = toJSON $ "3-2-" <> assetId qkey = object - [ "id" .= key, + [ "key" .= key, "domain" .= "invalid.example.com" ] res <- downloadAsset' uid qkey () diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 5967a9ca09..61723f5af4 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -67,10 +67,9 @@ uploadRaw :: App Response uploadRaw usr bs = do req <- baseRequest usr Cargohold (ExplicitVersion 1) "assets/v3" - submit "POST" $ - req - & contentTypeMixed - & (\r -> r {HTTP.requestBody = HTTP.RequestBodyLBS bs}) + let req' = req & contentTypeMixed & (\r -> r {HTTP.requestBody = HTTP.RequestBodyLBS bs}) + print req' + submit "POST" req' getContentType :: Response -> Maybe MIME.Type getContentType = MIME.parseContentType . decodeLatin1 . getHeader' (mk $ cs "Content-Type") diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index 07a7f854f0..52d6ded5a7 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -38,24 +38,21 @@ import Testlib.Prelude testSimpleRoundtrip :: HasCallStack => App () testSimpleRoundtrip = do - let defSettings = - [ "public" .= False - ] - let rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] - let allSets = - fmap object $ - defSettings : fmap (\r -> defSettings <> ["retention" .= r]) rets + let defSettings = ["public" .= False] + rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] + allSets = fmap (object . (\r -> defSettings <> ["retention" .= r])) rets mapM_ simpleRoundtrip allSets where simpleRoundtrip :: HasCallStack => Value -> App () simpleRoundtrip sets = do uid <- randomUser OwnDomain def - uid2 <- randomId + uid2 <- randomUser OwnDomain def -- Initial upload let bdy = (applicationText, "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 - print r1.jsonBody + print sets + print r1 -- use v3 path instead of the one returned in the header (key, tok, expires) <- (,,) @@ -75,11 +72,13 @@ testSimpleRoundtrip = do Object o -> case KM.lookup (fromString "retention") o of Nothing -> pure () Just _r -> do + print utc + print expires' assertBool "invalid expiration" (Just utc < expires') _ -> pure () -- Lookup with token and download via redirect. r2 <- downloadAsset' uid key tok - print r2.body + print r2 r2.status `shouldMatchInt` 302 assertBool "Response body should be empty" $ r2.body == mempty From 5600a5c1dad739920f5ccbe5961237c1fc9d0035 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Thu, 23 Nov 2023 14:38:27 +1000 Subject: [PATCH 07/22] WPB-5382: Another test fixed, with a lot of head-scratching involved --- integration/test/API/Cargohold.hs | 4 +-- integration/test/Test/Cargohold/API/Util.hs | 6 ++-- integration/test/Test/Cargohold/API/V3.hs | 28 +++++++++++++------ .../cargohold/test/integration/API/Util.hs | 3 +- services/cargohold/test/integration/API/V3.hs | 20 +++++++++++++ 5 files changed, 44 insertions(+), 17 deletions(-) diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index aa177cfbce..3c36fd0369 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -108,9 +108,7 @@ downloadAsset' :: (HasCallStack, MakesValue user, IsAssetLocation loc, IsAssetTo downloadAsset' user loc tok = do locPath <- locationPathFragment loc req <- baseRequest user Cargohold Unversioned $ locPath - let req' = req & tokenParam tok & noRedirect - print req' - submit "GET" req' + submit "GET" $ req & tokenParam tok & noRedirect downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response downloadAsset user assetDomain key zHostHeader trans = do diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 61723f5af4..5bf1baa551 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -67,9 +67,7 @@ uploadRaw :: App Response uploadRaw usr bs = do req <- baseRequest usr Cargohold (ExplicitVersion 1) "assets/v3" - let req' = req & contentTypeMixed & (\r -> r {HTTP.requestBody = HTTP.RequestBodyLBS bs}) - print req' - submit "POST" req' + submit "POST" $ req & contentTypeMixed & (\r -> r {HTTP.requestBody = HTTP.RequestBodyLBS bs}) getContentType :: Response -> Maybe MIME.Type getContentType = MIME.parseContentType . decodeLatin1 . getHeader' (mk $ cs "Content-Type") @@ -85,7 +83,7 @@ applicationOctetStream' = MIME.Type applicationOctetStream [] deleteAssetV3 :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response deleteAssetV3 user key = do - k <- key %. "id" & asString + k <- key %. "key" & asString req <- baseRequest user Cargohold (ExplicitVersion 1) $ "assets/v3/" <> k submit "DELETE" req diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index 52d6ded5a7..c87c8899f3 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -28,6 +28,7 @@ import Data.String.Conversions import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Format +import Data.Time.Format.ISO8601 import Network.HTTP.Client import SetupHelpers import Test.Cargohold.API.Util @@ -40,7 +41,7 @@ testSimpleRoundtrip :: HasCallStack => App () testSimpleRoundtrip = do let defSettings = ["public" .= False] rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] - allSets = fmap (object . (\r -> defSettings <> ["retention" .= r])) rets + allSets = fmap object $ (defSettings :) $ (\r -> ["retention" .= r]) <$> rets mapM_ simpleRoundtrip allSets where simpleRoundtrip :: HasCallStack => Value -> App () @@ -51,7 +52,9 @@ testSimpleRoundtrip = do let bdy = (applicationText, "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 + putStrLn "sets = " print sets + putStrLn "r1 = " print r1 -- use v3 path instead of the one returned in the header (key, tok, expires) <- @@ -62,8 +65,9 @@ testSimpleRoundtrip = do -- Check mandatory Date header let Just date = C8.unpack <$> lookup (mk $ cs "Date") r1.headers parseTime = parseTimeOrError False defaultTimeLocale rfc822DateFormat + parseTimeIso t = fromMaybe (error $ "Could not parse \"" <> t <> "\" as ISO8601") $ formatParseM (iso8601Format @UTCTime) t utc = parseTime date :: UTCTime - expires' = parseTime <$> expires :: Maybe UTCTime + expires' = parseTimeIso <$> expires :: Maybe UTCTime -- Potentially check for the expires header case sets of -- We don't care what the rentention value is here, @@ -71,13 +75,19 @@ testSimpleRoundtrip = do -- to be done. Object o -> case KM.lookup (fromString "retention") o of Nothing -> pure () - Just _r -> do - print utc - print expires' - assertBool "invalid expiration" (Just utc < expires') + Just r -> do + r' <- asString r + -- These retention policies never expire, so an expiration date isn't sent back + unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") $ do + putStrLn "utc =" + print utc + putStrLn "expires' = " + print expires' + assertBool "invalid expiration" (Just utc < expires') _ -> pure () -- Lookup with token and download via redirect. - r2 <- downloadAsset' uid key tok + r2 <- downloadAsset' uid r1.jsonBody tok + putStrLn "r2 = " print r2 r2.status `shouldMatchInt` 302 assertBool "Response body should be empty" $ r2.body == mempty @@ -93,9 +103,9 @@ testSimpleRoundtrip = do assertBool "User mismatch" $ getHeader (mk $ cs "x-amz-meta-user") r3 == pure (cs uid') assertBool "Data mismatch" $ r3.body == cs "Hello World" -- Delete (forbidden for other users) - deleteAssetV3 uid2 key >>= \r -> r.status `shouldMatchInt` 403 + deleteAssetV3 uid2 r1.jsonBody >>= \r -> r.status `shouldMatchInt` 403 -- Delete (allowed for creator) - deleteAssetV3 uid key >>= \r -> r.status `shouldMatchInt` 200 + deleteAssetV3 uid r1.jsonBody >>= \r -> r.status `shouldMatchInt` 200 r4 <- downloadAsset' uid key tok r4.status `shouldMatchInt` 404 let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers diff --git a/services/cargohold/test/integration/API/Util.hs b/services/cargohold/test/integration/API/Util.hs index 59ea794f59..9f8ab6dc75 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/services/cargohold/test/integration/API/Util.hs @@ -36,6 +36,7 @@ import Data.Qualified import Data.Text.Encoding (decodeLatin1, encodeUtf8) import qualified Data.UUID as UUID import Data.UUID.V4 (nextRandom) +import Debug.Trace import Federator.MockServer import Imports hiding (head) import qualified Network.HTTP.Media as HTTP @@ -125,7 +126,7 @@ zConn = header "Z-Connection" deleteAssetV3 :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) deleteAssetV3 u k = do c <- viewUnversionedCargohold - delete $ apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] + delete $ traceShowId . apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] deleteAsset :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) deleteAsset u k = do diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index 5560905f92..8d05f8b2d3 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -29,6 +29,7 @@ import Data.Qualified import Data.Time.Clock import Data.Time.Format import Data.UUID.V4 +import Debug.Trace (traceShowM) import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Types.Status (status200) @@ -57,6 +58,11 @@ testSimpleRoundtrip = do mapM_ simpleRoundtrip sets where simpleRoundtrip sets = do + putStrLn "----------------------------------------------" + putStrLn "----------------------------------------------" + putStrLn "----------------------------------------------" + putStrLn "sets = " + traceShowM sets uid <- randomUser uid2 <- liftIO $ Id <$> nextRandom -- Initial upload @@ -64,8 +70,12 @@ testSimpleRoundtrip = do r1 <- uploadSimple (path "/assets/v3") uid sets bdy Date: Thu, 23 Nov 2023 16:33:32 +1000 Subject: [PATCH 08/22] Fixing the last test, and it was a typo in a url. --- integration/test/Test/Cargohold/API.hs | 58 ++++++++++++++----- integration/test/Test/Cargohold/API/Util.hs | 5 +- services/cargohold/test/integration/API.hs | 6 ++ .../cargohold/test/integration/API/Util.hs | 9 +-- 4 files changed, 60 insertions(+), 18 deletions(-) diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index e5680f9d49..441ddd2f28 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -57,45 +57,69 @@ queryItem k v r = get' :: HTTP.Request -> (HTTP.Request -> HTTP.Request) -> App Response get' r f = submit "GET" $ f r +foo :: Show a => String -> a -> App () +foo s a = putStrLn s *> print a + testSimpleTokens :: HasCallStack => App () testSimpleTokens = do uid <- randomUser OwnDomain def uid2 <- randomUser OwnDomain def -- Initial upload - let sets = object ["public" .= False, "rentention" .= "volatile"] + let sets = object ["public" .= False, "retention" .= "volatile"] let bdy = (applicationText, "Hello World") + putStrLn "----------------------------" + putStrLn "----------------------------" + putStrLn "----------------------------" + foo "sets" sets + foo "bdy" bdy r1 <- uploadSimple uid sets bdy + foo "r1" r1 r1.status `shouldMatchInt` 201 loc <- - maybe (assertFailure "Could not get \"Location\" header from the request") (pure . cs @_ @String) $ - getHeader (mk $ cs "Location") r1 + maybe + (assertFailure "Could not get \"Location\" header from the request") + (pure . cs @_ @String) + $ getHeader (mk $ cs "Location") r1 + foo "loc" loc (key, tok) <- (,) <$> asString (r1.json %. "key") <*> r1.json %. "token" -- No access without token from other user (opaque 404) - downloadAsset' uid2 loc () >>= \r -> r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc () >>= \r -> do + foo "r' 1" r + r.status `shouldMatchInt` 404 -- No access with empty token query parameter from other user (opaque 404) - downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \r -> r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \r -> do + foo "r' 2" r + r.status `shouldMatchInt` 404 -- No access with wrong token (opaque 404) - downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \r -> r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \r -> do + foo "r' 3" r + r.status `shouldMatchInt` 404 -- No access with wrong token as query parameter (opaque 404) - downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> do + foo "r' 4" r + r.status `shouldMatchInt` 404 -- Token renewal fails if not done by owner postToken uid2 key >>= \r -> do + foo "r' 5" r r.status `shouldMatchInt` 403 label <- traverse ((%. "label") >=> asString) r.jsonBody label `shouldMatch` "unauthorised" -- Token renewal succeeds if done by owner r2 <- postToken uid key + foo "r2" r2 r2.status `shouldMatchInt` 200 tok' <- r2.jsonBody %. "token" & asString assertBool "token unchanged" (tok /= String (cs tok')) -- Download by owner with new token. r3 <- downloadAsset' uid loc tok' + foo "r3" r3 r3.status `shouldMatchInt` 302 cs @_ @String r3.body `shouldMatch` "" r4 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r3)) + foo "r4" r4 r4.status `shouldMatchInt` 200 let r4ContentType :: Maybe String r4ContentType = cs @_ @String <$> getHeader (mk $ cs "content-type") r4 @@ -108,24 +132,32 @@ testSimpleTokens = do r4User `shouldMatch` fmap Just (uid %. "id") cs @_ @String r4.body `shouldMatch` "Hello World" -- Verify access without token if the request comes from the creator. - downloadAsset' uid loc () >>= \r -> r.status `shouldMatchInt` 302 + downloadAsset' uid loc () >>= \r -> do + foo "r' 6" r + r.status `shouldMatchInt` 302 -- Verify access with new token from a different user. - downloadAsset' uid2 loc tok' >>= \r -> r.status `shouldMatchInt` 302 + downloadAsset' uid2 loc tok' >>= \r -> do + foo "r' 7" r + r.status `shouldMatchInt` 302 -- Verify access with new token as query parameter from a different user print tok' - downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) - >>= \r -> r.status `shouldMatchInt` 302 + downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) >>= \r -> do + foo "r' 8" r + r.status `shouldMatchInt` 302 -- Delete Token fails if not done by owner deleteToken uid2 key >>= \r -> do + foo "r' 9" r r.status `shouldMatchInt` 403 - label <- traverse ((%. "label") >=> asString) r.jsonBody - label `shouldMatch` "unauthorised" + label' <- traverse ((%. "label") >=> asString) r.jsonBody + label' `shouldMatch` "unauthorised" -- Delete Token succeeds by owner deleteToken uid key >>= \r -> do + foo "r' 10" r r.status `shouldMatchInt` 200 cs @_ @String r.body `shouldMatch` "" -- Access without token from different user (asset is now "public") downloadAsset' uid2 loc () >>= \r -> do + foo "r' 11" r r.status `shouldMatchInt` 302 cs @_ @String r.body `shouldMatch` "" diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 5bf1baa551..f4495e0c49 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -152,9 +152,12 @@ postToken user key = do deleteToken :: (MakesValue user, HasCallStack) => user -> String -> App Response deleteToken user key = do - req <- baseRequest user Cargohold Versioned $ "asserts/" <> key <> "/token" + req <- baseRequest user Cargohold Versioned $ "assets/" <> key <> "/token" submit "DELETE" req +rmZConn :: Request -> Request +rmZConn r = r {HTTP.requestHeaders = filter (\(n, _) -> n /= mk (cs "Z-Connection")) $ HTTP.requestHeaders r} + -- | Build a complete @multipart/mixed@ request body for a one-shot, -- non-resumable asset upload. buildMultipartBody :: (HasCallStack, MakesValue header) => header -> Lazy.ByteString -> MIME.MIMEType -> App Lazy.ByteString diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index 47428f0ea3..a966c423a9 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -151,6 +151,8 @@ testSimpleTokens = do r1 <- uploadSimple (path "/assets/v3") uid sets bdy AssetKey -> TestM (Response (Maybe LByteString)) deleteToken uid key = do c <- viewCargohold - delete $ - c - . zUser uid - . paths ["assets", toByteString' key, "token"] + fmap traceShowId $ + delete $ + c + . zUser uid + . paths ["assets", toByteString' key, "token"] viewFederationDomain :: TestM Domain viewFederationDomain = view (tsOpts . settings . federationDomain) From c1c5d178c10acaae463cb1353808faf6b3115af7 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Thu, 23 Nov 2023 16:39:33 +1000 Subject: [PATCH 09/22] WPB-5382: Removing debug statements, and touching up the code --- integration/test/Test/Cargohold/API.hs | 47 ++++--------------- integration/test/Test/Cargohold/API/Util.hs | 3 -- services/cargohold/test/integration/API.hs | 6 --- .../cargohold/test/integration/API/Util.hs | 12 ++--- services/cargohold/test/integration/API/V3.hs | 25 ++-------- 5 files changed, 16 insertions(+), 77 deletions(-) diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 441ddd2f28..411510dcef 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -57,69 +57,47 @@ queryItem k v r = get' :: HTTP.Request -> (HTTP.Request -> HTTP.Request) -> App Response get' r f = submit "GET" $ f r -foo :: Show a => String -> a -> App () -foo s a = putStrLn s *> print a - testSimpleTokens :: HasCallStack => App () testSimpleTokens = do uid <- randomUser OwnDomain def uid2 <- randomUser OwnDomain def -- Initial upload let sets = object ["public" .= False, "retention" .= "volatile"] - let bdy = (applicationText, "Hello World") - putStrLn "----------------------------" - putStrLn "----------------------------" - putStrLn "----------------------------" - foo "sets" sets - foo "bdy" bdy + bdy = (applicationText, "Hello World") r1 <- uploadSimple uid sets bdy - foo "r1" r1 r1.status `shouldMatchInt` 201 loc <- maybe (assertFailure "Could not get \"Location\" header from the request") (pure . cs @_ @String) $ getHeader (mk $ cs "Location") r1 - foo "loc" loc (key, tok) <- (,) <$> asString (r1.json %. "key") <*> r1.json %. "token" -- No access without token from other user (opaque 404) - downloadAsset' uid2 loc () >>= \r -> do - foo "r' 1" r - r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc () >>= \r -> r.status `shouldMatchInt` 404 -- No access with empty token query parameter from other user (opaque 404) - downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \r -> do - foo "r' 2" r - r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc (queryItem (cs "asset_token") Nothing) >>= \r -> r.status `shouldMatchInt` 404 -- No access with wrong token (opaque 404) - downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \r -> do - foo "r' 3" r - r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc (header "Asset-Token" "abc123") >>= \r -> r.status `shouldMatchInt` 404 -- No access with wrong token as query parameter (opaque 404) - downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> do - foo "r' 4" r - r.status `shouldMatchInt` 404 + downloadAsset' uid2 loc (queryItem (cs "asset_token") $ pure $ cs "acb123") >>= \r -> r.status `shouldMatchInt` 404 -- Token renewal fails if not done by owner postToken uid2 key >>= \r -> do - foo "r' 5" r r.status `shouldMatchInt` 403 label <- traverse ((%. "label") >=> asString) r.jsonBody label `shouldMatch` "unauthorised" -- Token renewal succeeds if done by owner r2 <- postToken uid key - foo "r2" r2 r2.status `shouldMatchInt` 200 tok' <- r2.jsonBody %. "token" & asString assertBool "token unchanged" (tok /= String (cs tok')) -- Download by owner with new token. r3 <- downloadAsset' uid loc tok' - foo "r3" r3 r3.status `shouldMatchInt` 302 cs @_ @String r3.body `shouldMatch` "" r4 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r3)) - foo "r4" r4 r4.status `shouldMatchInt` 200 let r4ContentType :: Maybe String r4ContentType = cs @_ @String <$> getHeader (mk $ cs "content-type") r4 @@ -132,32 +110,23 @@ testSimpleTokens = do r4User `shouldMatch` fmap Just (uid %. "id") cs @_ @String r4.body `shouldMatch` "Hello World" -- Verify access without token if the request comes from the creator. - downloadAsset' uid loc () >>= \r -> do - foo "r' 6" r - r.status `shouldMatchInt` 302 + downloadAsset' uid loc () >>= \r -> r.status `shouldMatchInt` 302 -- Verify access with new token from a different user. - downloadAsset' uid2 loc tok' >>= \r -> do - foo "r' 7" r - r.status `shouldMatchInt` 302 + downloadAsset' uid2 loc tok' >>= \r -> r.status `shouldMatchInt` 302 -- Verify access with new token as query parameter from a different user - print tok' - downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) >>= \r -> do - foo "r' 8" r + downloadAsset' uid2 loc (queryItem (cs "asset_token") (pure $ cs tok')) >>= \r -> r.status `shouldMatchInt` 302 -- Delete Token fails if not done by owner deleteToken uid2 key >>= \r -> do - foo "r' 9" r r.status `shouldMatchInt` 403 label' <- traverse ((%. "label") >=> asString) r.jsonBody label' `shouldMatch` "unauthorised" -- Delete Token succeeds by owner deleteToken uid key >>= \r -> do - foo "r' 10" r r.status `shouldMatchInt` 200 cs @_ @String r.body `shouldMatch` "" -- Access without token from different user (asset is now "public") downloadAsset' uid2 loc () >>= \r -> do - foo "r' 11" r r.status `shouldMatchInt` 302 cs @_ @String r.body `shouldMatch` "" diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index f4495e0c49..b457748b63 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -155,9 +155,6 @@ deleteToken user key = do req <- baseRequest user Cargohold Versioned $ "assets/" <> key <> "/token" submit "DELETE" req -rmZConn :: Request -> Request -rmZConn r = r {HTTP.requestHeaders = filter (\(n, _) -> n /= mk (cs "Z-Connection")) $ HTTP.requestHeaders r} - -- | Build a complete @multipart/mixed@ request body for a one-shot, -- non-resumable asset upload. buildMultipartBody :: (HasCallStack, MakesValue header) => header -> Lazy.ByteString -> MIME.MIMEType -> App Lazy.ByteString diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index a966c423a9..47428f0ea3 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -151,8 +151,6 @@ testSimpleTokens = do r1 <- uploadSimple (path "/assets/v3") uid sets bdy Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) deleteAssetV3 u k = do c <- viewUnversionedCargohold - delete $ traceShowId . apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] + delete $ apiVersion "v1" . c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] deleteAsset :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) deleteAsset u k = do @@ -204,11 +203,10 @@ postToken uid key = do deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) deleteToken uid key = do c <- viewCargohold - fmap traceShowId $ - delete $ - c - . zUser uid - . paths ["assets", toByteString' key, "token"] + delete $ + c + . zUser uid + . paths ["assets", toByteString' key, "token"] viewFederationDomain :: TestM Domain viewFederationDomain = view (tsOpts . settings . federationDomain) diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index 8d05f8b2d3..0bc0b49903 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -29,7 +29,6 @@ import Data.Qualified import Data.Time.Clock import Data.Time.Format import Data.UUID.V4 -import Debug.Trace (traceShowM) import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Types.Status (status200) @@ -58,11 +57,6 @@ testSimpleRoundtrip = do mapM_ simpleRoundtrip sets where simpleRoundtrip sets = do - putStrLn "----------------------------------------------" - putStrLn "----------------------------------------------" - putStrLn "----------------------------------------------" - putStrLn "sets = " - traceShowM sets uid <- randomUser uid2 <- liftIO $ Id <$> nextRandom -- Initial upload @@ -70,36 +64,23 @@ testSimpleRoundtrip = do r1 <- uploadSimple (path "/assets/v3") uid sets bdy lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime -- Potentially check for the expires header - when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do - putStrLn "sets ^. setAssetRetention" - print $ sets ^. setAssetRetention - putStrLn "Just utc" - print $ Just utc - putStrLn "view assetExpires ast" - print $ view assetExpires ast - liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) + when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ + liftIO $ + assertBool "invalid expiration" (Just utc < view assetExpires ast) -- Lookup with token and download via redirect. r2 <- downloadAsset uid key (Just tok) Date: Thu, 23 Nov 2023 16:42:41 +1000 Subject: [PATCH 10/22] WPB-5382: Adding a changelog --- changelog.d/5-internal/WPB-5382 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/WPB-5382 diff --git a/changelog.d/5-internal/WPB-5382 b/changelog.d/5-internal/WPB-5382 new file mode 100644 index 0000000000..e62e7ced91 --- /dev/null +++ b/changelog.d/5-internal/WPB-5382 @@ -0,0 +1 @@ +Migrating tests for Cargohold to the new `integration` test suite. \ No newline at end of file From 6ebc676e796a73f8cc6eb706eb416d4590684e1b Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Thu, 23 Nov 2023 16:45:00 +1000 Subject: [PATCH 11/22] WPB-5382: Reducing the diff --- integration/test/Test/Cargohold/API/Util.hs | 2 +- services/cargohold/test/integration/API/V3.hs | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index b457748b63..9cfe3ed171 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -105,7 +105,7 @@ downloadAssetWithAssetKey :: String -> App Response downloadAssetWithAssetKey r user tok = do - req <- baseRequest user Cargohold (ExplicitVersion 1) $ "asserts/v3/" <> tok + req <- baseRequest user Cargohold (ExplicitVersion 1) $ "assets/v3/" <> tok submit "GET" $ r $ req & tokenParam tok class IsAssetToken tok where diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index 0bc0b49903..5560905f92 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -72,9 +72,8 @@ testSimpleRoundtrip = do let Just date = C8.unpack <$> lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime -- Potentially check for the expires header - when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ - liftIO $ - assertBool "invalid expiration" (Just utc < view assetExpires ast) + when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do + liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) -- Lookup with token and download via redirect. r2 <- downloadAsset uid key (Just tok) Date: Fri, 24 Nov 2023 10:11:03 +1000 Subject: [PATCH 12/22] WPB-5382: Moving another test over --- integration/test/Test/Cargohold/API.hs | 59 +++++ integration/test/Test/Cargohold/API/Util.hs | 4 +- integration/test/Test/Cargohold/API/V3.hs | 12 +- services/cargohold/cargohold.cabal | 1 - services/cargohold/test/integration/API.hs | 242 +----------------- services/cargohold/test/integration/API/V3.hs | 98 ------- services/cargohold/test/integration/Main.hs | 2 - 7 files changed, 63 insertions(+), 355 deletions(-) delete mode 100644 services/cargohold/test/integration/API/V3.hs diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 411510dcef..393c91b7f5 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -22,11 +22,14 @@ module Test.Cargohold.API where import API.Cargohold import Codec.MIME.Type qualified as MIME import Control.Lens hiding (sets, (.=)) +import Data.Aeson.KeyMap qualified as KM import Data.Aeson.Types (Pair) import Data.ByteString.Char8 qualified as C8 import Data.ByteString.Lazy qualified as LBS hiding (replicate) import Data.CaseInsensitive (mk) import Data.String.Conversions +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError, rfc822DateFormat) +import Data.Time.Format.ISO8601 (formatParseM, iso8601Format) import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types qualified as HTTP @@ -38,6 +41,62 @@ import UnliftIO.Concurrent -------------------------------------------------------------------------------- -- Simple (single-step) uploads +testSimpleRoundtrip :: HasCallStack => App () +testSimpleRoundtrip = do + let def' = ["public" .= False] + rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] + sets' = fmap object $ def' : fmap (\r -> "retention" .= r : def') rets + mapM_ simpleRoundtrip sets' + where + simpleRoundtrip :: HasCallStack => Value -> App () + simpleRoundtrip sets = do + uid <- randomUser OwnDomain def + userId1 <- uid %. "id" & asString + uid2 <- randomUser OwnDomain def + -- Initial upload + let bdy = (applicationText, "Hello World") + r1 <- uploadSimple uid sets bdy + r1.status `shouldMatchInt` 201 + loc <- maybe (error "Could not find the Location header") (pure . cs @_ @String) $ lookup (mk $ cs "Location") r1.headers + (tok, expires) <- + (,) + <$> asString (r1.json %. "token") + <*> (lookupField r1.json "expires" >>= maybe (pure Nothing) (fmap pure . asString)) + -- Check mandatory Date header + let Just date = C8.unpack <$> lookup (mk $ cs "Date") r1.headers + utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime + parseTimeIso t = fromMaybe (error $ "Could not parse \"" <> t <> "\" as ISO8601") $ formatParseM (iso8601Format @UTCTime) t + expires' = parseTimeIso <$> expires :: Maybe UTCTime + -- Potentially check for the expires header + case sets of + Object o -> case KM.lookup (fromString "retention") o of + Nothing -> pure () + Just r -> do + r' <- asString r + -- These retention policies never expire, so an expiration date isn't sent back + unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") $ + assertBool "invalid expiration" (Just utc < expires') + _ -> pure () + -- Lookup with token and download via redirect. + r2 <- downloadAsset' uid loc tok + r2.status `shouldMatchInt` 302 + cs @_ @String r2.body `shouldMatch` "" + r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r2)) + r3.status `shouldMatchInt` 200 + assertBool "content-type should always be application/octet-stream" $ Just applicationOctetStream == fmap MIME.mimeType (getContentType r3) + assertBool "token mismatch" $ tok == decodeHeaderOrFail (mk $ cs "x-amz-meta-token") r3 + assertBool "user mismatch" $ userId1 == decodeHeaderOrFail (mk $ cs "x-amz-meta-user") r3 + assertBool "data mismatch" $ cs "Hello World" == r3.body + -- Delete (forbidden for other users) + deleteAsset uid2 r1.jsonBody >>= \r -> r.status `shouldMatchInt` 403 + -- Delete (allowed for creator) + deleteAsset uid r1.jsonBody >>= \r -> r.status `shouldMatchInt` 200 + r4 <- downloadAsset' uid loc tok + r4.status `shouldMatchInt` 404 + let Just date' = C8.unpack <$> lookup (mk $ cs "Date") r4.headers + utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime + assertBool "bad date" (utc' >= utc) + testDownloadWithAcceptHeader :: HasCallStack => App () testDownloadWithAcceptHeader = do assetId <- randomId diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 9cfe3ed171..2485f19343 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -89,9 +89,9 @@ deleteAssetV3 user key = do deleteAsset :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response deleteAsset user key = do - k <- key %. "id" & asString + k <- key %. "key" & asString d <- key %. "domain" & asString - req <- baseRequest user Cargohold Versioned $ "/assets/" <> d <> "/" <> show k + req <- baseRequest user Cargohold Versioned $ "/assets/" <> d <> "/" <> k submit "DELETE" req header :: String -> String -> Request -> Request diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index c87c8899f3..eae8d977f8 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -52,10 +52,6 @@ testSimpleRoundtrip = do let bdy = (applicationText, "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 - putStrLn "sets = " - print sets - putStrLn "r1 = " - print r1 -- use v3 path instead of the one returned in the header (key, tok, expires) <- (,,) @@ -78,17 +74,11 @@ testSimpleRoundtrip = do Just r -> do r' <- asString r -- These retention policies never expire, so an expiration date isn't sent back - unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") $ do - putStrLn "utc =" - print utc - putStrLn "expires' = " - print expires' + unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") $ assertBool "invalid expiration" (Just utc < expires') _ -> pure () -- Lookup with token and download via redirect. r2 <- downloadAsset' uid r1.jsonBody tok - putStrLn "r2 = " - print r2 r2.status `shouldMatchInt` 302 assertBool "Response body should be empty" $ r2.body == mempty diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index f7ae9eb5bb..5e6f463c9f 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -210,7 +210,6 @@ executable cargohold-integration API API.Federation API.Util - API.V3 App Metrics Paths_cargohold diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index 47428f0ea3..fe56b0073f 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -23,16 +23,13 @@ import API.Util import Bilge hiding (body) import Bilge.Assert import CargoHold.API.Error -import CargoHold.Options (aws, s3DownloadEndpoint) import CargoHold.Types import qualified CargoHold.Types.V3 as V3 -import qualified Codec.MIME.Type as MIME import Control.Exception (throw) import Control.Lens hiding (sets, (.=)) import qualified Data.Aeson as Aeson import Data.ByteString.Builder import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Conversion import Data.Domain import Data.Id import Data.Qualified @@ -44,15 +41,12 @@ import Data.UUID.V4 import Federator.MockServer import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) -import qualified Network.HTTP.Client as HTTP import Network.HTTP.Media ((//)) import qualified Network.HTTP.Types as HTTP -import Network.Wai.Utilities (Error (label)) import qualified Network.Wai.Utilities.Error as Wai import Test.Tasty import Test.Tasty.HUnit import TestSetup -import Util.Options import Wire.API.Federation.API.Cargohold import Wire.API.Federation.Component @@ -61,18 +55,8 @@ tests s = testGroup "API Integration" [ testGroup - "simple" - [ test s "roundtrip" testSimpleRoundtrip, - test s "download with accept header" testDownloadWithAcceptHeader, - test s "tokens" testSimpleTokens, - test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, - test s "client-compatibility" testUploadCompatibility, - test s "download url override" testDownloadURLOverride - ], - testGroup "remote" - [ test s "remote download wrong domain" testRemoteDownloadWrongDomain, - test s "remote download no asset" testRemoteDownloadNoAsset, + [ test s "remote download no asset" testRemoteDownloadNoAsset, test s "federator failure on remote download" testRemoteDownloadFederationFailure, test s "remote download" (testRemoteDownload "asset content"), test s "large remote download" $ @@ -83,233 +67,9 @@ tests s = ] ] --------------------------------------------------------------------------------- --- Simple (single-step) uploads - -testSimpleRoundtrip :: TestM () -testSimpleRoundtrip = do - let def = V3.defAssetSettings - let rets = [minBound ..] - let sets = def : map (\r -> def & V3.setAssetRetention ?~ r) rets - mapM_ simpleRoundtrip sets - where - simpleRoundtrip sets = do - uid <- randomUser - uid2 <- liftIO $ Id <$> nextRandom - -- Initial upload - let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple (path "/assets/v3") uid sets bdy - lookup "Date" (responseHeaders r1) - let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime - -- Potentially check for the expires header - when (isJust $ V3.assetRetentionSeconds =<< (sets ^. V3.setAssetRetention)) $ do - liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) - -- Lookup with token and download via redirect. - r2 <- - downloadAsset uid loc (Just tok) lookup "Date" (responseHeaders r4) - let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime - liftIO $ assertBool "bad date" (utc' >= utc) - -testDownloadWithAcceptHeader :: TestM () -testDownloadWithAcceptHeader = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - domain <- viewFederationDomain - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key domain - downloadAssetWith (header "Accept" "image/jpeg") uid qkey () - !!! const 404 === statusCode - -testSimpleTokens :: TestM () -testSimpleTokens = do - uid <- randomUser - uid2 <- liftIO $ Id <$> nextRandom - -- Initial upload - let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) - let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple (path "/assets/v3") uid sets bdy - responseJsonMaybe r2 - liftIO $ assertBool "token unchanged" (tok /= tok') - -- Download by owner with new token. - r3 <- - downloadAsset uid loc (Just tok') > wait >> go - where - wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 - go = do - uid <- randomUser - let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) - let part2 = (MIME.Type (MIME.Text "plain") [], C8.replicate 100000 'c') - uploadSimple (path "/assets/v3") uid sets part2 - !!! const 201 === statusCode - -testDownloadURLOverride :: TestM () -testDownloadURLOverride = do - -- This is a .example domain, it shouldn't resolve. But it is also not - -- supposed to be used by cargohold to make connections. - let downloadEndpoint = "external-s3-url.example" - withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do - uid <- randomUser - - -- Upload, should work, shouldn't try to use the S3DownloadEndpoint - let bdy = (applicationText, "Hello World") - uploadRes <- - uploadSimple (path "/assets/v3") uid V3.defAssetSettings bdy - nextRandom - uid <- liftIO $ Id <$> nextRandom - - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "invalid.example.com") - downloadAsset uid qkey () !!! do - const 422 === statusCode - testRemoteDownloadNoAsset :: TestM () testRemoteDownloadNoAsset = do assetId <- liftIO $ Id <$> nextRandom diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs deleted file mode 100644 index 5560905f92..0000000000 --- a/services/cargohold/test/integration/API/V3.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module API.V3 (tests) where - -import API.Util -import Bilge hiding (body) -import Bilge.Assert -import Control.Lens hiding (sets) -import qualified Data.ByteString.Char8 as C8 -import Data.Id -import Data.Qualified -import Data.Time.Clock -import Data.Time.Format -import Data.UUID.V4 -import Imports hiding (head) -import Network.HTTP.Client (parseUrlThrow) -import Network.HTTP.Types.Status (status200) -import Test.Tasty -import Test.Tasty.HUnit -import TestSetup -import Wire.API.Asset - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "API Integration v3" - [ testGroup - "simple" - [test s "roundtrip using v3 API" testSimpleRoundtrip] - ] - --------------------------------------------------------------------------------- --- Simple (single-step) uploads - -testSimpleRoundtrip :: TestM () -testSimpleRoundtrip = do - let def = defAssetSettings - let rets = [minBound ..] - let sets = def : map (\r -> def & setAssetRetention ?~ r) rets - mapM_ simpleRoundtrip sets - where - simpleRoundtrip sets = do - uid <- randomUser - uid2 <- liftIO $ Id <$> nextRandom - -- Initial upload - let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple (path "/assets/v3") uid sets bdy - lookup "Date" (responseHeaders r1) - let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime - -- Potentially check for the expires header - when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do - liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) - -- Lookup with token and download via redirect. - r2 <- - downloadAsset uid key (Just tok) lookup "Date" (responseHeaders r4) - let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime - liftIO $ assertBool "bad date" (utc' >= utc) diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs index 4615fa52bf..a09883fdb8 100644 --- a/services/cargohold/test/integration/Main.hs +++ b/services/cargohold/test/integration/Main.hs @@ -22,7 +22,6 @@ where import qualified API import API.Federation (tests) -import qualified API.V3 import qualified App import Data.Proxy import Data.Tagged @@ -67,7 +66,6 @@ main = do testGroup "Cargohold" [ API.tests ts, - API.V3.tests ts, Metrics.tests ts, API.Federation.tests ts, App.tests ts From 3b505639f3a714d8f1dd63925a7445ab93173172 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 24 Nov 2023 12:20:16 +1000 Subject: [PATCH 13/22] WPB-5382: Two more tests moved over --- integration/test/Test/Cargohold/API.hs | 143 +++++++-------------- services/cargohold/cargohold.cabal | 1 - services/cargohold/default.nix | 1 - services/cargohold/test/integration/API.hs | 86 +------------ 4 files changed, 51 insertions(+), 180 deletions(-) diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 393c91b7f5..f0021d1c15 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -299,100 +299,57 @@ testRemoteDownloadWrongDomain = do res <- downloadAsset' uid qkey () res.status `shouldMatchInt` 422 --- testRemoteDownloadNoAsset :: HasCallStack => App () --- testRemoteDownloadNoAsset = do --- assetId <- randomId --- uid <- randomId --- let key = "3-2-" <> assetId --- qkey = object --- [ "domain" .= "faraway.example.com" --- , "id" .= key --- ] --- respond req --- | frRPC req == "get-asset" = --- pure ("application" // "json", Aeson.encode (GetAssetResponse False)) --- | otherwise = --- throw --- . MockErrorResponse HTTP.status404 --- . LText.decodeUtf8With Text.lenientDecode --- . Aeson.encode --- $ assetNotFound --- (_, reqs) <- withMockFederator respond $ do --- downloadAsset' uid qkey () !!! do --- const 404 === statusCode --- localDomain <- viewFederationDomain --- liftIO $ --- reqs --- @?= undefined --- -- [ FederatedRequest --- -- { frOriginDomain = localDomain, --- -- frTargetDomain = Domain "faraway.example.com", --- -- frComponent = Cargohold, --- -- frRPC = "get-asset", --- -- frBody = Aeson.encode (GetAsset uid key Nothing) --- -- } --- -- ] +testRemoteDownloadNoAsset :: HasCallStack => App () +testRemoteDownloadNoAsset = do + assetId <- randomId + uid <- randomUser OwnDomain def + otherDomain <- make OtherDomain & asString + let key = "3-2-" <> assetId + qkey = + object + [ "domain" .= otherDomain, + "key" .= key + ] + res <- downloadAsset' uid qkey () + res.status `shouldMatchInt` 404 --- testRemoteDownloadFederationFailure :: HasCallStack => App () --- testRemoteDownloadFederationFailure = do --- assetId <- randomId --- uid <- randomId --- let key = "3-2-" <> assetId --- qkey = object --- [ "domain" .= "faraway.example.com" --- , "id" .= key --- ] --- respond req --- | frRPC req == "get-asset" = --- pure ("application" // "json", Aeson.encode (GetAssetResponse True)) --- | otherwise = throw (MockErrorResponse HTTP.status500 "mock error") --- -- (resp, _) <- --- -- withMockFederator respond $ do --- -- responseJsonError --- res <- downloadAsset' uid qkey () --- res.status `shouldMatchInt` 500 --- resJ <- maybe (assertFailure "No JSON body") pure res.jsonBody --- asString (resJ %. "label") `shouldMatch` "mock-error" --- asString (resJ %. "message") `shouldMatch` "mock error" +testRemoteDownloadFederationFailure :: HasCallStack => App () +testRemoteDownloadFederationFailure = do + assetId <- randomId + uid <- randomUser OwnDomain def + startDynamicBackends [def] $ \[remoteDomain] -> do + let key = "3-2-" <> assetId + qkey = + object + [ "domain" .= remoteDomain, + "key" .= key + ] + res <- downloadAsset' uid qkey () + res.status `shouldMatchInt` 500 + resJ <- maybe (assertFailure "No JSON body") pure res.jsonBody + asString (resJ %. "label") `shouldMatch` "mock-error" + asString (resJ %. "message") `shouldMatch` "mock error" --- testRemoteDownloadShort :: HasCallStack => App () --- testRemoteDownloadShort = remoteDownload $ cs "asset content" +testRemoteDownloadShort :: HasCallStack => App () +testRemoteDownloadShort = remoteDownload "asset content" --- testRemoteDownloadLong :: HasCallStack => App () --- testRemoteDownloadLong = remoteDownload $ toLazyByteString $ mconcat $ replicate 20000 $ builder "hello world\n" +testRemoteDownloadLong :: HasCallStack => App () +testRemoteDownloadLong = remoteDownload $ concat $ replicate 20000 $ "hello world\n" --- remoteDownload :: HasCallStack => LBS.ByteString -> App () --- remoteDownload assetContent = do --- assetId <- randomId --- uid <- randomId --- --- let key = "3-2-" <> assetId --- qkey = object ["domain" .= "faraway.example.com", "id" .= key] --- respond req --- | frRPC req == "get-asset" = --- pure ("application" // "json", Aeson.encode (GetAssetResponse True)) --- | otherwise = pure ("application" // "octet-stream", assetContent) --- (_, reqs) <- withMockFederator respond $ do --- res <- downloadAsset' uid qkey () --- res.status `shouldMatchInt` 200 --- res.responseBody `shouldMatch` assetContent --- --- let ga = object [ "user" .= uid, "key" .= key ] --- liftIO $ --- reqs --- @?= undefined --- -- [ FederatedRequest --- -- { frOriginDomain = localDomain, --- -- frTargetDomain = Domain "faraway.example.com", --- -- frComponent = Cargohold, --- -- frRPC = "get-asset", --- -- frBody = ga --- -- }, --- -- FederatedRequest --- -- { frOriginDomain = localDomain, --- -- frTargetDomain = Domain "faraway.example.com", --- -- frComponent = Cargohold, --- -- frRPC = "stream-asset", --- -- frBody = ga --- -- } --- -- ] +remoteDownload :: (HasCallStack, ConvertibleStrings a String) => a -> App () +remoteDownload content = do + uid1 <- randomUser OwnDomain def + uid2 <- randomUser OtherDomain def + r1 <- uploadSimple uid1 settings (applicationOctetStream, cs content) + r1.status `shouldMatchInt` 201 + let locHeader = mk $ cs "Location" + loc = decodeHeaderOrFail @String locHeader r1 + -- Lookup and download via redirect. + r2 <- downloadAsset' uid2 loc () + print r2 + r2.status `shouldMatchInt` 200 + assertBool "Content types should match" $ getContentType r2 == Just applicationOctetStream' + -- decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id") + cs @_ @String r2.body `shouldMatch` Just (cs content :: String) + where + settings = object ["public" .= True] diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 5e6f463c9f..595231dbf7 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -294,7 +294,6 @@ executable cargohold-integration , tasty-ant-xml , tasty-hunit >=0.9 , text >=1.1 - , time >=1.5 , types-common >=0.7 , uuid >=1.3 , wai-utilities >=0.12 diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 5dbc7d1a5b..84162798a1 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -163,7 +163,6 @@ mkDerivation { tasty-ant-xml tasty-hunit text - time types-common uuid wai-utilities diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index fe56b0073f..a807d33730 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -22,25 +22,15 @@ module API (tests) where import API.Util import Bilge hiding (body) import Bilge.Assert -import CargoHold.API.Error import CargoHold.Types -import qualified CargoHold.Types.V3 as V3 import Control.Exception (throw) -import Control.Lens hiding (sets, (.=)) import qualified Data.Aeson as Aeson -import Data.ByteString.Builder -import qualified Data.ByteString.Char8 as C8 import Data.Domain import Data.Id import Data.Qualified -import qualified Data.Text.Encoding.Error as Text -import qualified Data.Text.Lazy.Encoding as LText -import Data.Time.Clock -import Data.Time.Format import Data.UUID.V4 import Federator.MockServer import Imports hiding (head) -import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Media ((//)) import qualified Network.HTTP.Types as HTTP import qualified Network.Wai.Utilities.Error as Wai @@ -48,7 +38,6 @@ import Test.Tasty import Test.Tasty.HUnit import TestSetup import Wire.API.Federation.API.Cargohold -import Wire.API.Federation.Component tests :: IO TestSetup -> TestTree tests s = @@ -56,50 +45,13 @@ tests s = "API Integration" [ testGroup "remote" - [ test s "remote download no asset" testRemoteDownloadNoAsset, - test s "federator failure on remote download" testRemoteDownloadFederationFailure, - test s "remote download" (testRemoteDownload "asset content"), - test s "large remote download" $ - testRemoteDownload - ( toLazyByteString - (mconcat (replicate 20000 (byteString "hello world\n"))) - ) + [ test s "federator failure on remote download" testRemoteDownloadFederationFailure ] ] -------------------------------------------------------------------------------- -- Federation behaviour -testRemoteDownloadNoAsset :: TestM () -testRemoteDownloadNoAsset = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "faraway.example.com") - respond req - | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse False)) - | otherwise = - throw - . MockErrorResponse HTTP.status404 - . LText.decodeUtf8With Text.lenientDecode - . Aeson.encode - $ assetNotFound - (_, reqs) <- withMockFederator respond $ do - downloadAsset uid qkey () !!! do - const 404 === statusCode - localDomain <- viewFederationDomain - liftIO $ - reqs - @?= [ FederatedRequest - { frOriginDomain = localDomain, - frTargetDomain = Domain "faraway.example.com", - frComponent = Cargohold, - frRPC = "get-asset", - frBody = Aeson.encode (GetAsset uid key Nothing) - } - ] - testRemoteDownloadFederationFailure :: TestM () testRemoteDownloadFederationFailure = do assetId <- liftIO $ Id <$> nextRandom @@ -118,39 +70,3 @@ testRemoteDownloadFederationFailure = do liftIO $ do Wai.label resp @?= "mock-error" Wai.message resp @?= "mock error" - -testRemoteDownload :: LByteString -> TestM () -testRemoteDownload assetContent = do - assetId <- liftIO $ Id <$> nextRandom - uid <- liftIO $ Id <$> nextRandom - - let key = AssetKeyV3 assetId AssetPersistent - qkey = Qualified key (Domain "faraway.example.com") - respond req - | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse True)) - | otherwise = pure ("application" // "octet-stream", assetContent) - (_, reqs) <- withMockFederator respond $ do - downloadAsset uid qkey () !!! do - const 200 === statusCode - const (Just assetContent) === responseBody - - localDomain <- viewFederationDomain - let ga = Aeson.encode (GetAsset uid key Nothing) - liftIO $ - reqs - @?= [ FederatedRequest - { frOriginDomain = localDomain, - frTargetDomain = Domain "faraway.example.com", - frComponent = Cargohold, - frRPC = "get-asset", - frBody = ga - }, - FederatedRequest - { frOriginDomain = localDomain, - frTargetDomain = Domain "faraway.example.com", - frComponent = Cargohold, - frRPC = "stream-asset", - frBody = ga - } - ] From 7a08302d0207970e0f14cbd0857876afc0f15743 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 24 Nov 2023 15:40:35 +1000 Subject: [PATCH 14/22] WPB-5382: Migrating more tests over --- integration/integration.cabal | 1 + integration/test/SetupHelpers.hs | 7 +- integration/test/Test/Cargohold/API.hs | 34 +-- .../test/Test/Cargohold/API/Federation.hs | 201 ++++++++++++++++++ integration/test/Test/Cargohold/API/Util.hs | 3 + .../test/integration/API/Federation.hs | 84 -------- 6 files changed, 228 insertions(+), 102 deletions(-) create mode 100644 integration/test/Test/Cargohold/API/Federation.hs diff --git a/integration/integration.cabal b/integration/integration.cabal index 1ec7aab6ac..984e314dfa 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -107,6 +107,7 @@ library Test.Brig Test.Cargohold Test.Cargohold.API + Test.Cargohold.API.Federation Test.Cargohold.API.Util Test.Cargohold.API.V3 Test.Cargohold.App diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 7ae16b04bb..486b614d83 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -168,7 +168,12 @@ createMLSOne2OnePartner domain other convDomain = loop -- Copied from `src/CargoHold/API/V3.hs` and inlined to avoid pulling in `types-common` randomToken :: HasCallStack => App String -randomToken = liftIO (unpack . B64Url.encode <$> getRandomBytes 16) +randomToken = map mkUrlSafe . unpack . B64Url.encode <$> liftIO (getRandomBytes 16) + where + mkUrlSafe :: Char -> Char + mkUrlSafe '/' = '_' + mkUrlSafe '+' = '-' + mkUrlSafe c = c randomId :: HasCallStack => App String randomId = liftIO (show <$> nextRandom) diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index f0021d1c15..e88001c973 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -313,22 +313,23 @@ testRemoteDownloadNoAsset = do res <- downloadAsset' uid qkey () res.status `shouldMatchInt` 404 -testRemoteDownloadFederationFailure :: HasCallStack => App () -testRemoteDownloadFederationFailure = do - assetId <- randomId - uid <- randomUser OwnDomain def - startDynamicBackends [def] $ \[remoteDomain] -> do - let key = "3-2-" <> assetId - qkey = - object - [ "domain" .= remoteDomain, - "key" .= key - ] - res <- downloadAsset' uid qkey () - res.status `shouldMatchInt` 500 - resJ <- maybe (assertFailure "No JSON body") pure res.jsonBody - asString (resJ %. "label") `shouldMatch` "mock-error" - asString (resJ %. "message") `shouldMatch` "mock error" +-- Deliberately causing a 500 error is tricky, and I can't see a nice way of doing it +-- testRemoteDownloadFederationFailure :: HasCallStack => App () +-- testRemoteDownloadFederationFailure = do +-- assetId <- randomId +-- uid <- randomUser OwnDomain def +-- startDynamicBackends [def] $ \[remoteDomain] -> do +-- let key = "3-2-" <> assetId +-- qkey = +-- object +-- [ "domain" .= remoteDomain, +-- "key" .= key +-- ] +-- res <- downloadAsset' uid qkey () +-- res.status `shouldMatchInt` 500 +-- resJ <- maybe (assertFailure "No JSON body") pure res.jsonBody +-- asString (resJ %. "label") `shouldMatch` "mock-error" +-- asString (resJ %. "message") `shouldMatch` "mock error" testRemoteDownloadShort :: HasCallStack => App () testRemoteDownloadShort = remoteDownload "asset content" @@ -346,7 +347,6 @@ remoteDownload content = do loc = decodeHeaderOrFail @String locHeader r1 -- Lookup and download via redirect. r2 <- downloadAsset' uid2 loc () - print r2 r2.status `shouldMatchInt` 200 assertBool "Content types should match" $ getContentType r2 == Just applicationOctetStream' -- decodeHeaderOrFail @String (mk $ cs "x-amz-meta-user") r3 `shouldMatch` (uid %. "id") diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs new file mode 100644 index 0000000000..1fab5d1a6b --- /dev/null +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -0,0 +1,201 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . + +module Test.Cargohold.API.Federation where + +import API.Cargohold +import Control.Lens hiding ((.=)) +import SetupHelpers +import Test.Cargohold.API.Util +import Testlib.Prelude + +testGetAssetAvailablePublic :: HasCallStack => App () +testGetAssetAvailablePublic = getAssetAvailable True + +testGetAssetAvailablePrivate :: HasCallStack => App () +testGetAssetAvailablePrivate = getAssetAvailable False + +getAssetAvailable :: HasCallStack => Bool -> App () +getAssetAvailable isPublicAsset = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + settings = object ["public" .= isPublicAsset, "retention" .= "volatile"] + uid1 <- randomUser OwnDomain def + uid2 <- randomUser OtherDomain def + r1 <- uploadSimple uid1 settings bdy + r1.status `shouldMatchInt` 201 + ast <- maybe (error "No JSON in the response") pure r1.jsonBody + + -- Call get-asset federation API + -- Public assets don't have tokens, so don't explode if we can't get one. + tok <- + if isPublicAsset + then pure $ Right () + else Left <$> (ast %. "token" & asString) + res <- downloadAsset' uid2 r1.jsonBody tok + res.status `shouldMatchInt` 200 + +testGetAssetNotAvailable :: HasCallStack => App () +testGetAssetNotAvailable = do + uid <- randomUser OwnDomain def + userId <- uid %. "id" & asString + token <- randomToken + assetId <- randomId + otherDomain <- make OtherDomain & asString + let key = "3-2-" <> assetId + -- Use a foreign domain so that it will go via federator + ga = object ["user" .= userId, "token" .= token, "key" .= key, "domain" .= otherDomain] + r <- downloadAsset' uid ga ga + -- check that asset is not available + r.status `shouldMatchInt` 404 + r.jsonBody %. "message" `shouldMatch` "Asset not found" + +testGetAssetWrongToken :: HasCallStack => App () +testGetAssetWrongToken = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + -- Make it a public token so that other users can potentially + -- grab it across federation instances + settings = object ["public" .= True, "retention" .= "volatile"] + uid1 <- randomUser OwnDomain def + uid2 <- randomUser OtherDomain def + userId2 <- uid2 %. "id" & asString + domain <- make OwnDomain & asString + r1 <- uploadSimple uid1 settings bdy + r1.status `shouldMatchInt` 201 + key <- r1.jsonBody %. "key" & asString + + -- Call get-asset federation API with wrong (random) token + -- Use uid2 so that this will go via federation + tok <- randomToken + let ga = + object + [ "user" .= userId2, + "token" .= tok, + "key" .= key, + "domain" .= domain + ] + r2 <- downloadAsset' uid2 ga ga + r2.status `shouldMatchInt` 404 + r2.jsonBody %. "message" `shouldMatch` "Asset not found" + +-- testLargeAsset :: TestM () +-- testLargeAsset = do +-- -- Initial upload +-- let settings = +-- defAssetSettings +-- & set setAssetRetention (Just AssetVolatile) +-- uid <- randomUser +-- -- generate random bytes +-- let size = 1024 * 1024 +-- bs <- liftIO $ getRandomBytes size +-- +-- ast :: Asset <- +-- responseJsonError +-- =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) +-- runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) +-- liftIO . runResourceT $ connect source sinkList +-- liftIO $ do +-- let minNumChunks = 8 +-- assertBool +-- ("Expected at least " <> show minNumChunks <> " chunks, got " <> show (length chunks)) +-- (length chunks > minNumChunks) +-- mconcat chunks @?= bs +-- +-- testStreamAsset :: TestM () +-- testStreamAsset = do +-- -- Initial upload +-- let bdy = (applicationOctetStream, "Hello World") +-- settings = +-- defAssetSettings +-- & set setAssetRetention (Just AssetVolatile) +-- uid <- randomUser +-- ast :: Asset <- +-- responseJsonError +-- =<< uploadSimple (path "/assets/v3") uid settings bdy +-- runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) +-- liftIO . runResourceT $ connect source sinkLazy +-- liftIO $ respBody @?= "Hello World" +-- +-- testStreamAssetNotAvailable :: TestM () +-- testStreamAssetNotAvailable = do +-- uid <- liftIO $ Id <$> nextRandom +-- token <- randToken +-- +-- assetId <- liftIO $ Id <$> nextRandom +-- let key = AssetKeyV3 assetId AssetPersistent +-- let ga = +-- GetAsset +-- { user = uid, +-- token = Just token, +-- key = key +-- } +-- err <- withFederationError $ do +-- runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) +-- liftIO $ do +-- Wai.code err @?= HTTP.notFound404 +-- Wai.label err @?= "not-found" +-- +-- testStreamAssetWrongToken :: TestM () +-- testStreamAssetWrongToken = do +-- -- Initial upload +-- let bdy = (applicationOctetStream, "Hello World") +-- settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) +-- uid <- randomUser +-- ast :: Asset <- +-- responseJsonError +-- =<< uploadSimple (path "/assets/v3") uid settings bdy +-- IsAssetToken (Either a b) where + tokenParam = either tokenParam tokenParam + instance IsAssetToken Value where tokenParam v = case v of diff --git a/services/cargohold/test/integration/API/Federation.hs b/services/cargohold/test/integration/API/Federation.hs index d7bf5c87cf..2582d0477c 100644 --- a/services/cargohold/test/integration/API/Federation.hs +++ b/services/cargohold/test/integration/API/Federation.hs @@ -43,13 +43,6 @@ tests s = testGroup "API Federation" [ testGroup - "get-asset" - [ test s "private asset is available" (testGetAssetAvailable False), - test s "public asset is available" (testGetAssetAvailable True), - test s "not available" testGetAssetNotAvailable, - test s "wrong token" testGetAssetWrongToken - ], - testGroup "stream-asset" [ test s "streaming large asset" testLargeAsset, test s "stream an asset" testStreamAsset, @@ -58,83 +51,6 @@ tests s = ] ] -testGetAssetAvailable :: Bool -> TestM () -testGetAssetAvailable isPublicAsset = do - -- Initial upload - let bdy = (applicationOctetStream, "Hello World") - settings = - defAssetSettings - & set setAssetRetention (Just AssetVolatile) - & set setAssetPublic isPublicAsset - uid <- randomUser - ast :: Asset <- - responseJsonError - =<< uploadSimple (path "/assets/v3") uid settings bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) - - -- check that asset is available - liftIO $ ok @?= True - -testGetAssetNotAvailable :: TestM () -testGetAssetNotAvailable = do - uid <- liftIO $ Id <$> nextRandom - token <- randToken - - assetId <- liftIO $ Id <$> nextRandom - let key = AssetKeyV3 assetId AssetPersistent - let ga = - GetAsset - { user = uid, - token = Just token, - key = key - } - ok <- - withFederationClient $ - available <$> runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) - - -- check that asset is not available - liftIO $ ok @?= False - -testGetAssetWrongToken :: TestM () -testGetAssetWrongToken = do - -- Initial upload - let bdy = (applicationOctetStream, "Hello World") - settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) - uid <- randomUser - ast :: Asset <- - responseJsonError - =<< uploadSimple (path "/assets/v3") uid settings bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"get-asset" ga) - - -- check that asset is not available - liftIO $ ok @?= False - testLargeAsset :: TestM () testLargeAsset = do -- Initial upload From 223362f3ea4829e0f6af6b49cb472ece67087a0a Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 24 Nov 2023 16:39:17 +1000 Subject: [PATCH 15/22] WPB-5382: testLargeAsset moved over --- integration/test/Test/Cargohold/API.hs | 11 +-- .../test/Test/Cargohold/API/Federation.hs | 67 +++++++++---------- integration/test/Test/Cargohold/API/Util.hs | 55 +++++++++++++-- integration/test/Test/Cargohold/API/V3.hs | 2 +- services/cargohold/cargohold.cabal | 1 - services/cargohold/default.nix | 1 - .../test/integration/API/Federation.hs | 39 +---------- 7 files changed, 89 insertions(+), 87 deletions(-) diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index e88001c973..2f38e3041d 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -26,6 +26,7 @@ import Data.Aeson.KeyMap qualified as KM import Data.Aeson.Types (Pair) import Data.ByteString.Char8 qualified as C8 import Data.ByteString.Lazy qualified as LBS hiding (replicate) +import Data.ByteString.Lazy.Char8 qualified as L8 import Data.CaseInsensitive (mk) import Data.String.Conversions import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError, rfc822DateFormat) @@ -54,7 +55,7 @@ testSimpleRoundtrip = do userId1 <- uid %. "id" & asString uid2 <- randomUser OwnDomain def -- Initial upload - let bdy = (applicationText, "Hello World") + let bdy = (applicationText, cs "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 loc <- maybe (error "Could not find the Location header") (pure . cs @_ @String) $ lookup (mk $ cs "Location") r1.headers @@ -122,7 +123,7 @@ testSimpleTokens = do uid2 <- randomUser OwnDomain def -- Initial upload let sets = object ["public" .= False, "retention" .= "volatile"] - bdy = (applicationText, "Hello World") + bdy = (applicationText, cs "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 loc <- @@ -205,7 +206,7 @@ testSimpleS3ClosedConnectionReuse = go >> wait >> go go = do uid <- randomUser OwnDomain def let sets = object $ defAssetSettings' <> ["retention" .= "volatile"] - let part2 = (MIME.Text $ cs "plain", replicate 100000 'c') + let part2 = (MIME.Text $ cs "plain", cs $ replicate 100000 'c') uploadSimple uid sets part2 >>= \r -> r.status `shouldMatchInt` 201 testDownloadURLOverride :: HasCallStack => App () @@ -220,7 +221,7 @@ testDownloadURLOverride = do -- withSettingsOverrides (aws . s3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do uid <- randomUser d def -- Upload, should work, shouldn't try to use the S3DownloadEndpoint - let bdy = (applicationText, "Hello World") + let bdy = (applicationText, cs "Hello World") uploadRes <- uploadSimple uid defAssetSettings bdy uploadRes.status `shouldMatchInt` 201 let loc = decodeHeaderOrFail (mk $ cs "Location") uploadRes :: String @@ -337,7 +338,7 @@ testRemoteDownloadShort = remoteDownload "asset content" testRemoteDownloadLong :: HasCallStack => App () testRemoteDownloadLong = remoteDownload $ concat $ replicate 20000 $ "hello world\n" -remoteDownload :: (HasCallStack, ConvertibleStrings a String) => a -> App () +remoteDownload :: (HasCallStack, ConvertibleStrings a L8.ByteString, ConvertibleStrings a String) => a -> App () remoteDownload content = do uid1 <- randomUser OwnDomain def uid2 <- randomUser OtherDomain def diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs index 1fab5d1a6b..14b0bbb6eb 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -19,6 +19,9 @@ module Test.Cargohold.API.Federation where import API.Cargohold import Control.Lens hiding ((.=)) +import Crypto.Random (getRandomBytes) +import Data.ByteString.Builder +import Data.String.Conversions import SetupHelpers import Test.Cargohold.API.Util import Testlib.Prelude @@ -32,7 +35,7 @@ testGetAssetAvailablePrivate = getAssetAvailable False getAssetAvailable :: HasCallStack => Bool -> App () getAssetAvailable isPublicAsset = do -- Initial upload - let bdy = (applicationOctetStream, "Hello World") + let bdy = (applicationOctetStream, cs "Hello World") settings = object ["public" .= isPublicAsset, "retention" .= "volatile"] uid1 <- randomUser OwnDomain def uid2 <- randomUser OtherDomain def @@ -67,7 +70,7 @@ testGetAssetNotAvailable = do testGetAssetWrongToken :: HasCallStack => App () testGetAssetWrongToken = do -- Initial upload - let bdy = (applicationOctetStream, "Hello World") + let bdy = (applicationOctetStream, cs "Hello World") -- Make it a public token so that other users can potentially -- grab it across federation instances settings = object ["public" .= True, "retention" .= "volatile"] @@ -93,41 +96,31 @@ testGetAssetWrongToken = do r2.status `shouldMatchInt` 404 r2.jsonBody %. "message" `shouldMatch` "Asset not found" --- testLargeAsset :: TestM () --- testLargeAsset = do --- -- Initial upload --- let settings = --- defAssetSettings --- & set setAssetRetention (Just AssetVolatile) --- uid <- randomUser --- -- generate random bytes --- let size = 1024 * 1024 --- bs <- liftIO $ getRandomBytes size --- --- ast :: Asset <- --- responseJsonError --- =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) --- runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) --- liftIO . runResourceT $ connect source sinkList --- liftIO $ do --- let minNumChunks = 8 --- assertBool --- ("Expected at least " <> show minNumChunks <> " chunks, got " <> show (length chunks)) --- (length chunks > minNumChunks) --- mconcat chunks @?= bs --- +testLargeAsset :: HasCallStack => App () +testLargeAsset = do + -- Initial upload + let settings = object ["public" .= True, "retention" .= "volatile"] + uid <- randomUser OwnDomain def + domain <- uid %. "qualified_id" %. "domain" & asString + uid2 <- randomUser OtherDomain def + userId2 <- uid2 %. "id" & asString + -- generate random bytes + let size = 1024 * 1024 + bs :: ByteString <- liftIO $ getRandomBytes size + let body = toLazyByteString $ buildMultipartBody' settings applicationOctetStream' (cs bs) + r1 <- uploadRaw uid body + r1.status `shouldMatchInt` 201 + key <- r1.jsonBody %. "key" & asString + -- Call get-asset federation API + let ga = + object + [ "user" .= userId2, + "key" .= key, + "domain" .= domain + ] + r2 <- downloadAsset' uid2 ga () + r2.status `shouldMatchInt` 200 + -- testStreamAsset :: TestM () -- testStreamAsset = do -- -- Initial upload diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index d32d067e8e..484d97df11 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -29,21 +29,21 @@ import Data.ByteString.Lazy.Char8 qualified as Lazy8 import Data.CaseInsensitive import Data.String.Conversions import Data.Text qualified as T -import Data.Text.Encoding (decodeLatin1, decodeUtf8, encodeUtf8Builder) +import Data.Text.Encoding (decodeLatin1, decodeUtf8, encodeUtf8, encodeUtf8Builder) import GHC.Stack import Network.HTTP.Client (Request (requestHeaders)) import Network.HTTP.Client qualified as HTTP -import Network.HTTP.Types.Header +import Network.HTTP.Types.Header (HeaderName) import Testlib.Prelude uploadSimple :: (HasCallStack, MakesValue user, MakesValue settings) => user -> settings -> - (MIME.MIMEType, String) -> + (MIME.MIMEType, Lazy8.ByteString) -> App Response uploadSimple usr sts (ct, bs) = do - body <- buildMultipartBody sts (Lazy8.pack bs) ct + body <- buildMultipartBody sts bs ct uploadRaw usr body decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response -> a @@ -227,3 +227,50 @@ buildMultipartBody header' body bodyMimeType = do multipartBoundary :: String multipartBoundary = "frontier" + +buildMultipartBody' :: Value -> MIME.Type -> LBS.ByteString -> Builder +buildMultipartBody' sets typ bs = + beginMultipartBody sets typ (fromIntegral $ LBS.length bs) <> lazyByteString bs <> endMultipartBody' + +-- | Begin building a @multipart/mixed@ request body for a non-resumable upload. +-- The returned 'Builder' can be immediately followed by the actual asset bytes. +beginMultipartBody :: Value -> MIME.Type -> Word -> Builder +beginMultipartBody sets t l = + byteString + ( cs + "--frontier\r\n\ + \Content-Type: application/json\r\n\ + \Content-Length: " + ) + <> int64Dec (LBS.length settingsJson) + <> byteString + ( cs + "\r\n\ + \\r\n" + ) + <> lazyByteString settingsJson + <> byteString + ( cs + "\r\n\ + \--frontier\r\n\ + \Content-Type: " + ) + <> byteString (encodeUtf8 (MIME.showType t)) + <> byteString + ( cs + "\r\n\ + \Content-Length: " + ) + <> wordDec l + <> byteString + ( cs + "\r\n\ + \\r\n" + ) + where + settingsJson = Aeson.encode sets + +-- | The trailer of a non-resumable @multipart/mixed@ request body initiated +-- via 'beginMultipartBody'. +endMultipartBody' :: Builder +endMultipartBody' = byteString $ cs "\r\n--frontier--\r\n" diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index eae8d977f8..35b054034a 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -49,7 +49,7 @@ testSimpleRoundtrip = do uid <- randomUser OwnDomain def uid2 <- randomUser OwnDomain def -- Initial upload - let bdy = (applicationText, "Hello World") + let bdy = (applicationText, cs "Hello World") r1 <- uploadSimple uid sets bdy r1.status `shouldMatchInt` 201 -- use v3 path instead of the one returned in the header diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 595231dbf7..6dd63746b7 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -273,7 +273,6 @@ executable cargohold-integration , cargohold-types , conduit , containers - , crypton , federator , http-api-data , http-client >=0.7 diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 84162798a1..5157280005 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -141,7 +141,6 @@ mkDerivation { cargohold-types conduit containers - crypton federator HsOpenSSL http-api-data diff --git a/services/cargohold/test/integration/API/Federation.hs b/services/cargohold/test/integration/API/Federation.hs index 2582d0477c..97db2106b3 100644 --- a/services/cargohold/test/integration/API/Federation.hs +++ b/services/cargohold/test/integration/API/Federation.hs @@ -23,7 +23,6 @@ import Bilge.Assert import CargoHold.API.V3 (randToken) import Conduit import Control.Lens -import Crypto.Random import Data.Id import Data.Qualified import Data.UUID.V4 @@ -44,48 +43,12 @@ tests s = "API Federation" [ testGroup "stream-asset" - [ test s "streaming large asset" testLargeAsset, - test s "stream an asset" testStreamAsset, + [ test s "stream an asset" testStreamAsset, test s "stream asset not available" testStreamAssetNotAvailable, test s "stream asset wrong token" testStreamAssetWrongToken ] ] -testLargeAsset :: TestM () -testLargeAsset = do - -- Initial upload - let settings = - defAssetSettings - & set setAssetRetention (Just AssetVolatile) - uid <- randomUser - -- generate random bytes - let size = 1024 * 1024 - bs <- liftIO $ getRandomBytes size - - ast :: Asset <- - responseJsonError - =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) - runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) - liftIO . runResourceT $ connect source sinkList - liftIO $ do - let minNumChunks = 8 - assertBool - ("Expected at least " <> show minNumChunks <> " chunks, got " <> show (length chunks)) - (length chunks > minNumChunks) - mconcat chunks @?= bs - testStreamAsset :: TestM () testStreamAsset = do -- Initial upload From a22e58754022c8a73ec61795ab2f48a2cdf47749 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 24 Nov 2023 16:54:38 +1000 Subject: [PATCH 16/22] WPB-5382: Moving over testStreamAsset and updating prior tests. --- .../test/Test/Cargohold/API/Federation.hs | 62 +++++++++---------- .../test/integration/API/Federation.hs | 31 +--------- 2 files changed, 30 insertions(+), 63 deletions(-) diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs index 14b0bbb6eb..ec5d3aedcf 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -18,6 +18,7 @@ module Test.Cargohold.API.Federation where import API.Cargohold +import Codec.MIME.Type qualified as MIME import Control.Lens hiding ((.=)) import Crypto.Random (getRandomBytes) import Data.ByteString.Builder @@ -71,9 +72,7 @@ testGetAssetWrongToken :: HasCallStack => App () testGetAssetWrongToken = do -- Initial upload let bdy = (applicationOctetStream, cs "Hello World") - -- Make it a public token so that other users can potentially - -- grab it across federation instances - settings = object ["public" .= True, "retention" .= "volatile"] + settings = object ["public" .= False, "retention" .= "volatile"] uid1 <- randomUser OwnDomain def uid2 <- randomUser OtherDomain def userId2 <- uid2 %. "id" & asString @@ -99,7 +98,7 @@ testGetAssetWrongToken = do testLargeAsset :: HasCallStack => App () testLargeAsset = do -- Initial upload - let settings = object ["public" .= True, "retention" .= "volatile"] + let settings = object ["public" .= False, "retention" .= "volatile"] uid <- randomUser OwnDomain def domain <- uid %. "qualified_id" %. "domain" & asString uid2 <- randomUser OtherDomain def @@ -110,44 +109,41 @@ testLargeAsset = do let body = toLazyByteString $ buildMultipartBody' settings applicationOctetStream' (cs bs) r1 <- uploadRaw uid body r1.status `shouldMatchInt` 201 + tok <- r1.jsonBody %. "token" & asString key <- r1.jsonBody %. "key" & asString -- Call get-asset federation API let ga = object [ "user" .= userId2, "key" .= key, - "domain" .= domain + "domain" .= domain, + "token" .= tok ] - r2 <- downloadAsset' uid2 ga () + r2 <- downloadAsset' uid2 ga ga r2.status `shouldMatchInt` 200 --- testStreamAsset :: TestM () --- testStreamAsset = do --- -- Initial upload --- let bdy = (applicationOctetStream, "Hello World") --- settings = --- defAssetSettings --- & set setAssetRetention (Just AssetVolatile) --- uid <- randomUser --- ast :: Asset <- --- responseJsonError --- =<< uploadSimple (path "/assets/v3") uid settings bdy --- runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) --- liftIO . runResourceT $ connect source sinkLazy --- liftIO $ respBody @?= "Hello World" --- +testStreamAsset :: HasCallStack => App () +testStreamAsset = do + -- Initial upload + uid <- randomUser OwnDomain def + uid2 <- randomUser OtherDomain def + userId <- uid %. "id" & asString + domain <- uid %. "qualified_id" %. "domain" & asString + r1 <- uploadSimple uid settings bdy + r1.status `shouldMatchInt` 201 + + -- Call get-asset federation API + tok <- r1.jsonBody %. "token" & asString + key <- r1.jsonBody %. "key" & asString + let ga = object ["user" .= userId, "token" .= tok, "key" .= key, "domain" .= domain] + r2 <- downloadAsset' uid2 ga ga + r2.status `shouldMatchInt` 200 + cs @_ @String r2.body `shouldMatch` (snd bdy :: String) + where + bdy :: ConvertibleStrings String a => (MIME.MIMEType, a) + bdy = (applicationOctetStream, cs "Hello World") + settings = object ["public" .= False, "retention" .= "volatile"] + -- testStreamAssetNotAvailable :: TestM () -- testStreamAssetNotAvailable = do -- uid <- liftIO $ Id <$> nextRandom diff --git a/services/cargohold/test/integration/API/Federation.hs b/services/cargohold/test/integration/API/Federation.hs index 97db2106b3..b9e8c325b9 100644 --- a/services/cargohold/test/integration/API/Federation.hs +++ b/services/cargohold/test/integration/API/Federation.hs @@ -35,7 +35,6 @@ import TestSetup import Wire.API.Asset import Wire.API.Federation.API import Wire.API.Federation.API.Cargohold -import Wire.API.Routes.AssetBody tests :: IO TestSetup -> TestTree tests s = @@ -43,39 +42,11 @@ tests s = "API Federation" [ testGroup "stream-asset" - [ test s "stream an asset" testStreamAsset, - test s "stream asset not available" testStreamAssetNotAvailable, + [ test s "stream asset not available" testStreamAssetNotAvailable, test s "stream asset wrong token" testStreamAssetWrongToken ] ] -testStreamAsset :: TestM () -testStreamAsset = do - -- Initial upload - let bdy = (applicationOctetStream, "Hello World") - settings = - defAssetSettings - & set setAssetRetention (Just AssetVolatile) - uid <- randomUser - ast :: Asset <- - responseJsonError - =<< uploadSimple (path "/assets/v3") uid settings bdy - runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) - liftIO . runResourceT $ connect source sinkLazy - liftIO $ respBody @?= "Hello World" - testStreamAssetNotAvailable :: TestM () testStreamAssetNotAvailable = do uid <- liftIO $ Id <$> nextRandom From 000f880180a727ea459aacfd657e2ae390afbd10 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 24 Nov 2023 17:12:54 +1000 Subject: [PATCH 17/22] WPB-5382: Moving over the last of the federation tests. Touching up previous tests so that they use the domain from the created users, rather than remaking the domain string. --- .../test/Test/Cargohold/API/Federation.hs | 81 +++++++--------- services/cargohold/cargohold.cabal | 2 - services/cargohold/default.nix | 1 - .../test/integration/API/Federation.hs | 93 ------------------- services/cargohold/test/integration/Main.hs | 2 - 5 files changed, 36 insertions(+), 143 deletions(-) delete mode 100644 services/cargohold/test/integration/API/Federation.hs diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs index ec5d3aedcf..24c28c79ac 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -76,7 +76,7 @@ testGetAssetWrongToken = do uid1 <- randomUser OwnDomain def uid2 <- randomUser OtherDomain def userId2 <- uid2 %. "id" & asString - domain <- make OwnDomain & asString + domain <- uid1 %. "qualified_id" %. "domain" & asString r1 <- uploadSimple uid1 settings bdy r1.status `shouldMatchInt` 201 key <- r1.jsonBody %. "key" & asString @@ -144,47 +144,38 @@ testStreamAsset = do bdy = (applicationOctetStream, cs "Hello World") settings = object ["public" .= False, "retention" .= "volatile"] --- testStreamAssetNotAvailable :: TestM () --- testStreamAssetNotAvailable = do --- uid <- liftIO $ Id <$> nextRandom --- token <- randToken --- --- assetId <- liftIO $ Id <$> nextRandom --- let key = AssetKeyV3 assetId AssetPersistent --- let ga = --- GetAsset --- { user = uid, --- token = Just token, --- key = key --- } --- err <- withFederationError $ do --- runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) --- liftIO $ do --- Wai.code err @?= HTTP.notFound404 --- Wai.label err @?= "not-found" --- --- testStreamAssetWrongToken :: TestM () --- testStreamAssetWrongToken = do --- -- Initial upload --- let bdy = (applicationOctetStream, "Hello World") --- settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) --- uid <- randomUser --- ast :: Asset <- --- responseJsonError --- =<< uploadSimple (path "/assets/v3") uid settings bdy --- App () +testStreamAssetNotAvailable = do + uid <- randomUser OwnDomain def + uid2 <- randomUser OtherDomain def + userId <- uid2 %. "id" & asString + domain <- uid %. "qualified_id" %. "domain" & asString + token <- randomToken + assetId <- randomId + let key = "3-2-" <> assetId + ga = object ["user" .= userId, "token" .= token, "key" .= key, "domain" .= domain] + r <- downloadAsset' uid2 ga ga + r.status `shouldMatchInt` 404 + r.jsonBody %. "message" `shouldMatch` "Asset not found" + +testStreamAssetWrongToken :: HasCallStack => App () +testStreamAssetWrongToken = do + -- Initial upload + uid <- randomUser OwnDomain def + uid2 <- randomUser OtherDomain def + userId2 <- uid2 %. "id" & asString + domain <- uid %. "qualified_id" %. "domain" & asString + r1 <- uploadSimple uid settings bdy + r1.status `shouldMatchInt` 201 + + -- Call get-asset federation API with wrong (random) token + tok <- randomToken + key <- r1.jsonBody %. "key" & asString + let ga = object ["user" .= userId2, "token" .= tok, "key" .= key, "domain" .= domain] + r2 <- downloadAsset' uid2 ga ga + r2.status `shouldMatchInt` 404 + r2.jsonBody %. "message" `shouldMatch` "Asset not found" + where + bdy :: ConvertibleStrings String a => (MIME.MIMEType, a) + bdy = (applicationOctetStream, cs "Hello World") + settings = object ["public" .= False, "retention" .= "volatile"] diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 6dd63746b7..bf0869c0fd 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -208,7 +208,6 @@ executable cargohold-integration main-is: Main.hs other-modules: API - API.Federation API.Util App Metrics @@ -271,7 +270,6 @@ executable cargohold-integration , bytestring-conversion >=0.2 , cargohold , cargohold-types - , conduit , containers , federator , http-api-data diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 5157280005..8c2b3ebc4a 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -139,7 +139,6 @@ mkDerivation { bytestring bytestring-conversion cargohold-types - conduit containers federator HsOpenSSL diff --git a/services/cargohold/test/integration/API/Federation.hs b/services/cargohold/test/integration/API/Federation.hs deleted file mode 100644 index b9e8c325b9..0000000000 --- a/services/cargohold/test/integration/API/Federation.hs +++ /dev/null @@ -1,93 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module API.Federation (tests) where - -import API.Util -import Bilge -import Bilge.Assert -import CargoHold.API.V3 (randToken) -import Conduit -import Control.Lens -import Data.Id -import Data.Qualified -import Data.UUID.V4 -import Imports -import qualified Network.HTTP.Types as HTTP -import qualified Network.Wai.Utilities.Error as Wai -import Test.Tasty -import Test.Tasty.HUnit -import TestSetup -import Wire.API.Asset -import Wire.API.Federation.API -import Wire.API.Federation.API.Cargohold - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "API Federation" - [ testGroup - "stream-asset" - [ test s "stream asset not available" testStreamAssetNotAvailable, - test s "stream asset wrong token" testStreamAssetWrongToken - ] - ] - -testStreamAssetNotAvailable :: TestM () -testStreamAssetNotAvailable = do - uid <- liftIO $ Id <$> nextRandom - token <- randToken - - assetId <- liftIO $ Id <$> nextRandom - let key = AssetKeyV3 assetId AssetPersistent - let ga = - GetAsset - { user = uid, - token = Just token, - key = key - } - err <- withFederationError $ do - runFederationClient (unsafeFedClientIn @'Cargohold @"stream-asset" ga) - liftIO $ do - Wai.code err @?= HTTP.notFound404 - Wai.label err @?= "not-found" - -testStreamAssetWrongToken :: TestM () -testStreamAssetWrongToken = do - -- Initial upload - let bdy = (applicationOctetStream, "Hello World") - settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) - uid <- randomUser - ast :: Asset <- - responseJsonError - =<< uploadSimple (path "/assets/v3") uid settings bdy - Date: Mon, 27 Nov 2023 14:47:50 +1000 Subject: [PATCH 18/22] WPB-5382: Adding comments and removing code that couldn't be moved over. A couple of the tests from `services/cargohold` don't work well in the new integration suite. Two of these are looking for specific error strings when the configuration is incorrect, and the last is testing response codes for when asset IDs can be found, but the asset itself can't be streamed. --- integration/integration.cabal | 1 - integration/test/Test/Cargohold/API.hs | 18 --------- integration/test/Test/Cargohold/App.hs | 3 -- services/cargohold/cargohold.cabal | 1 - services/cargohold/test/integration/API.hs | 5 ++- services/cargohold/test/integration/App.hs | 2 + services/cargohold/test/integration/Main.hs | 2 - .../cargohold/test/integration/Metrics.hs | 38 ------------------- 8 files changed, 6 insertions(+), 64 deletions(-) delete mode 100644 integration/test/Test/Cargohold/App.hs delete mode 100644 services/cargohold/test/integration/Metrics.hs diff --git a/integration/integration.cabal b/integration/integration.cabal index 984e314dfa..f1f224a367 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -110,7 +110,6 @@ library Test.Cargohold.API.Federation Test.Cargohold.API.Util Test.Cargohold.API.V3 - Test.Cargohold.App Test.Cargohold.Metrics Test.Client Test.Conversation diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 2f38e3041d..6e719f5307 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -314,24 +314,6 @@ testRemoteDownloadNoAsset = do res <- downloadAsset' uid qkey () res.status `shouldMatchInt` 404 --- Deliberately causing a 500 error is tricky, and I can't see a nice way of doing it --- testRemoteDownloadFederationFailure :: HasCallStack => App () --- testRemoteDownloadFederationFailure = do --- assetId <- randomId --- uid <- randomUser OwnDomain def --- startDynamicBackends [def] $ \[remoteDomain] -> do --- let key = "3-2-" <> assetId --- qkey = --- object --- [ "domain" .= remoteDomain, --- "key" .= key --- ] --- res <- downloadAsset' uid qkey () --- res.status `shouldMatchInt` 500 --- resJ <- maybe (assertFailure "No JSON body") pure res.jsonBody --- asString (resJ %. "label") `shouldMatch` "mock-error" --- asString (resJ %. "message") `shouldMatch` "mock error" - testRemoteDownloadShort :: HasCallStack => App () testRemoteDownloadShort = remoteDownload "asset content" diff --git a/integration/test/Test/Cargohold/App.hs b/integration/test/Test/Cargohold/App.hs deleted file mode 100644 index 66e3d5f455..0000000000 --- a/integration/test/Test/Cargohold/App.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - -module Test.Cargohold.App where diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index bf0869c0fd..3d8bd520a0 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -210,7 +210,6 @@ executable cargohold-integration API API.Util App - Metrics Paths_cargohold TestSetup diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index a807d33730..6e2464b779 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- @@ -52,6 +51,10 @@ tests s = -------------------------------------------------------------------------------- -- Federation behaviour +-- This test doesn't fit in well with the `integration` style of tests. This is +-- because setting up the asset to have the weird state where the asset key exists, +-- but somehow the asset itself can't be downloaded is a bit beyond what the API +-- integration setup allows. So this specific test can stay here for now. testRemoteDownloadFederationFailure :: TestM () testRemoteDownloadFederationFailure = do assetId <- liftIO $ Id <$> nextRandom diff --git a/services/cargohold/test/integration/App.hs b/services/cargohold/test/integration/App.hs index 016de02496..b5ba0132d8 100644 --- a/services/cargohold/test/integration/App.hs +++ b/services/cargohold/test/integration/App.hs @@ -20,6 +20,8 @@ tests :: IO TestSetup -> TestTree tests s = testGroup "Configuration sanity checks" + -- The way that the `integration` tests are setup means that the error strings these + -- tests look for are suppressed in a general time out message when the service can't start. [ test s "multiIngress and cloudFront cannot be combined" testMultiIngressCloudFrontFails, test s "multiIngress and s3DownloadEndpoint cannot be combined" testMultiIngressS3DownloadEndpointFails ] diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs index a426653a21..f5997aebda 100644 --- a/services/cargohold/test/integration/Main.hs +++ b/services/cargohold/test/integration/Main.hs @@ -25,7 +25,6 @@ import qualified App import Data.Proxy import Data.Tagged import Imports hiding (local) -import qualified Metrics import Options.Applicative import Test.Tasty import Test.Tasty.Ingredients @@ -65,7 +64,6 @@ main = do testGroup "Cargohold" [ API.tests ts, - Metrics.tests ts, App.tests ts ] where diff --git a/services/cargohold/test/integration/Metrics.hs b/services/cargohold/test/integration/Metrics.hs deleted file mode 100644 index 0ffbeeab63..0000000000 --- a/services/cargohold/test/integration/Metrics.hs +++ /dev/null @@ -1,38 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module Metrics - ( tests, - ) -where - -import Bilge -import Bilge.Assert -import Imports -import Test.Tasty -import TestSetup - -tests :: IO TestSetup -> TestTree -tests s = testGroup "Metrics" [test s "prometheus" testPrometheusMetrics] - -testPrometheusMetrics :: TestM () -testPrometheusMetrics = do - cargohold <- viewUnversionedCargohold - get (cargohold . path "/i/metrics") !!! do - const 200 === statusCode - -- Should contain the request duration metric in its output - const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody From fe0ce0acf6c938f89ee8c19c9fb715782bd613e3 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Tue, 28 Nov 2023 14:41:28 +1000 Subject: [PATCH 19/22] WPB-5382: Use upstream url-safe base64 encoding --- integration/test/SetupHelpers.hs | 9 ++------- services/cargohold/test/integration/API.hs | 1 - 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 486b614d83..f361de3d45 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -11,7 +11,7 @@ import Control.Monad.Reader import Crypto.Random (getRandomBytes) import Data.Aeson hiding ((.=)) import Data.Aeson.Types qualified as Aeson -import Data.ByteString.Base64 qualified as B64Url +import Data.ByteString.Base64.URL qualified as B64Url import Data.ByteString.Char8 (unpack) import Data.Default import Data.Function @@ -168,12 +168,7 @@ createMLSOne2OnePartner domain other convDomain = loop -- Copied from `src/CargoHold/API/V3.hs` and inlined to avoid pulling in `types-common` randomToken :: HasCallStack => App String -randomToken = map mkUrlSafe . unpack . B64Url.encode <$> liftIO (getRandomBytes 16) - where - mkUrlSafe :: Char -> Char - mkUrlSafe '/' = '_' - mkUrlSafe '+' = '-' - mkUrlSafe c = c +randomToken = unpack . B64Url.encode <$> liftIO (getRandomBytes 16) randomId :: HasCallStack => App String randomId = liftIO (show <$> nextRandom) diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index 6e2464b779..4c9f8b65b4 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -1,4 +1,3 @@ - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH From 3cfcee8250086d8ebf2470321e6b2196a31fecc2 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Tue, 5 Dec 2023 11:29:58 +1000 Subject: [PATCH 20/22] Writing new tests for rate limiting --- deploy/dockerephemeral/federation-v0.yaml | 4 ++- .../federation-v0/nginz/conf/nginx.conf | 5 +++ integration/test/API/Cargohold.hs | 5 +++ integration/test/Test/Cargohold/API.hs | 32 +++++++++++++++++++ 4 files changed, 45 insertions(+), 1 deletion(-) diff --git a/deploy/dockerephemeral/federation-v0.yaml b/deploy/dockerephemeral/federation-v0.yaml index e262a4693a..1342056cac 100644 --- a/deploy/dockerephemeral/federation-v0.yaml +++ b/deploy/dockerephemeral/federation-v0.yaml @@ -185,7 +185,9 @@ services: ports: - '127.0.0.1:21097:8080' - '127.0.0.1:21098:8081' - healthcheck: *haskell_health_check + # healthcheck: *haskell_health_check + healthcheck: + test: "true" depends_on: coredns-federation: condition: service_started diff --git a/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf b/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf index b05c0cbe94..a604e9ab19 100644 --- a/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf +++ b/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf @@ -311,6 +311,11 @@ http { # Cargohold Endpoints + location ~* ^(/v[0-9]+)?/assets { + include common_response_with_zauth.conf; + proxy_pass http://cargohold; + } + location /assets { include common_response_with_zauth.conf; proxy_pass http://cargohold; diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index 3c36fd0369..666adc8cf4 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -110,6 +110,11 @@ downloadAsset' user loc tok = do req <- baseRequest user Cargohold Unversioned $ locPath submit "GET" $ req & tokenParam tok & noRedirect +downloadAssetV4Nginz :: (HasCallStack, MakesValue user, IsAssetToken tok) => user -> String -> tok -> App Response +downloadAssetV4Nginz user loc tok = do + req <- baseRequest user Nginz (ExplicitVersion 1) loc + submit "GET" $ req & tokenParam tok & noRedirect + downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response downloadAsset user assetDomain key zHostHeader trans = do domain <- objDomain assetDomain diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 6e719f5307..3042ccd8ee 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -37,8 +37,40 @@ import Network.HTTP.Types qualified as HTTP import SetupHelpers (randomId, randomUser) import Test.Cargohold.API.Util import Testlib.Prelude +import UnliftIO (replicateConcurrently_) import UnliftIO.Concurrent +testRateLimiting :: HasCallStack => App () +testRateLimiting = do + let settings = object ["public" .= False, "retention" .= "persistent"] + simpleRateLimiting settings + where + concurrentN = 100 + sequentialN = 100 + simpleRateLimiting :: HasCallStack => Value -> App () + simpleRateLimiting sets = do + uid <- randomUser OwnDomain def + uid2 <- randomUser OwnDomain def + userId2 <- uid2 %. "id" & asString + -- Initial upload + let bdy = (applicationText, cs "Hello World") + r1 <- uploadSimple uid sets bdy + r1.status `shouldMatchInt` 201 + loc <- maybe (error "Could not find the Location header") (pure . cs @_ @String) $ lookup (mk $ cs "Location") r1.headers + tok <- asString (r1.json %. "token") + + replicateConcurrently_ concurrentN $ replicateM_ sequentialN $ do + -- Lookup with token and download via redirect. + r2 <- downloadAssetV4Nginz uid2 loc tok + r2.status `shouldMatchInt` 302 + cs @_ @String r2.body `shouldMatch` "" + r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r2)) + r3.status `shouldMatchInt` 200 + assertBool "content-type should always be application/octet-stream" $ Just applicationOctetStream == fmap MIME.mimeType (getContentType r3) + assertBool "token mismatch" $ tok == decodeHeaderOrFail (mk $ cs "x-amz-meta-token") r3 + assertBool "user mismatch" $ userId2 == decodeHeaderOrFail (mk $ cs "x-amz-meta-user") r3 + assertBool "data mismatch" $ cs "Hello World" == r3.body + -------------------------------------------------------------------------------- -- Simple (single-step) uploads From 803a4e18a0abd76eedfdbd0e14614fdbfbab50ac Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 5 Jan 2024 10:22:25 +0000 Subject: [PATCH 21/22] clean up --- .../cargohold/test/integration/API/Util.hs | 34 +++++++------------ 1 file changed, 13 insertions(+), 21 deletions(-) diff --git a/services/cargohold/test/integration/API/Util.hs b/services/cargohold/test/integration/API/Util.hs index 59ea794f59..1c9e105724 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/services/cargohold/test/integration/API/Util.hs @@ -15,7 +15,19 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.Util where +module API.Util + ( randomUser, + uploadSimple, + decodeHeaderOrFail, + getContentType, + applicationText, + applicationOctetStream, + deleteAssetV3, + deleteAsset, + downloadAsset, + withMockFederator, + ) +where import Bilge hiding (body, host, port) import qualified Bilge @@ -30,7 +42,6 @@ import Data.ByteString.Builder import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy -import Data.Domain import Data.Id import Data.Qualified import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -192,25 +203,6 @@ downloadAsset :: TestM (Response (Maybe LByteString)) downloadAsset = downloadAssetWith id -postToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) -postToken uid key = do - c <- viewCargohold - post $ - c - . zUser uid - . paths ["assets", toByteString' key, "token"] - -deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) -deleteToken uid key = do - c <- viewCargohold - delete $ - c - . zUser uid - . paths ["assets", toByteString' key, "token"] - -viewFederationDomain :: TestM Domain -viewFederationDomain = view (tsOpts . settings . federationDomain) - -------------------------------------------------------------------------------- -- Mocking utilities From ad056ad30aa9fae45d96e2042326ebdf2d9c0859 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 5 Jan 2024 10:29:30 +0000 Subject: [PATCH 22/22] removed reate limiting test as it is broken --- integration/test/API/Cargohold.hs | 5 ---- integration/test/Test/Cargohold/API.hs | 32 -------------------------- 2 files changed, 37 deletions(-) diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index ae3693e69f..595ce75327 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -110,11 +110,6 @@ downloadAsset' user loc tok = do req <- baseRequest user Cargohold Unversioned $ locPath submit "GET" $ req & tokenParam tok & noRedirect -downloadAssetV4Nginz :: (HasCallStack, MakesValue user, IsAssetToken tok) => user -> String -> tok -> App Response -downloadAssetV4Nginz user loc tok = do - req <- baseRequest user Nginz (ExplicitVersion 1) loc - submit "GET" $ req & tokenParam tok & noRedirect - downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response downloadAsset user assetDomain key zHostHeader trans = do domain <- objDomain assetDomain diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index dcbd327629..25f3c4956d 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -37,40 +37,8 @@ import qualified Network.HTTP.Types as HTTP import SetupHelpers (randomId, randomUser) import Test.Cargohold.API.Util import Testlib.Prelude -import UnliftIO (replicateConcurrently_) import UnliftIO.Concurrent -testRateLimiting :: HasCallStack => App () -testRateLimiting = do - let settings = object ["public" .= False, "retention" .= "persistent"] - simpleRateLimiting settings - where - concurrentN = 100 - sequentialN = 100 - simpleRateLimiting :: HasCallStack => Value -> App () - simpleRateLimiting sets = do - uid <- randomUser OwnDomain def - uid2 <- randomUser OwnDomain def - userId2 <- uid2 %. "id" & asString - -- Initial upload - let bdy = (applicationText, cs "Hello World") - r1 <- uploadSimple uid sets bdy - r1.status `shouldMatchInt` 201 - loc <- maybe (error "Could not find the Location header") (pure . cs @_ @String) $ lookup (mk $ cs "Location") r1.headers - tok <- asString (r1.json %. "token") - - replicateConcurrently_ concurrentN $ replicateM_ sequentialN $ do - -- Lookup with token and download via redirect. - r2 <- downloadAssetV4Nginz uid2 loc tok - r2.status `shouldMatchInt` 302 - cs @_ @String r2.body `shouldMatch` "" - r3 <- flip get' id =<< parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") r2)) - r3.status `shouldMatchInt` 200 - assertBool "content-type should always be application/octet-stream" $ Just applicationOctetStream == fmap MIME.mimeType (getContentType r3) - assertBool "token mismatch" $ tok == decodeHeaderOrFail (mk $ cs "x-amz-meta-token") r3 - assertBool "user mismatch" $ userId2 == decodeHeaderOrFail (mk $ cs "x-amz-meta-user") r3 - assertBool "data mismatch" $ cs "Hello World" == r3.body - -------------------------------------------------------------------------------- -- Simple (single-step) uploads