diff --git a/changelog.d/5-internal/weed b/changelog.d/5-internal/weed new file mode 100644 index 00000000000..03b7ed904d9 --- /dev/null +++ b/changelog.d/5-internal/weed @@ -0,0 +1 @@ +Started weeding out dead code. diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 36d6527ae9d..d88cafb9187 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -123,14 +123,6 @@ getUser user target = do joinHttpPath ["users", domain, uid] submit "GET" req -getUserByHandle :: (HasCallStack, MakesValue user, MakesValue domain) => user -> domain -> String -> App Response -getUserByHandle user domain handle = do - domainStr <- asString domain - req <- - baseRequest user Brig Versioned $ - joinHttpPath ["users", "by-handle", domainStr, handle] - submit "GET" req - -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_clients__client_ getClient :: (HasCallStack, MakesValue user, MakesValue client) => @@ -476,9 +468,6 @@ getSwaggerPublicTOC = do joinHttpPath ["api", "swagger-ui"] submit "GET" req -getSwaggerInternalTOC :: (HasCallStack) => App Response -getSwaggerInternalTOC = error "FUTUREWORK: this API end-point does not exist." - getSwaggerPublicAllUI :: (HasCallStack) => Int -> App Response getSwaggerPublicAllUI version = do req <- diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index 5fbfd5cf2e5..cb5be7d48c0 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -160,17 +160,6 @@ refreshIndex domain = do res <- submit "POST" req res.status `shouldMatchInt` 200 -connectWithRemoteUser :: (MakesValue userFrom, MakesValue userTo) => userFrom -> userTo -> App () -connectWithRemoteUser userFrom userTo = do - userFromId <- objId userFrom - qUserTo <- make userTo - let body = ["tag" .= "CreateConnectionForTest", "user" .= userFromId, "other" .= qUserTo] - req <- - baseRequest userFrom Brig Unversioned $ - joinHttpPath ["i", "connections", "connection-update"] - res <- submit "PUT" (req & addJSONObject body) - res.status `shouldMatchInt` 200 - addFederationRemoteTeam :: (HasCallStack, MakesValue domain, MakesValue remoteDomain, MakesValue team) => domain -> remoteDomain -> team -> App () addFederationRemoteTeam domain remoteDomain team = do void $ addFederationRemoteTeam' domain remoteDomain team >>= getBody 200 diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index e21e26fed81..df8af34d71c 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -72,9 +72,6 @@ textPlainMime = MIME.Text $ T.pack "plain" multipartMixedMime :: String multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary -mimeTypeToString :: MIME.MIMEType -> String -mimeTypeToString = T.unpack . MIME.showMIMEType - buildUploadAssetRequestBody :: (HasCallStack, MakesValue assetRetention) => Bool -> diff --git a/integration/test/API/Common.hs b/integration/test/API/Common.hs index 12f4a3866ab..6b80f9e5305 100644 --- a/integration/test/API/Common.hs +++ b/integration/test/API/Common.hs @@ -10,13 +10,6 @@ import qualified Data.Vector as Vector import System.Random (randomIO, randomRIO) import Testlib.Prelude -teamRole :: String -> Int -teamRole "partner" = 1025 -teamRole "member" = 1587 -teamRole "admin" = 5951 -teamRole "owner" = 8191 -teamRole bad = error $ "unknown team role: " <> bad - -- | please don't use special shell characters like '!' here. it makes writing shell lines -- that use test data a lot less straight-forward. defPassword :: String diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index d4c4b6e366e..a0fe93d2993 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -614,6 +614,21 @@ disableLegalHold tid ownerid uid pw = do req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) submit "DELETE" (addJSONObject ["password" .= pw] req) +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_consent +consentToLegalHold :: (HasCallStack, MakesValue tid, MakesValue zusr) => tid -> zusr -> String -> App Response +consentToLegalHold tid zusr pwd = do + tidStr <- asString tid + req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "consent"]) + submit "POST" (addJSONObject ["password" .= pwd] req) + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_teams__tid__legalhold__uid_ +getLegalHoldStatus :: (HasCallStack, MakesValue tid, MakesValue zusr) => tid -> zusr -> App Response +getLegalHoldStatus tid zusr = do + tidStr <- asString tid + uidStr <- asString $ zusr %. "id" + req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) + submit "GET" req + -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings postLegalHoldSettings :: (HasCallStack, MakesValue ownerid, MakesValue tid, MakesValue newService) => tid -> ownerid -> newService -> App Response postLegalHoldSettings tid owner newSettings = @@ -653,21 +668,6 @@ approveLegalHoldDevice' tid uid forUid pwd = do req <- baseRequest uid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr, "approve"]) submit "PUT" (addJSONObject ["password" .= pwd] req) --- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_consent -consentToLegalHold :: (HasCallStack, MakesValue tid, MakesValue zusr) => tid -> zusr -> String -> App Response -consentToLegalHold tid zusr pwd = do - tidStr <- asString tid - req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "consent"]) - submit "POST" (addJSONObject ["password" .= pwd] req) - --- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_teams__tid__legalhold__uid_ -getLegalHoldStatus :: (HasCallStack, MakesValue tid, MakesValue zusr) => tid -> zusr -> App Response -getLegalHoldStatus tid zusr = do - tidStr <- asString tid - uidStr <- asString $ zusr %. "id" - req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) - submit "GET" req - -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__features_legalhold putLegalholdStatus :: (HasCallStack, MakesValue tid, MakesValue usr) => diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index 2c8638d578a..684da6542f3 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -755,17 +755,6 @@ createApplicationMessage cid messageContent = do setMLSCiphersuite :: Ciphersuite -> App () setMLSCiphersuite suite = modifyMLSState $ \mls -> mls {ciphersuite = suite} -withCiphersuite :: (HasCallStack) => Ciphersuite -> App a -> App a -withCiphersuite suite action = do - suite0 <- (.ciphersuite) <$> getMLSState - setMLSCiphersuiteIO <- appToIOKleisli setMLSCiphersuite - actionIO <- appToIO action - liftIO $ - bracket - (setMLSCiphersuiteIO suite) - (const (setMLSCiphersuiteIO suite0)) - (const actionIO) - leaveCurrentConv :: (HasCallStack) => ClientIdentity -> diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 8ffb512da7b..dffc4168bbe 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -98,16 +98,6 @@ header :: String -> String -> Request -> Request header name value req = req {requestHeaders = (mk $ cs name, cs value) : 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) $ "assets/v3/" <> tok - submit "GET" $ r $ req & tokenParam tok - class IsAssetToken tok where tokenParam :: tok -> Request -> Request diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 22195f3afdb..c948bccb649 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -593,24 +593,6 @@ testLHGetMembersIncludesStatus = do -- bob has accepted the legalhold device statusShouldBe "enabled" -type TB s = TaggedBool s - -enableLH :: (MakesValue tid, MakesValue teamAdmin, MakesValue targetUser, HasCallStack) => tid -> teamAdmin -> targetUser -> Bool -> App (Maybe String) -enableLH tid teamAdmin targetUser approveLH = do - -- alice requests a legalhold device for herself - requestLegalHoldDevice tid teamAdmin targetUser - >>= assertStatus 201 - - when approveLH do - approveLegalHoldDevice tid targetUser defPassword - >>= assertStatus 200 - legalholdUserStatus tid targetUser targetUser `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" - if approveLH - then Just <$> lhDeviceIdOf targetUser - else pure Nothing - testLHConnectionsWithNonConsentingUsers :: App () testLHConnectionsWithNonConsentingUsers = do (alice, tid, []) <- createTeam OwnDomain 1 diff --git a/integration/test/Testlib/Certs.hs b/integration/test/Testlib/Certs.hs index b6fda9b5204..64df6e4c152 100644 --- a/integration/test/Testlib/Certs.hs +++ b/integration/test/Testlib/Certs.hs @@ -32,10 +32,6 @@ privateKeyToString = toPem . keyToPEM PKCS8Format . PrivKeyRSA publicKeyToString :: RSA.PublicKey -> String publicKeyToString = toPem . pubKeyToPEM . PubKeyRSA --- | order: publickey, private key -keyPairToString :: RSAKeyPair -> (String, String) -keyPairToString = bimap publicKeyToString privateKeyToString - -- | the minimum key size is hard coded to be 256 bytes (= 2048 bits) mkKeyPair :: (HasCallStack) => (Integer, Integer) -> App RSAKeyPair mkKeyPair primes = @@ -57,21 +53,6 @@ primesB = 1030843359898456423663521323846594342599509001361505950190458094255790543792826808869649005832755187592625111972154015489882697017782849415061917844274039201990123282710414810809677284498651901967728601289390435426055251344683598043635553930587608961202440578033000424009931449958127951542294372025522185552538021557179009278446615246891375299863655746951224012338422185000952023195927317706092311999889180603374149659663869483313116251085191329801800565556652256960650364631610748235925879940728370511827034946814052737660926604082837303885143652256413187183052924192977324527952882600246973965189570970469037044568259408811931440525775822585332497163319841870179534838043708793539688804501356153704884928847627798172061867373042270416202913078776299057112318300845218218100606684092792088779583532324019862407866255929320869554565576301069075336647916168479092314004711778618335406757602974282533765740790546167166172626995630463716394043281720388344899550856555259477489548509996409954619324524195894460510128676025203769176155038527250084664954695197534485529595784255553806751541708069739004260117122700058054443774458724994738753921481706985581116480802534320353367271370286704034867136678539759260831996400891886615914808935283451835347282009482924185619896114631919985205238905153951336432886954324618000593140640843908517786951586431386674557882396487935889471856924185568502767114186884930347618747984770073080480895996031031971187681573023398782756925726725786964170460286504569090697402674905089317540771910375616350312239688178277204391962835159620450731320465816254229575392846112372636483958055913716148919092913102176828552932292829256960875180097808893909460952573027221089128208000054670526724565994184754244760290009957352237133054978847493874379201323517903544742831961755055100216728931496213920467911320372016970509300894067675803619448926461034580033818298648457643287641768005986812455071220244863874301028965665847375769473444088940776224643189987541019987285740411119351744972645543429351630677554481991322726604779330104110295967482897278840078926508970545806499140537364387530291523697762079684955475417383069988065253583073257131193644210418873929829417895241230927769637328283865111435730810586338426336027745629520975220163350734423915441885289661065494424704587153904031874537230782548938379423349488654701140981815973723582107593419642780372301171156324514852331126462907486017679770773972513376077318418003532168673261819818236071249 ) --- | create a root certificate authority CertificateBundle -createRootCA :: - (HasCallStack) => - -- | the root CA's name - String -> - -- | the root CA's keymaterial - RSAKeyPair -> - SignedCert -createRootCA caName (pubKey, privKey) = - mkSignedCert - pubKey - privKey - caName - caName - -- | sign an intermediate/ leaf certificate by signing with an intermediate/ root CA's key intermediateCert :: (HasCallStack) => diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 08ddcb5d965..6f1e7d4a2a9 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -11,8 +11,6 @@ import Data.Functor import Data.IORef import qualified Data.Map as Map import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set import Data.Traversable (for) import qualified Data.Yaml as Yaml import qualified Database.CQL.IO as Cassandra @@ -161,18 +159,6 @@ mkEnv ge = do timeOutSeconds = ge.gTimeOutSeconds } -destroy :: IORef (Set BackendResource) -> BackendResource -> IO () -destroy ioRef = modifyIORef' ioRef . Set.insert - -create :: IORef (Set.Set BackendResource) -> IO BackendResource -create ioRef = - atomicModifyIORef - ioRef - $ \s -> - case Set.minView s of - Nothing -> error "No resources available" - Just (r, s') -> (s', r) - allCiphersuites :: [Ciphersuite] -- FUTUREWORK: add 0x0005 to this list once openmls supports it allCiphersuites = map Ciphersuite ["0x0001", "0xf031", "0x0002", "0x0007"] diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 153a8008c79..14c285f964a 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -78,9 +78,6 @@ addQueryParams :: [(String, String)] -> HTTP.Request -> HTTP.Request addQueryParams params req = HTTP.setQueryString (map (\(k, v) -> (cs k, Just (cs v))) params) req -contentTypeJSON :: HTTP.Request -> HTTP.Request -contentTypeJSON = addHeader "Content-Type" "application/json" - contentTypeMixed :: HTTP.Request -> HTTP.Request contentTypeMixed = addHeader "Content-Type" "multipart/mixed" diff --git a/integration/test/Testlib/Prelude.hs b/integration/test/Testlib/Prelude.hs index 69c3797f54d..3bacfc4dd82 100644 --- a/integration/test/Testlib/Prelude.hs +++ b/integration/test/Testlib/Prelude.hs @@ -52,15 +52,6 @@ module Testlib.Prelude putStr, putStrLn, print, - getChar, - getLine, - getContents, - interact, - readFile, - writeFile, - appendFile, - readIO, - readLn, liftIO, -- * Functor @@ -186,33 +177,6 @@ putStrLn = liftIO . P.putStrLn print :: (Show a, MonadIO m) => a -> m () print = liftIO . P.print -getChar :: (MonadIO m) => m Char -getChar = liftIO P.getChar - -getLine :: (MonadIO m) => m String -getLine = liftIO P.getLine - -getContents :: (MonadIO m) => m String -getContents = liftIO P.getContents - -interact :: (MonadIO m) => (String -> String) -> m () -interact = liftIO . P.interact - -readFile :: (MonadIO m) => FilePath -> m String -readFile = liftIO . P.readFile - -writeFile :: (MonadIO m) => FilePath -> String -> m () -writeFile = fmap liftIO . P.writeFile - -appendFile :: (MonadIO m) => FilePath -> String -> m () -appendFile = fmap liftIO . P.appendFile - -readIO :: (Read a, MonadIO m) => String -> m a -readIO = liftIO . P.readIO - -readLn :: (Read a, MonadIO m) => m a -readLn = liftIO P.readLn - ---------------------------------------------------------------------- -- Functor diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 77edab5326f..e07324e172a 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -23,7 +23,6 @@ module Bilge.RPC RPCException (..), rpc, rpc', - statusCheck, parseResponse, rpcExceptionMsg, ) @@ -34,7 +33,6 @@ import Bilge.Request import Bilge.Response import Control.Error hiding (err) import Control.Monad.Catch (MonadCatch, MonadThrow (..), try) -import Control.Monad.Except import Data.Aeson (FromJSON, eitherDecode') import Data.CaseInsensitive (original) import Data.Text.Lazy (pack) @@ -104,17 +102,6 @@ rpcExceptionMsg (RPCException sys req ex) = headers = foldr hdr id (HTTP.requestHeaders req) hdr (k, v) x = x ~~ original k .= v -statusCheck :: - (MonadError e m) => - Int -> - (LText -> e) -> - Response (Maybe LByteString) -> - m () -statusCheck c f r = - unless (statusCode r == c) $ - throwError $ - f ("unexpected status code: " <> pack (show $ statusCode r)) - parseResponse :: (Exception e, MonadThrow m, FromJSON a) => (LText -> e) -> diff --git a/libs/bilge/src/Bilge/TestSession.hs b/libs/bilge/src/Bilge/TestSession.hs index 246b7a17bcb..4f49c2d23e6 100644 --- a/libs/bilge/src/Bilge/TestSession.hs +++ b/libs/bilge/src/Bilge/TestSession.hs @@ -40,6 +40,3 @@ liftSession session = SessionT $ do let resultInState = runReaderT session app let resultInIO = ST.evalStateT resultInState clientState liftIO resultInIO - -runSessionT :: (Monad m) => SessionT m a -> Wai.Application -> m a -runSessionT session app = ST.evalStateT (runReaderT (unSessionT session) app) WaiTest.initState diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 7f294c52fac..2f67b800eb5 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -148,13 +148,12 @@ test-suite brig-types-tests -Wunused-packages build-depends: - aeson >=2.0.1.0 - , base >=4 && <5 + aeson >=2.0.1.0 + , base >=4 && <5 , brig-types - , bytestring-conversion >=0.3.1 , imports , openapi3 - , QuickCheck >=2.9 + , QuickCheck >=2.9 , tasty , tasty-hunit , tasty-quickcheck diff --git a/libs/brig-types/default.nix b/libs/brig-types/default.nix index 78932b5d379..50587cd4eeb 100644 --- a/libs/brig-types/default.nix +++ b/libs/brig-types/default.nix @@ -43,7 +43,6 @@ mkDerivation { testHaskellDepends = [ aeson base - bytestring-conversion imports openapi3 QuickCheck diff --git a/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs b/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs index 13cfc3570e6..d7f91ce70c7 100644 --- a/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs +++ b/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs @@ -19,7 +19,6 @@ module Test.Brig.Roundtrip where import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) import Data.Aeson.Types (parseEither) -import Data.ByteString.Conversion import Data.OpenApi (ToSchema, validatePrettyToJSON) import Imports import Test.Tasty (TestTree) @@ -56,14 +55,3 @@ testRoundTripWithSwagger = testProperty msg (trip .&&. scm) validatePrettyToJSON v ) $ isNothing (validatePrettyToJSON v) - -testRoundTripByteString :: - forall a. - (Arbitrary a, Typeable a, ToByteString a, FromByteString a, Eq a, Show a) => - TestTree -testRoundTripByteString = testProperty msg trip - where - msg = show (typeRep @a) - trip (v :: a) = - counterexample (show $ toByteString' v) $ - Just v === (fromByteString . toByteString') v diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index 795083fe39d..c7d4c352a99 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -24,7 +24,6 @@ module Cassandra.Exec paramsP, x5, x1, - syncCassandra, paginateC, PageWithState (..), paginateWithState, @@ -80,15 +79,6 @@ data CassandraError | Other !SomeException deriving (Show) -syncCassandra :: (MonadIO m, MonadCatch m) => m a -> m (Either CassandraError a) -syncCassandra m = - catches - (Right <$> m) - [ Handler $ \(e :: Error) -> pure . Left . Cassandra $ e, - Handler $ \(e :: IOException) -> pure . Left . Comm $ e, - Handler $ \(e :: SomeException) -> pure . Left . Other $ e - ] - -- | Stream results of a query. -- -- You can execute this conduit by doing @transPipe (runClient ...)@. diff --git a/libs/cassandra-util/src/Cassandra/Helpers.hs b/libs/cassandra-util/src/Cassandra/Helpers.hs index 8a260d530b5..4c2834f7ffc 100644 --- a/libs/cassandra-util/src/Cassandra/Helpers.hs +++ b/libs/cassandra-util/src/Cassandra/Helpers.hs @@ -1,4 +1,4 @@ -module Cassandra.Helpers where +module Cassandra.Helpers (toOptionFieldName) where import Data.Aeson.TH import Imports diff --git a/libs/extended/default.nix b/libs/extended/default.nix index b47de8057a2..61f4643c17e 100644 --- a/libs/extended/default.nix +++ b/libs/extended/default.nix @@ -14,7 +14,6 @@ , data-default , errors , exceptions -, extra , gitignoreSource , hspec , hspec-discover @@ -25,7 +24,6 @@ , lib , metrics-wai , monad-control -, optparse-applicative , resourcet , retry , servant @@ -59,14 +57,12 @@ mkDerivation { data-default errors exceptions - extra http-client http-client-tls http-types imports metrics-wai monad-control - optparse-applicative resourcet retry servant diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index 03d180a004a..65ad7864014 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -22,7 +22,6 @@ library Data.Time.Clock.DiffTime Network.AMQP.Extended Network.RabbitMqAdmin - Options.Applicative.Extended Servant.API.Extended Servant.API.Extended.Endpath Servant.API.Extended.RawM @@ -90,14 +89,12 @@ library , data-default , errors , exceptions - , extra , http-client , http-client-tls , http-types , imports , metrics-wai , monad-control - , optparse-applicative , resourcet , retry , servant diff --git a/libs/extended/src/Data/Time/Clock/DiffTime.hs b/libs/extended/src/Data/Time/Clock/DiffTime.hs index 5541fd43d38..b84c9f9a95e 100644 --- a/libs/extended/src/Data/Time/Clock/DiffTime.hs +++ b/libs/extended/src/Data/Time/Clock/DiffTime.hs @@ -1,13 +1,7 @@ module Data.Time.Clock.DiffTime ( DiffTime, - weeksToDiffTime, - daysToDiffTime, - hoursToDiffTime, - minutesToDiffTime, secondsToDiffTime, millisecondsToDiffTime, - microsecondsToDiffTime, - nanosecondsToDiffTime, picosecondsToDiffTime, diffTimeToFullMicroseconds, diffTimeToPicoseconds, @@ -17,27 +11,14 @@ where import Data.Time import Imports -weeksToDiffTime, - daysToDiffTime, - hoursToDiffTime, - minutesToDiffTime, - millisecondsToDiffTime, - microsecondsToDiffTime, - nanosecondsToDiffTime :: - Integer -> DiffTime -weeksToDiffTime = daysToDiffTime . (7 *) -daysToDiffTime = hoursToDiffTime . (24 *) -hoursToDiffTime = minutesToDiffTime . (60 *) -minutesToDiffTime = secondsToDiffTime . (60 *) +-- we really should be doing all this with https://hackage.haskell.org/package/units... +millisecondsToDiffTime :: Integer -> DiffTime millisecondsToDiffTime = picosecondsToDiffTime . (e9 *) -microsecondsToDiffTime = picosecondsToDiffTime . (e6 *) -nanosecondsToDiffTime = picosecondsToDiffTime . (e3 *) -- | Rounds down. Useful for 'threadDelay', 'timeout', etc. diffTimeToFullMicroseconds :: DiffTime -> Int diffTimeToFullMicroseconds = fromInteger . (`div` e6) . diffTimeToPicoseconds -e3, e6, e9 :: Integer -e3 = 1_000 +e6, e9 :: Integer e6 = 1_000_000 e9 = 1_000_000_000 diff --git a/libs/extended/src/Options/Applicative/Extended.hs b/libs/extended/src/Options/Applicative/Extended.hs deleted file mode 100644 index 3a44fecb188..00000000000 --- a/libs/extended/src/Options/Applicative/Extended.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - --- 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 . - --- | A version of "Options.Applicative" with extra utilities. -module Options.Applicative.Extended - ( module Options.Applicative, - - -- * Extra option readers - autoRange, - ) -where - -import Data.List.Extra (stripInfix) -import Imports -import Options.Applicative - --- | A reader that accepts either @N@ or @N..M@ (not necessarily just --- numbers). -autoRange :: (Read a) => ReadM (a, a) -autoRange = eitherReader $ \arg -> case stripInfix ".." arg of - Nothing -> (\a -> (a, a)) <$> readEither arg - Just (l, r) -> case (readEither l, readEither r) of - (Right lv, Right rv) -> Right (lv, rv) - (Left e, _) -> Left ("can't parse lower end: " <> e) - (_, Left e) -> Left ("can't parse upper end: " <> e) diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index b08103a22cd..1674d3bae0f 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -18,16 +18,13 @@ -- with this program. If not, see . module Galley.Types - ( foldrOtrRecipients, - Accept (..), + ( Accept (..), ) where import Data.Aeson -import Data.Id (ClientId, UserId) -import Data.Map.Strict qualified as Map +import Data.Id (UserId) import Imports -import Wire.API.Message -------------------------------------------------------------------------------- -- Accept @@ -47,14 +44,3 @@ instance ToJSON Accept where instance FromJSON Accept where parseJSON = withObject "accept" $ \o -> Accept <$> o .: "user" - --------------------------------------------------------------------------------- --- utility functions - -foldrOtrRecipients :: (UserId -> ClientId -> Text -> a -> a) -> a -> OtrRecipients -> a -foldrOtrRecipients f a = - Map.foldrWithKey go a - . userClientMap - . otrRecipientsMap - where - go u cs acc = Map.foldrWithKey (f u) acc cs diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index 6c0df12d8a5..b9539ae81ac 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -35,7 +35,6 @@ module Gundeck.Types.Push.V2 pushNativeAps, pushNativePriority, pushPayload, - singletonRecipient, singletonPayload, Recipient (..), RecipientClients (..), @@ -79,7 +78,6 @@ import Data.Json.Util import Data.List1 import Data.List1 qualified as List1 import Data.Range -import Data.Range qualified as Range import Data.Set qualified as Set import Imports import Wire.API.Message (Priority (..)) @@ -273,9 +271,6 @@ newPush from to pload = _pushPayload = pload } -singletonRecipient :: Recipient -> Range 1 1024 (Set Recipient) -singletonRecipient = Range.unsafeRange . Set.singleton - singletonPayload :: (ToJSONObject a) => a -> List1 Object singletonPayload = List1.singleton . toJSONObject diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index 6d1df7d26ff..a66da6837a2 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -27,10 +27,8 @@ module Data.Metrics.Servant where import Data.ByteString.UTF8 qualified as UTF8 -import Data.Metrics.Middleware.Prometheus (normalizeWaiRequestRoute) import Data.Metrics.Types import Data.Metrics.Types qualified as Metrics -import Data.Metrics.WaiRoute (treeToPaths) import Data.Proxy import Data.Text.Encoding import Data.Text.Encoding.Error @@ -40,7 +38,6 @@ import Imports import Network.Wai qualified as Wai import Network.Wai.Middleware.Prometheus import Network.Wai.Middleware.Prometheus qualified as Promth -import Network.Wai.Routing (Routes, prepare) import Servant.API import Servant.Multipart @@ -57,18 +54,6 @@ servantPrometheusMiddleware _ = Promth.prometheus conf . instrument promthNormal -- See Note [Raw Response] instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses -servantPlusWAIPrometheusMiddleware :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Routes a m b -> proxy api -> Wai.Middleware -servantPlusWAIPrometheusMiddleware routes _ = do - Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths) - where - -- See Note [Raw Response] - instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses - - paths = - let Paths servantPaths = routesToPaths @api - Paths waiPaths = treeToPaths (prepare routes) - in Paths (meltTree (servantPaths <> waiPaths)) - conf :: PrometheusSettings conf = Promth.def diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs index 8cdf9f6600a..8d2b82bc758 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs @@ -5,7 +5,6 @@ module Wire.Sem.Concurrency where import Data.Kind (Type) import Imports import Polysemy -import Polysemy.Internal data ConcurrencySafety = Safe | Unsafe @@ -105,67 +104,3 @@ unsafePooledForConcurrentlyN_ n as f = send (UnsafePooledMapConcurrentlyN_ n f as :: Concurrency 'Unsafe (Sem r) ()) {-# INLINEABLE unsafePooledForConcurrentlyN_ #-} - -pooledMapConcurrentlyN :: - forall r' r t a b. - (r' ~ '[Final IO]) => - (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => - -- | Max. number of threads. Should not be less than 1. - Int -> - (a -> Sem r' b) -> - t a -> - Sem r [b] -pooledMapConcurrentlyN n f as = - send - ( UnsafePooledMapConcurrentlyN n (subsume_ @r' @r . f) as :: - Concurrency 'Safe (Sem r) [b] - ) -{-# INLINEABLE pooledMapConcurrentlyN #-} - -pooledMapConcurrentlyN_ :: - forall r' r t a b. - (r' ~ '[Final IO]) => - (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => - -- | Max. number of threads. Should not be less than 1. - Int -> - (a -> Sem r' b) -> - t a -> - Sem r () -pooledMapConcurrentlyN_ n f as = - send - ( UnsafePooledMapConcurrentlyN_ n (subsume_ @r' @r . f) as :: - Concurrency 'Safe (Sem r) () - ) -{-# INLINEABLE pooledMapConcurrentlyN_ #-} - -pooledForConcurrentlyN :: - forall r' r t a b. - (r' ~ '[Final IO]) => - (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => - -- | Max. number of threads. Should not be less than 1. - Int -> - t a -> - (a -> Sem r' b) -> - Sem r [b] -pooledForConcurrentlyN n as f = - send - ( UnsafePooledMapConcurrentlyN n (subsume_ @r' @r . f) as :: - Concurrency 'Safe (Sem r) [b] - ) -{-# INLINEABLE pooledForConcurrentlyN #-} - -pooledForConcurrentlyN_ :: - forall r' r t a b. - (r' ~ '[Final IO]) => - (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => - -- | Max. number of threads. Should not be less than 1. - Int -> - t a -> - (a -> Sem r' b) -> - Sem r () -pooledForConcurrentlyN_ n as f = - send - ( UnsafePooledMapConcurrentlyN_ n (subsume_ @r' @r . f) as :: - Concurrency 'Safe (Sem r) () - ) -{-# INLINEABLE pooledForConcurrentlyN_ #-} diff --git a/libs/tasty-cannon/src/Test/Tasty/Cannon.hs b/libs/tasty-cannon/src/Test/Tasty/Cannon.hs index 7fb72b5ca33..44503d63123 100644 --- a/libs/tasty-cannon/src/Test/Tasty/Cannon.hs +++ b/libs/tasty-cannon/src/Test/Tasty/Cannon.hs @@ -31,12 +31,8 @@ module Test.Tasty.Cannon close, bracket, bracketAsClient, - bracketN, - bracketAsClientN, -- ** Random Connection IDs - connectR, - connectAsClientR, bracketR, bracketAsClientR, bracketR2, @@ -142,36 +138,8 @@ bracketAsClient :: bracketAsClient can uid client conn = Catch.bracket (connectAsClient can uid client conn) close -bracketN :: - (MonadIO m, MonadMask m) => - Cannon -> - [(UserId, ConnId)] -> - ([WebSocket] -> m a) -> - m a -bracketN c us f = go [] us - where - go wss [] = f (reverse wss) - go wss ((x, y) : xs) = bracket c x y (\ws -> go (ws : wss) xs) - -bracketAsClientN :: - (MonadMask m, MonadIO m) => - Cannon -> - [(UserId, ClientId, ConnId)] -> - ([WebSocket] -> m a) -> - m a -bracketAsClientN c us f = go [] us - where - go wss [] = f (reverse wss) - go wss ((x, y, z) : xs) = bracketAsClient c x y z (\ws -> go (ws : wss) xs) - -- Random Connection IDs -connectR :: (MonadIO m) => Cannon -> UserId -> m WebSocket -connectR can uid = randomConnId >>= connect can uid - -connectAsClientR :: (MonadIO m) => Cannon -> UserId -> ClientId -> m WebSocket -connectAsClientR can uid clientId = randomConnId >>= connectAsClient can uid clientId - bracketR :: (MonadIO m, MonadMask m) => Cannon -> UserId -> (WebSocket -> m a) -> m a bracketR can usr f = do cid <- randomConnId diff --git a/libs/types-common-aws/src/Util/Test/SQS.hs b/libs/types-common-aws/src/Util/Test/SQS.hs index 6a527482150..f9d015a1631 100644 --- a/libs/types-common-aws/src/Util/Test/SQS.hs +++ b/libs/types-common-aws/src/Util/Test/SQS.hs @@ -135,12 +135,6 @@ execute env = AWS.runResourceT . flip runReaderT env ----------------------------------------------------------------------------- -- Internal. Most of these functions _can_ be used outside of this function -- but probably do not need to -receive :: Int -> Text -> SQS.ReceiveMessage -receive n url = - SQS.newReceiveMessage url - & set SQS.receiveMessage_waitTimeSeconds (Just 1) - . set SQS.receiveMessage_maxNumberOfMessages (Just n) - . set SQS.receiveMessage_visibilityTimeout (Just 1) deleteMessage :: (MonadReader AWS.Env m, MonadResource m) => Text -> SQS.Message -> m () deleteMessage url m = do diff --git a/libs/types-common-journal/src/Data/Proto/Id.hs b/libs/types-common-journal/src/Data/Proto/Id.hs index 6210c8e78ac..8a0c3ed6a25 100644 --- a/libs/types-common-journal/src/Data/Proto/Id.hs +++ b/libs/types-common-journal/src/Data/Proto/Id.hs @@ -17,13 +17,10 @@ module Data.Proto.Id where -import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.ByteString.Lazy (toStrict) import Data.Id import Data.UUID qualified as UUID import Imports toBytes :: Id a -> ByteString toBytes = toStrict . UUID.toByteString . toUUID - -fromBytes :: ByteString -> Maybe (Id a) -fromBytes = fmap Id . UUID.fromByteString . fromStrict diff --git a/libs/types-common/src/Data/Handle.hs b/libs/types-common/src/Data/Handle.hs index 64842b51e70..ce8c8f1a4ac 100644 --- a/libs/types-common/src/Data/Handle.hs +++ b/libs/types-common/src/Data/Handle.hs @@ -21,7 +21,6 @@ module Data.Handle ( Handle (fromHandle), parseHandle, parseHandleEither, - isValidHandle, BadHandle (..), ) where @@ -73,9 +72,6 @@ instance FromByteString Handle where parseHandle :: Text -> Maybe Handle parseHandle = either (const Nothing) Just . parseHandleEither -isValidHandle :: Text -> Bool -isValidHandle = isRight . parseHandleEither - parseHandleEither :: Text -> Either String Handle parseHandleEither = Atto.parseOnly (handleParser <* Atto.endOfInput) . Text.E.encodeUtf8 diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 87ac386a7c4..c152fc6539c 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -43,7 +43,6 @@ module Data.Json.Util base64Schema, base64URLSchema, Base64ByteStringL (..), - base64SchemaL, fromBase64TextLenient, fromBase64Text, toBase64Text, @@ -269,9 +268,6 @@ instance S.ToParamSchema Base64ByteStringL where base64SchemaLN :: ValueSchema NamedSwaggerDoc LByteString base64SchemaLN = L.toStrict .= fmap L.fromStrict base64SchemaN -base64SchemaL :: ValueSchema SwaggerDoc LByteString -base64SchemaL = unnamed base64SchemaLN - -------------------------------------------------------------------------------- -- Utilities diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 0d1632ad4b1..d6367a1f851 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -26,7 +26,6 @@ module Data.Qualified qToPair, QualifiedWithTag, tUnqualified, - tUnqualifiedL, tDomain, tUntagged, qTagUnsafe, @@ -48,7 +47,7 @@ module Data.Qualified ) where -import Control.Lens (Lens, lens, over, (?~)) +import Control.Lens (over, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Bifunctor (first) import Data.Domain (Domain) @@ -93,9 +92,6 @@ tUnqualified = qUnqualified . tUntagged tDomain :: QualifiedWithTag t a -> Domain tDomain = qDomain . tUntagged -tUnqualifiedL :: Lens (QualifiedWithTag t a) (QualifiedWithTag t b) a b -tUnqualifiedL = lens tUnqualified qualifyAs - -- | A type representing a 'Qualified' value where the domain is guaranteed to -- be remote. type Remote = QualifiedWithTag 'QRemote diff --git a/libs/types-common/src/Data/Text/Ascii.hs b/libs/types-common/src/Data/Text/Ascii.hs index 7f167d611cd..2299facd5c7 100644 --- a/libs/types-common/src/Data/Text/Ascii.hs +++ b/libs/types-common/src/Data/Text/Ascii.hs @@ -38,7 +38,6 @@ module Data.Text.Ascii -- * Standard Characters Standard (..), Ascii, - validateStandard, -- * Printable Characters Printable (..), @@ -67,10 +66,6 @@ module Data.Text.Ascii encodeBase16, decodeBase16, - -- * Safe Widening - widen, - widenChar, - -- * Unsafe Construction unsafeFromText, unsafeFromByteString, @@ -198,9 +193,6 @@ instance AsciiChars Standard where contains Standard = isAscii {-# INLINE contains #-} -validateStandard :: Text -> Either String Ascii -validateStandard = validate - -------------------------------------------------------------------------------- -- Printable @@ -364,19 +356,6 @@ encodeBase16 = unsafeFromByteString . B16.encode decodeBase16 :: AsciiBase16 -> Maybe ByteString decodeBase16 t = either (const Nothing) Just (B16.decode (toByteString' t)) --------------------------------------------------------------------------------- --- Safe Widening - --- | Safely widen an ASCII text into another ASCII text with a larger --- character set. -widen :: (Subset c c' ~ 'True) => AsciiText c -> AsciiText c' -widen (AsciiText t) = AsciiText t - --- | Safely widen an ASCII character into another ASCII character with a larger --- character set. -widenChar :: (Subset c c' ~ 'True) => AsciiChar c -> AsciiChar c' -widenChar (AsciiChar t) = AsciiChar t - -------------------------------------------------------------------------------- -- Unsafe Construction diff --git a/libs/types-common/src/Data/UUID/Tagged.hs b/libs/types-common/src/Data/UUID/Tagged.hs index fa6eb11ce5f..14aceb1f5d2 100644 --- a/libs/types-common/src/Data/UUID/Tagged.hs +++ b/libs/types-common/src/Data/UUID/Tagged.hs @@ -22,17 +22,14 @@ module Data.UUID.Tagged V5, Version (..), version, - variant, addv4, unpack, - create, mk, ) where import Data.Bits import Data.UUID qualified as D -import Data.UUID.V4 qualified as D4 import Imports -- | Versioned UUID. @@ -68,10 +65,6 @@ mk u = UUID $ (retainVariant 2 x2) x3 --- | Create a fresh UUIDv4. -create :: IO (UUID V4) -create = UUID <$> D4.nextRandom - -- | Extract the 'D.UUID' from a versioned UUID. unpack :: UUID v -> D.UUID unpack (UUID x) = x @@ -100,12 +93,6 @@ version u = let (_, x, _, _) = D.toWords u in (x .&. 0x0000F000) `shiftR` 12 --- | Tell the variant of a 'D.UUID' value. -variant :: D.UUID -> Word32 -variant u = - let (_, _, x, _) = D.toWords u - in (x .&. 0xC0000000) `shiftR` 30 - -- Internal: retainVersion :: Word32 -> Word32 -> Word32 diff --git a/libs/types-common/src/Util/Options.hs b/libs/types-common/src/Util/Options.hs index 2d46e74097a..f82600dc00b 100644 --- a/libs/types-common/src/Util/Options.hs +++ b/libs/types-common/src/Util/Options.hs @@ -37,7 +37,6 @@ import Imports import Options.Applicative import Options.Applicative.Types import URI.ByteString -import Util.Options.Common data AWSEndpoint = AWSEndpoint { _awsHost :: !ByteString, @@ -147,10 +146,3 @@ getOptions desc mp defaultPath = do parseAWSEndpoint :: ReadM AWSEndpoint parseAWSEndpoint = readerAsk >>= maybe (error "Could not parse AWS endpoint") pure . fromByteString . fromString - -discoUrlParser :: Parser Text -discoUrlParser = - textOption $ - long "disco-url" - <> metavar "URL" - <> help "klabautermann url" diff --git a/libs/types-common/src/Util/Options/Common.hs b/libs/types-common/src/Util/Options/Common.hs index 14b997bee7e..e7b3eaf3dac 100644 --- a/libs/types-common/src/Util/Options/Common.hs +++ b/libs/types-common/src/Util/Options/Common.hs @@ -22,10 +22,7 @@ module Util.Options.Common where import Cassandra.Helpers (toOptionFieldName) -import Data.ByteString.Char8 qualified as C -import Data.Text qualified as T import Imports hiding (reader) -import Options.Applicative import System.Posix.Env qualified as Posix optOrEnv :: (a -> b) -> Maybe a -> (String -> b) -> String -> IO b @@ -37,9 +34,3 @@ optOrEnvSafe :: (a -> b) -> Maybe a -> (String -> b) -> String -> IO (Maybe b) optOrEnvSafe getter conf reader var = case conf of Nothing -> fmap reader <$> Posix.getEnv var Just c -> pure $ Just (getter c) - -bytesOption :: Mod OptionFields String -> Parser ByteString -bytesOption = fmap C.pack . strOption - -textOption :: Mod OptionFields String -> Parser Text -textOption = fmap T.pack . strOption diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs index aea3d8b41f3..09abc767e1a 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs @@ -23,7 +23,6 @@ module Network.Wai.Utilities.Error ErrorData (..), mkError, (!>>), - byteStringError, ) where @@ -31,7 +30,6 @@ import Control.Error import Data.Aeson hiding (Error) import Data.Aeson.Types (Pair) import Data.Domain -import Data.Text.Lazy.Encoding (decodeUtf8) import Imports import Network.HTTP.Types @@ -69,10 +67,6 @@ instance FromJSON ErrorData where <$> o .: "domain" <*> o .: "path" --- | Assumes UTF-8 encoding. -byteStringError :: Status -> LByteString -> LByteString -> Error -byteStringError s l m = mkError s (decodeUtf8 l) (decodeUtf8 m) - instance ToJSON Error where toJSON (Error c l m md inner) = object $ diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs index 7da25d4449b..2450bfd7b47 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs @@ -23,7 +23,6 @@ module Network.Wai.Utilities.Request where import Control.Error -import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as Lazy @@ -32,10 +31,7 @@ import Data.Text.Lazy qualified as Text import Imports import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate import Network.Wai.Predicate.Request -import Network.Wai.Utilities.Error qualified as Wai -import Network.Wai.Utilities.ZAuth ((.&>)) import Pipes import Pipes.Prelude qualified as P @@ -54,21 +50,6 @@ parseBody :: ExceptT LText m a parseBody r = readBody r >>= hoistEither . fmapL Text.pack . eitherDecode' -parseBody' :: (FromJSON a, MonadIO m, MonadThrow m) => JsonRequest a -> m a -parseBody' r = either thrw pure =<< runExceptT (parseBody r) - where - thrw msg = throwM $ Wai.mkError status400 "bad-request" msg - -parseOptionalBody :: - (MonadIO m, FromJSON a) => - OptionalJsonRequest a -> - ExceptT LText m (Maybe a) -parseOptionalBody r = - hoistEither . fmapL Text.pack . traverse eitherDecode' . nonEmptyBody =<< readBody r - where - nonEmptyBody "" = Nothing - nonEmptyBody ne = Just ne - lookupRequestId :: HeaderName -> Request -> Maybe ByteString lookupRequestId reqIdHeaderName = lookup reqIdHeaderName . requestHeaders @@ -82,24 +63,8 @@ getRequestId reqIdHeaderName req = newtype JsonRequest body = JsonRequest {fromJsonRequest :: Request} -jsonRequest :: - forall body r. - (HasRequest r, HasHeaders r) => - Predicate r Error (JsonRequest body) -jsonRequest = - contentType "application" "json" - .&> (pure . JsonRequest . getRequest) - newtype OptionalJsonRequest body = OptionalJsonRequest {fromOptionalJsonRequest :: Request} -optionalJsonRequest :: - forall body r. - (HasRequest r, HasHeaders r) => - Predicate r Error (OptionalJsonRequest body) -optionalJsonRequest = - opt (contentType "application" "json") - .&> (pure . OptionalJsonRequest . getRequest) - ---------------------------------------------------------------------------- -- Instances diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs index ce838ff5463..bb27d08fdee 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs @@ -30,9 +30,6 @@ import Network.Wai.Utilities.Error empty :: Response empty = plain "" -noContent :: Response -noContent = empty & setStatus status204 - plain :: Lazy.ByteString -> Response plain = responseLBS status200 [plainContent] @@ -45,11 +42,8 @@ json = responseLBS status200 [jsonContent] . encode jsonContent :: Header jsonContent = (hContentType, "application/json") -errorRs :: Status -> LText -> LText -> Response -errorRs s l m = errorRs' (mkError s l m) - -errorRs' :: Error -> Response -errorRs' e = setStatus (code e) (json e) +errorRs :: Error -> Response +errorRs e = setStatus (code e) (json e) addHeader :: HeaderName -> ByteString -> Response -> Response addHeader k v (ResponseFile s h f ff) = ResponseFile s ((k, v) : h) f ff diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 9186ed78333..dd3306f4a65 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -42,7 +42,6 @@ module Network.Wai.Utilities.Server logError, logError', logErrorMsg, - restrict, flushRequestBody, -- * Constants @@ -185,7 +184,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes) messageStr Nothing = mempty route :: (MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived -route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k) +route rt rq k = Route.routeWith (Route.Config $ errorRs noEndpoint) rt rq (liftIO . k) where noEndpoint = Wai.mkError status404 "no-endpoint" "The requested endpoint does not exist" {-# INLINEABLE route #-} @@ -469,22 +468,6 @@ runHandlers :: SomeException -> [Handler IO a] -> IO a runHandlers e [] = throwIO e runHandlers e (Handler h : hs) = maybe (runHandlers e hs) h (fromException e) -restrict :: Int -> Int -> Predicate r P.Error Int -> Predicate r P.Error Int -restrict l u = fmap $ \x -> - x >>= \v -> - if v >= l && v <= u - then x - else Fail (setMessage (emsg v) . setReason TypeError $ e400) - where - emsg v = - LBS.toStrict . toLazyByteString $ - byteString "outside range [" - <> intDec l - <> byteString ", " - <> intDec u - <> byteString "]: " - <> intDec v - flushRequestBody :: Request -> IO () flushRequestBody req = do bs <- getRequestBodyChunk req diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs b/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs index 5733203a0bd..a96a16f2032 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs @@ -19,25 +19,14 @@ module Network.Wai.Utilities.ZAuth ( ZAuthType (..), - zauthType, - zauth, - zauthUserId, - zauthConnId, - zauthBotId, - zauthConvId, - zauthProviderId, (<&.), (.&>), ) where import Data.ByteString.Conversion -import Data.Id import Imports -import Network.HTTP.Types.Header -import Network.HTTP.Types.Status import Network.Wai.Predicate -import Network.Wai.Predicate.Request -- ZAuth headers -------------------------------------------------------------- @@ -65,40 +54,6 @@ instance FromByteString ZAuthType where "provider" -> pure ZAuthProvider _ -> fail $ "Invalid ZAuth type: " ++ show t --- | A token type is present if the request was authenticated. -zauthType :: (HasHeaders r) => Predicate r Error ZAuthType -zauthType = zheader "Z-Type" - --- | Require a specific token type to be used. -zauth :: (HasHeaders r) => ZAuthType -> Predicate r Error () -zauth t = do - r <- zauthType - pure $ case r of - Okay _ z | z == t -> Okay 0 () - _ -> Fail accessDenied - --- | A zauth user ID is present if 'zauthType' is either 'ZAuthAccess' --- or 'ZAuthUser'. -zauthUserId :: (HasHeaders r) => Predicate r Error UserId -zauthUserId = zheader "Z-User" - --- | A zauth connection ID is present if 'zauthType' is 'ZAuthAccess'. -zauthConnId :: (HasHeaders r) => Predicate r Error ConnId -zauthConnId = zheader "Z-Connection" - --- | A zauth bot ID is present if 'zauthType' is 'ZAuthBot'. -zauthBotId :: (HasHeaders r) => Predicate r Error BotId -zauthBotId = zheader "Z-Bot" - --- | A zauth conversation ID is present if 'zauthType' is 'ZAuthBot'. -zauthConvId :: (HasHeaders r) => Predicate r Error ConvId -zauthConvId = zheader "Z-Conversation" - --- | A provider ID is present if 'zauthType' is either 'ZAuthBot' --- or 'ZAuthProvider'. -zauthProviderId :: (HasHeaders r) => Predicate r Error ProviderId -zauthProviderId = zheader "Z-Provider" - -- Extra Predicate Combinators ------------------------------------------------ -- Variations of '.&.' that keep only the result of the left or right @@ -114,14 +69,3 @@ infixr 3 .&> (.&>) :: Predicate a f t -> Predicate a f t' -> Predicate a f t' (.&>) a b = fmap (fmap tl) (a .&. b) - --- Internal ------------------------------------------------------------------- - --- | Missing or invalid zauth-related headers due to a misconfiguration --- between the zauth ACL and / or API handlers should yield an opaque 403 --- error, in order not to leak such details to clients on public API endpoints. -zheader :: (HasHeaders r, FromByteString a) => HeaderName -> Predicate r Error a -zheader = fmap (result (Fail . const accessDenied) Okay) . header - -accessDenied :: Error -accessDenied = setMessage "Access denied" (err status403) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index bf33723b172..1c45da47edf 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -29,7 +29,6 @@ module Wire.API.Federation.API fedQueueClient, sendBundle, fedClientIn, - unsafeFedClientIn, module Wire.API.MakesFederatedCall, -- * Re-exports @@ -165,11 +164,3 @@ fedQueueClient :: Payload tag -> FedQueueClient c () fedQueueClient payload = sendBundle =<< makeBundle @tag payload - --- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Intended --- to be used in test situations only. -unsafeFedClientIn :: - forall (comp :: Component) (name :: Symbol) m api. - (HasUnsafeFedEndpoint comp api name, HasClient m api) => - Client m api -unsafeFedClientIn = clientIn (Proxy @api) (Proxy @m) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 2e3f4b8d488..7cde4f2b733 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -160,9 +160,6 @@ routingKey t = "backend-notifications." <> t -- they are stored in Rabbit. type DefederationDomain = Domain -defederationQueue :: Text -defederationQueue = "delete-federation" - -- | If you ever change this function and modify -- queue parameters, know that it will start failing in the -- next release! So be prepared to write migrations. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs index aef5cc95980..dcf029f1d8a 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs @@ -25,12 +25,6 @@ import Data.Proxy import Imports import Wire.API.MakesFederatedCall (Component (..)) -parseComponent :: Text -> Maybe Component -parseComponent "brig" = Just Brig -parseComponent "galley" = Just Galley -parseComponent "cargohold" = Just Cargohold -parseComponent _ = Nothing - componentName :: Component -> Text componentName Brig = "brig" componentName Galley = "galley" diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index c6f14413058..d10d00e6c4b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -32,17 +32,14 @@ module Wire.API.Federation.Version -- * VersionRange VersionUpperBound (..), VersionRange (..), - fromVersion, - toVersionExcl, allVersions, latestCommonVersion, rangeFromVersion, rangeUntilVersion, - enumVersionRange, ) where -import Control.Lens (makeLenses, (?~)) +import Control.Lens ((?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.OpenApi qualified as S import Data.Schema @@ -131,8 +128,6 @@ deriving instance Show VersionRange deriving instance Ord VersionRange -makeLenses ''VersionRange - instance ToSchema VersionRange where schema = object "VersionRange" $ @@ -165,12 +160,6 @@ rangeFromVersion v = VersionRange v Unbounded rangeUntilVersion :: Version -> VersionRange rangeUntilVersion v = VersionRange minBound (VersionUpperBound v) -enumVersionRange :: VersionRange -> Set Version -enumVersionRange = - Set.fromList . \case - VersionRange l Unbounded -> [l ..] - VersionRange l (VersionUpperBound u) -> init [l .. u] - -- | For a version range of a local backend and for a set of versions that a -- remote backend supports, compute the newest version supported by both. The -- remote versions are given as integers as the range of versions supported by diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index 27fba120068..17842d6df14 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -17,11 +17,7 @@ module Test.Wire.API.Federation.Golden.MLSMessageSendingStatus where -import Data.Domain -import Data.Id import Data.Json.Util -import Data.Qualified -import Data.UUID qualified as UUID import Imports import Wire.API.MLS.Message @@ -45,16 +41,3 @@ testObject_MLSMessageSendingStatus3 = { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC") } - -failed1 :: [Qualified UserId] -failed1 = - let domain = Domain "offline.example.com" - in [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] - -failed2 :: [Qualified UserId] -failed2 = - let domain = Domain "golden.example.com" - in flip Qualified domain . Id . fromJust . UUID.fromString - <$> [ "00000000-0000-0000-0000-000200000008", - "00000000-0000-0000-0000-000100000007" - ] diff --git a/libs/wire-api/src/Wire/API/Call/Config.hs b/libs/wire-api/src/Wire/API/Call/Config.hs index b48d771e20d..889b8ffd1bf 100644 --- a/libs/wire-api/src/Wire/API/Call/Config.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -46,16 +46,10 @@ module Wire.API.Call.Config turiTransport, Transport (..), TurnHost (..), - isHostName, -- * SFTUsername SFTUsername, mkSFTUsername, - suExpiresAt, - suVersion, - suKeyindex, - suShared, - suRandom, -- * TurnUsername TurnUsername, @@ -409,10 +403,6 @@ instance Arbitrary TurnHost where "xn--mgbh0fb.xn--kgbechtv" ] -isHostName :: TurnHost -> Bool -isHostName (TurnHostIp _) = False -isHostName (TurnHostName _) = True - parseTurnHost :: Text -> Maybe TurnHost parseTurnHost h = case BC.fromByteString host of Just ip@(IpAddr _) -> Just $ TurnHostIp ip @@ -645,7 +635,6 @@ isTls uri = makeLenses ''RTCConfiguration makeLenses ''RTCIceServer makeLenses ''TurnURI -makeLenses ''SFTUsername makeLenses ''TurnUsername makeLenses ''SFTServer makeLenses ''AuthSFTServer diff --git a/libs/wire-api/src/Wire/API/ConverProtoLens.hs b/libs/wire-api/src/Wire/API/ConverProtoLens.hs deleted file mode 100644 index 6e4398c47f7..00000000000 --- a/libs/wire-api/src/Wire/API/ConverProtoLens.hs +++ /dev/null @@ -1,33 +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 Wire.API.ConverProtoLens where - -import Data.Bifunctor (Bifunctor (first)) -import Imports - --- | This typeclass exists to provide overloaded function names for convertion --- between data types generated by proto-lens and data types used in wire --- We added fundeps here for better type inference, but we can't be as explicit as we wanted --- with @a -> b, b -> a@, since our instances would be orphaned on the left hand side argument. -class ConvertProtoLens a b | b -> a where - fromProtolens :: a -> Either Text b - toProtolens :: b -> a - --- | Add labels to error messages -protoLabel :: Text -> Either Text a -> Either Text a -protoLabel lbl = first ((lbl <> ": ") <>) diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 0aa78bd25c6..e4184cb1d2d 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -68,7 +68,6 @@ module Wire.API.Conversation -- * invite Invite (..), InviteQualified (..), - newInvite, -- * update ConversationRename (..), @@ -805,9 +804,6 @@ instance ToSchema InviteQualified where <*> invQRoleName .= (fromMaybe roleNameWireAdmin <$> optField "conversation_role" schema) -newInvite :: List1 UserId -> Invite -newInvite us = Invite us roleNameWireAdmin - -------------------------------------------------------------------------------- -- update diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index 1443e158af8..7d3636f3f40 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -26,7 +26,6 @@ module Wire.API.Conversation.Member defMember, MutedStatus (..), OtherMember (..), - defOtherMember, -- * Member Update MemberUpdate (..), @@ -150,14 +149,6 @@ data OtherMember = OtherMember deriving (Arbitrary) via (GenericUniform OtherMember) deriving (FromJSON, ToJSON, S.ToSchema) via Schema OtherMember -defOtherMember :: Qualified UserId -> OtherMember -defOtherMember uid = - OtherMember - { omQualifiedId = uid, - omService = Nothing, - omConvRoleName = roleNameWireMember - } - instance ToSchema OtherMember where schema = object "OtherMember" $ diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index c0060347b7b..9e213a26fdd 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -28,7 +28,6 @@ module Wire.API.Conversation.Protocol _ProtocolMLS, _ProtocolMixed, _ProtocolProteus, - conversationMLSData, protocolSchema, ConversationMLSData (..), ActiveMLSConversationData (..), @@ -40,7 +39,7 @@ where import Control.Applicative import Control.Arrow -import Control.Lens (Traversal', makePrisms, (?~)) +import Control.Lens (makePrisms, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Json.Util import Data.OpenApi qualified as S @@ -201,11 +200,6 @@ data Protocol $(makePrisms ''Protocol) -conversationMLSData :: Traversal' Protocol ConversationMLSData -conversationMLSData _ ProtocolProteus = pure ProtocolProteus -conversationMLSData f (ProtocolMLS mls) = ProtocolMLS <$> f mls -conversationMLSData f (ProtocolMixed mls) = ProtocolMixed <$> f mls - protocolTag :: Protocol -> ProtocolTag protocolTag ProtocolProteus = ProtocolProteusTag protocolTag (ProtocolMLS _) = ProtocolMLSTag diff --git a/libs/wire-api/src/Wire/API/Conversation/Role.hs b/libs/wire-api/src/Wire/API/Conversation/Role.hs index edb97c23f42..c22cccf72c1 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Role.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Role.hs @@ -33,7 +33,6 @@ module Wire.API.Conversation.Role RoleName, fromRoleName, parseRoleName, - wireConvRoleNames, roleNameWireAdmin, roleNameWireMember, @@ -246,9 +245,6 @@ instance Arbitrary RoleName where where genChar = QC.elements $ ['a' .. 'z'] <> ['0' .. '9'] <> ['_'] -wireConvRoleNames :: [RoleName] -wireConvRoleNames = [roleNameWireAdmin, roleNameWireMember] - roleNameWireAdmin :: RoleName roleNameWireAdmin = RoleName "wire_admin" diff --git a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs index a286a02d0a1..5f93d01f8c3 100644 --- a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs +++ b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs @@ -30,9 +30,7 @@ module Wire.API.MLS.CipherSuite IsSignatureScheme, SignatureSchemeTag (..), SignatureSchemeCurve, - signatureScheme, signatureSchemeName, - signatureSchemeTag, csSignatureScheme, -- * Key pairs @@ -282,9 +280,6 @@ newtype SignatureScheme = SignatureScheme {unSignatureScheme :: Word16} deriving stock (Eq, Show) deriving newtype (ParseMLS, Arbitrary) -signatureScheme :: SignatureSchemeTag -> SignatureScheme -signatureScheme = SignatureScheme . signatureSchemeNumber - data SignatureSchemeTag = Ed25519 | Ecdsa_secp256r1_sha256 @@ -330,23 +325,12 @@ instance Cql SignatureSchemeTag where signatureSchemeFromName name fromCql _ = Left "SignatureScheme: Text expected" -signatureSchemeNumber :: SignatureSchemeTag -> Word16 -signatureSchemeNumber Ed25519 = 0x807 -signatureSchemeNumber Ecdsa_secp256r1_sha256 = 0x403 -signatureSchemeNumber Ecdsa_secp384r1_sha384 = 0x503 -signatureSchemeNumber Ecdsa_secp521r1_sha512 = 0x603 - signatureSchemeName :: SignatureSchemeTag -> Text signatureSchemeName Ed25519 = "ed25519" signatureSchemeName Ecdsa_secp256r1_sha256 = "ecdsa_secp256r1_sha256" signatureSchemeName Ecdsa_secp384r1_sha384 = "ecdsa_secp384r1_sha384" signatureSchemeName Ecdsa_secp521r1_sha512 = "ecdsa_secp521r1_sha512" -signatureSchemeTag :: SignatureScheme -> Maybe SignatureSchemeTag -signatureSchemeTag (SignatureScheme n) = getAlt $ - flip foldMap [minBound .. maxBound] $ \s -> - guard (signatureSchemeNumber s == n) $> s - signatureSchemeFromName :: Text -> Maybe SignatureSchemeTag signatureSchemeFromName name = getAlt $ flip foldMap [minBound .. maxBound] $ \s -> diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 342bb739e23..cb1003ab8fe 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -30,9 +30,6 @@ module Wire.API.MLS.Message FramedContentAuthData (..), Sender (..), - -- * Utilities - verifyMessageSignature, - -- * Servant types MLSMessageSendingStatus (..), ) @@ -48,7 +45,6 @@ import GHC.Records import Imports import Test.QuickCheck hiding (label) import Wire.API.Event.Conversation -import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Epoch import Wire.API.MLS.Group @@ -238,11 +234,6 @@ instance SerialiseMLS Sender where serialiseMLS SenderNewMemberCommit = serialiseMLS SenderNewMemberCommitTag -needsGroupContext :: Sender -> Bool -needsGroupContext (SenderMember _) = True -needsGroupContext (SenderExternal _) = True -needsGroupContext _ = False - -- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6-4 data FramedContent = FramedContent { groupId :: GroupId, @@ -329,15 +320,6 @@ instance SerialiseMLS FramedContentTBS where serialiseMLS tbs.content traverse_ serialiseMLS tbs.groupContext -framedContentTBS :: RawMLS GroupContext -> RawMLS FramedContent -> FramedContentTBS -framedContentTBS ctx msgContent = - FramedContentTBS - { protocolVersion = defaultProtocolVersion, - wireFormat = WireFormatPublicTag, - content = msgContent, - groupContext = guard (needsGroupContext msgContent.value.sender) $> ctx - } - -- | https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-6.1-2 data FramedContentAuthData = FramedContentAuthData { signature_ :: ByteString, @@ -359,18 +341,6 @@ instance SerialiseMLS FramedContentAuthData where serialiseMLSBytes @VarInt ad.signature_ traverse_ (serialiseMLSBytes @VarInt) ad.confirmationTag -verifyMessageSignature :: - RawMLS GroupContext -> - RawMLS FramedContent -> - RawMLS FramedContentAuthData -> - ByteString -> - Bool -verifyMessageSignature ctx msgContent authData pubkey = isJust $ do - let tbs = mkRawMLS (framedContentTBS ctx msgContent) - sig = authData.value.signature_ - cs <- cipherSuiteTag ctx.value.cipherSuite - guard $ csVerifySignature cs pubkey tbs sig - -------------------------------------------------------------------------------- -- Servant diff --git a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs index 618d26201bf..ca6783cd192 100644 --- a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs +++ b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs @@ -23,7 +23,6 @@ module Wire.API.MLS.Serialisation SerialiseMLS (..), VarInt (..), parseMLSStream, - serialiseMLSStream, parseMLSVector, serialiseMLSVector, parseMLSBytes, @@ -129,9 +128,6 @@ parseMLSStream p = do then pure [] else (:) <$> p <*> parseMLSStream p -serialiseMLSStream :: (a -> Put) -> [a] -> Put -serialiseMLSStream = traverse_ - parseMLSVector :: forall w a. (Binary w, Integral w) => Get a -> Get [a] parseMLSVector getItem = do len <- get @w diff --git a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs index 2a59e5648fb..a076e39ea85 100644 --- a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs +++ b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs @@ -22,7 +22,6 @@ module Wire.API.MakesFederatedCall MakesFederatedCall, Component (..), callsFed, - unsafeCallsFed, AddAnnotation, Location (..), ShowComponent, @@ -218,14 +217,6 @@ instance (c ~ ((k, d) :: Constraint), SolveCallsFed d r a) => SolveCallsFed c r instance {-# OVERLAPPABLE #-} (c ~ (() :: Constraint), r ~ a) => SolveCallsFed c r a where callsFed f = f --- | Unsafely discharge a 'CallsFed' constraint. Necessary for interacting with --- wai-routes. --- --- This is unsafe in the sense that it will drop the 'CallsFed' constraint, and --- thus might mean a federated call gets forgotten in the documentation. -unsafeCallsFed :: forall (comp :: Component) (name :: Symbol) r. ((CallsFed comp name) => r) -> r -unsafeCallsFed f = withDict (synthesizeCallsFed @comp @name) f - data FedCallFrom' f = FedCallFrom { name :: f String, method :: f String, diff --git a/libs/wire-api/src/Wire/API/Message/Proto.hs b/libs/wire-api/src/Wire/API/Message/Proto.hs index d20ecd75ab6..21e698b0abd 100644 --- a/libs/wire-api/src/Wire/API/Message/Proto.hs +++ b/libs/wire-api/src/Wire/API/Message/Proto.hs @@ -24,7 +24,6 @@ module Wire.API.Message.Proto userId, fromUserId, ClientId, - clientId, newClientId, fromClientId, toClientId, @@ -86,9 +85,6 @@ instance Decode ClientId newClientId :: Word64 -> ClientId newClientId c = ClientId {_client = putField c} -clientId :: (Functor f) => (Word64 -> f Word64) -> ClientId -> f ClientId -clientId f c = (\x -> c {_client = x}) <$> field f (_client c) - toClientId :: ClientId -> Id.ClientId toClientId c = Id.ClientId $ getField (_client c) diff --git a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs index ec44311dece..4b0d8e1c848 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs @@ -31,8 +31,6 @@ module Wire.API.Provider.Service.Tag -- * ServiceTag Matchers MatchAny (..), MatchAll (..), - (.||.), - (.&&.), matchAll, match1, match, @@ -305,12 +303,6 @@ newtype MatchAll = MatchAll {matchAllSet :: Set ServiceTag} deriving stock (Eq, Show, Ord) -(.||.) :: MatchAny -> MatchAny -> MatchAny -(.||.) (MatchAny a) (MatchAny b) = MatchAny (Set.union a b) - -(.&&.) :: MatchAll -> MatchAll -> MatchAll -(.&&.) (MatchAll a) (MatchAll b) = MatchAll (Set.union a b) - matchAll :: MatchAll -> MatchAny matchAll = MatchAny . Set.singleton diff --git a/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs b/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs index 74257a99e66..6b5463bfdb9 100644 --- a/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs +++ b/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs @@ -48,8 +48,6 @@ makePrisms ''FederationRestriction data FederationRestrictionTag = FederationRestrictionAllowAllTag | FederationRestrictionByTeamTag deriving (Eq, Enum, Bounded) -makePrisms ''FederationRestrictionTag - deriving via Schema FederationRestriction instance (S.ToSchema FederationRestriction) deriving via Schema FederationRestriction instance (FromJSON FederationRestriction) diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 0ee626b9d98..bb972553319 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -544,9 +544,6 @@ instance (ResponseType r ~ a) => AsUnion '[r] a where toUnion = Z . I fromUnion = unI . unZ -_foo :: Union '[Int] -_foo = toUnion @'[Respond 200 "test" Int] @Int 3 - class InjectAfter as bs where injectAfter :: Union bs -> Union (as .++ bs) diff --git a/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs b/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs index cd797101f11..0b48d00ad53 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs @@ -44,12 +44,12 @@ versionMiddleware disabledAPIVersions app req k = case parseVersion (removeVersi where err :: Text -> IO ResponseReceived err v = - k . errorRs' . mkError HTTP.status404 "unsupported-version" $ + k . errorRs . mkError HTTP.status404 "unsupported-version" $ "Version " <> fromStrict v <> " is not supported" errint :: IO ResponseReceived errint = - k . errorRs' . mkError HTTP.status404 "unsupported-version" $ + k . errorRs . mkError HTTP.status404 "unsupported-version" $ "Internal APIs (`/i/...`) are not under version control" data ParseVersionError = NoVersion | BadVersion Text | InternalApisAreUnversioned diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 8465f2f1e6f..91ab3f61fd4 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -99,7 +99,6 @@ module Wire.API.User DeleteUser (..), mkDeleteUser, VerifyDeleteUser (..), - mkVerifyDeleteUser, DeletionCodeTimeout (..), DeleteUserResponse (..), DeleteUserResult (..), @@ -1650,9 +1649,6 @@ data VerifyDeleteUser = VerifyDeleteUser deriving (Arbitrary) via (GenericUniform VerifyDeleteUser) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema VerifyDeleteUser) -mkVerifyDeleteUser :: Code.Key -> Code.Value -> VerifyDeleteUser -mkVerifyDeleteUser = VerifyDeleteUser - instance ToSchema VerifyDeleteUser where schema = objectWithDocModifier "VerifyDeleteUser" (description ?~ "Data for verifying an account deletion.") $ diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 5c37e1dbca2..172e2cf043b 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -75,7 +75,6 @@ library Wire.API.Bot.Service Wire.API.Call.Config Wire.API.Connection - Wire.API.ConverProtoLens Wire.API.Conversation Wire.API.Conversation.Action Wire.API.Conversation.Action.Tag diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 8d31d806a9b..1c0e673fa88 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -6,7 +6,6 @@ module Wire.MiniBackend interpretFederationStack, runFederationStack, interpretNoFederationStack, - runNoFederationStackState, interpretNoFederationStackState, runNoFederationStack, runAllErrorsUnsafe, @@ -303,16 +302,6 @@ runNoFederationStack localBackend teamMember cfg = -- want to do errors?) runAllErrorsUnsafe . interpretNoFederationStack localBackend teamMember def cfg -runNoFederationStackState :: - (HasCallStack) => - MiniBackend -> - Maybe TeamMember -> - UserSubsystemConfig -> - Sem (MiniBackendEffects `Append` AllErrors) a -> - (MiniBackend, a) -runNoFederationStackState localBackend teamMember cfg = - runAllErrorsUnsafe . interpretNoFederationStackState localBackend teamMember def cfg - interpretNoFederationStack :: (Members AllErrors r) => MiniBackend -> diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index bba2cd54e2a..98618e5dbd0 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -19,14 +19,12 @@ module Brig.API.Error where import Brig.API.Types import Control.Monad.Error.Class -import Data.Aeson import Data.ByteString.Conversion import Data.Domain (Domain) import Data.Jwt.Tools (DPoPTokenGenerationError (..)) import Data.Text.Lazy as LT import Data.ZAuth.Validation qualified as ZAuth import Imports -import Network.HTTP.Types.Header import Network.HTTP.Types.Status import Network.Wai.Utilities.Error qualified as Wai import Wire.API.Error @@ -38,9 +36,6 @@ import Wire.Error throwStd :: (MonadError HttpError m) => Wai.Error -> m a throwStd = throwError . StdError -throwRich :: (MonadError HttpError m, ToJSON x) => Wai.Error -> x -> [Header] -> m a -throwRich e x h = throwError (RichError e x h) - -- Error Mapping ---------------------------------------------------------- connError :: ConnectionError -> HttpError @@ -87,12 +82,6 @@ changeEmailError (EmailExists _) = StdError (errorToWai @'E.UserKeyExists) changeEmailError (ChangeBlacklistedEmail _) = StdError blacklistedEmail changeEmailError EmailManagedByScim = StdError $ propertyManagedByScim "email" -changeHandleError :: ChangeHandleError -> HttpError -changeHandleError ChangeHandleNoIdentity = StdError (errorToWai @'E.NoIdentity) -changeHandleError ChangeHandleExists = StdError (errorToWai @'E.HandleExists) -changeHandleError ChangeHandleInvalid = StdError (errorToWai @'E.InvalidHandle) -changeHandleError ChangeHandleManagedByScim = StdError (errorToWai @'E.HandleManagedByScim) - legalHoldLoginError :: LegalHoldLoginError -> HttpError legalHoldLoginError LegalHoldLoginNoBindingTeam = StdError noBindingTeam legalHoldLoginError LegalHoldLoginLegalHoldNotEnabled = StdError legalHoldNotEnabled @@ -234,10 +223,6 @@ accountStatusError :: AccountStatusError -> HttpError accountStatusError InvalidAccountStatus = StdError invalidAccountStatus accountStatusError AccountNotFound = StdError (notFound "Account not found") -updateProfileError :: UpdateProfileError -> HttpError -updateProfileError DisplayNameManagedByScim = StdError (propertyManagedByScim "name") -updateProfileError ProfileNotFound = StdError (errorToWai @'E.UserNotFound) - verificationCodeThrottledError :: VerificationCodeThrottledError -> HttpError verificationCodeThrottledError (VerificationCodeThrottled t) = RichError @@ -253,15 +238,9 @@ clientCapabilitiesCannotBeRemoved = Wai.mkError status409 "client-capabilities-c emailExists :: Wai.Error emailExists = Wai.mkError status409 "email-exists" "The given e-mail address is in use." -phoneExists :: Wai.Error -phoneExists = Wai.mkError status409 "phone-exists" "The given phone number is in use." - badRequest :: LText -> Wai.Error badRequest = Wai.mkError status400 "bad-request" -loginCodePending :: Wai.Error -loginCodePending = Wai.mkError status403 "pending-login" "A login code is still pending." - loginCodeNotFound :: Wai.Error loginCodeNotFound = Wai.mkError status404 "no-pending-login" "No login code was found." @@ -274,12 +253,6 @@ invalidAccountStatus = Wai.mkError status400 "invalid-status" "The specified acc activationKeyNotFound :: Wai.Error activationKeyNotFound = notFound "Activation key not found." -invalidActivationCode :: LText -> Wai.Error -invalidActivationCode = Wai.mkError status404 "invalid-code" - -activationCodeNotFound :: Wai.Error -activationCodeNotFound = invalidActivationCode "Activation key/code not found or invalid." - deletionCodePending :: Wai.Error deletionCodePending = Wai.mkError status403 "pending-delete" "A verification code for account deletion is still pending." @@ -294,38 +267,15 @@ blacklistedEmail = "The given e-mail address has been blacklisted due to a permanent bounce \ \or a complaint." -passwordExists :: Wai.Error -passwordExists = - Wai.mkError - status403 - "password-exists" - "The operation is not permitted because the user has a password set." - -phoneBudgetExhausted :: Wai.Error -phoneBudgetExhausted = - Wai.mkError - status403 - "phone-budget-exhausted" - "The SMS or voice call budget for the given phone number has been \ - \exhausted. Please try again later. Repeated exhaustion of the SMS or \ - \voice call budget is considered abuse of the API and may result in \ - \permanent blacklisting of the phone number." - authMissingCookie :: Wai.Error authMissingCookie = Wai.mkError status403 "invalid-credentials" "Missing cookie" -authInvalidCookie :: Wai.Error -authInvalidCookie = Wai.mkError status403 "invalid-credentials" "Invalid cookie" - authMissingToken :: Wai.Error authMissingToken = Wai.mkError status403 "invalid-credentials" "Missing token" authMissingCookieAndToken :: Wai.Error authMissingCookieAndToken = Wai.mkError status403 "invalid-credentials" "Missing cookie and token" -invalidAccessToken :: Wai.Error -invalidAccessToken = Wai.mkError status403 "invalid-credentials" "Invalid access token" - missingAccessToken :: Wai.Error missingAccessToken = Wai.mkError status403 "invalid-credentials" "Missing access token" diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 2971f28e4e9..dcd6eba66a1 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -21,7 +21,6 @@ module Brig.API.Handler toServantHandler, -- * Utilities - parseJsonBody, checkAllowlist, checkAllowlistWithError, isAllowlisted, @@ -41,16 +40,13 @@ import Control.Lens (view) import Control.Monad.Catch (catches, throwM) import Control.Monad.Catch qualified as Catch import Control.Monad.Except (MonadError, throwError) -import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.ZAuth.Validation qualified as ZV import Imports import Network.HTTP.Types (Status (statusCode, statusMessage)) -import Network.Wai.Utilities.Error ((!>>)) import Network.Wai.Utilities.Error qualified as WaiError -import Network.Wai.Utilities.Request (JsonRequest, parseBody) import Network.Wai.Utilities.Server qualified as Server import Servant qualified import System.Logger qualified as Log @@ -122,12 +118,6 @@ brigErrorHandlers logger reqId = ------------------------------------------------------------------------------- -- Utilities --- This could go to libs/wai-utilities. There is a `parseJson'` in --- "Network.Wai.Utilities.Request", but adding `parseJsonBody` there would require to move --- more code out of brig. -parseJsonBody :: (FromJSON a, MonadIO m) => JsonRequest a -> ExceptT HttpError m a -parseJsonBody req = parseBody req !>> StdError . badRequest - -- | If an Allowlist is configured, consult it, otherwise a no-op. {#RefActivationAllowlist} checkAllowlist :: Email -> Handler r () checkAllowlist = wrapHttpClientE . checkAllowlistWithError (StdError allowlistError) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 3fa288a39fb..45b1d03fb37 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -29,7 +29,6 @@ module Brig.API.User CheckHandleResp (..), checkHandle, lookupHandle, - changeManagedBy, changeAccountStatus, changeSingleAccountStatus, Data.lookupAccounts, @@ -537,25 +536,6 @@ checkRestrictedUserCreation new = do ) $ throwE RegisterErrorUserCreationRestricted -------------------------------------------------------------------------------- --- Update ManagedBy - -changeManagedBy :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - ManagedByUpdate -> - (AppT r) () -changeManagedBy uid conn (ManagedByUpdate mb) = do - wrapClient $ Data.updateManagedBy uid mb - liftSem $ Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) - ------------------------------------------------------------------------------- -- Change Email diff --git a/services/brig/test/integration/API/Search/Util.hs b/services/brig/test/integration/API/Search/Util.hs index 9f8c83b34e0..3dc5598a871 100644 --- a/services/brig/test/integration/API/Search/Util.hs +++ b/services/brig/test/integration/API/Search/Util.hs @@ -102,13 +102,6 @@ assertCan'tFind brig self expected q = do assertBool ("User shouldn't be present in results for query: " <> show q) $ expected `notElem` map contactQualifiedId r -assertCan'tFindWithDomain :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> Qualified UserId -> Text -> Domain -> m () -assertCan'tFindWithDomain brig self expected q domain = do - r <- searchResults <$> executeSearchWithDomain brig self q domain - liftIO $ do - assertBool ("User shouldn't be present in results for query: " <> show q) $ - expected `notElem` map contactQualifiedId r - executeTeamUserSearch :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 61ab960962f..6f78f951fe8 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -110,22 +110,6 @@ createPopulatedBindingTeamWithNames brig names = do pure invitee pure (tid, inviter, invitees) -createTeam :: UserId -> Galley -> Http TeamId -createTeam u galley = do - tid <- randomId - r <- - put - ( galley - . paths ["i", "teams", toByteString' tid] - . contentJson - . zAuthAccess u "conn" - . expect2xx - . lbytes (encode newTeam) - ) - maybe (error "invalid team id") pure $ - fromByteString $ - getHeader' "Location" r - -- | Create user and binding team. -- -- NB: the created user is the team owner. diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index d862c73ddd1..5e6c4856d96 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -24,7 +24,6 @@ module API.User.Util where import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Options (Opts) -import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.ZAuth (Token) import Cassandra qualified as DB import Codec.MIME.Type qualified as MIME @@ -50,7 +49,6 @@ import Data.Text.Ascii qualified as Ascii import Data.Vector qualified as Vec import Data.ZAuth.Token qualified as ZAuth import Federation.Util (withTempMockFederator) -import Federator.MockServer (FederatedRequest (..)) import GHC.TypeLits (KnownSymbol) import Imports import Test.Tasty.Cannon qualified as WS @@ -73,7 +71,6 @@ import Wire.API.User.Activation import Wire.API.User.Auth import Wire.API.User.Client import Wire.API.User.Client.DPoPAccessToken (Proof) -import Wire.API.User.Client.Prekey import Wire.API.User.Handle import Wire.API.User.Password import Wire.VerificationCode qualified as Code @@ -375,33 +372,6 @@ receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction ex res @?= F.NewConnectionResponseOk expectedReaction assertConnectionQualified brig uid1 quid2 expectedRel -sendConnectionAction :: - (HasCallStack) => - Brig -> - Opts -> - UserId -> - Qualified UserId -> - Maybe F.RemoteConnectionAction -> - Relation -> - Http () -sendConnectionAction brig opts uid1 quid2 reaction expectedRel = do - let mockConnectionResponse = F.NewConnectionResponseOk reaction - mockResponse = encode mockConnectionResponse - (res, reqs) <- - liftIO . withTempMockFederator opts mockResponse $ - postConnectionQualified brig uid1 quid2 - - liftIO $ do - req <- assertOne reqs - frTargetDomain req @?= qDomain quid2 - frComponent req @?= Brig - frRPC req @?= "send-connection-action" - eitherDecode (frBody req) - @?= Right (F.NewConnectionRequest uid1 Nothing (qUnqualified quid2) F.RemoteConnect) - - liftIO $ assertBool "postConnectionQualified failed" $ statusCode res `elem` [200, 201] - assertConnectionQualified brig uid1 quid2 expectedRel - sendConnectionUpdateAction :: (HasCallStack) => Brig -> @@ -462,25 +432,6 @@ downloadAsset c usr ast = . zConn "conn" ) -requestLegalHoldDevice :: Brig -> UserId -> UserId -> LastPrekey -> (MonadHttp m) => m ResponseLBS -requestLegalHoldDevice brig requesterId targetUserId lastPrekey' = - post $ - brig - . paths ["i", "clients", "legalhold", toByteString' targetUserId, "request"] - . contentJson - . body payload - where - payload = - RequestBodyLBS . encode $ - LegalHoldClientRequest requesterId lastPrekey' - -deleteLegalHoldDevice :: Brig -> UserId -> (MonadHttp m) => m ResponseLBS -deleteLegalHoldDevice brig uid = - delete $ - brig - . paths ["i", "clients", "legalhold", toByteString' uid] - . contentJson - matchDeleteUserNotification :: Qualified UserId -> Notification -> Assertion matchDeleteUserNotification quid n = do let j = Object $ List1.head (ntfPayload n) diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index e1b01f8fe36..6ce6f9ece74 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -58,7 +58,7 @@ import Data.List1 (List1) import Data.List1 qualified as List1 import Data.Misc import Data.Proxy -import Data.Qualified hiding (isLocal) +import Data.Qualified import Data.Range import Data.Sequence qualified as Seq import Data.String.Conversions @@ -104,7 +104,6 @@ import Test.Tasty.Pending (flakyTestCase) import Text.Printf (printf) import UnliftIO.Async qualified as Async import Util.Options -import Web.Internal.HttpApiData import Wire.API.Connection import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -112,7 +111,6 @@ import Wire.API.Federation.API import Wire.API.Federation.Domain import Wire.API.Federation.Version import Wire.API.Internal.Notification -import Wire.API.MLS.SubConversation import Wire.API.Routes.MultiTablePaging import Wire.API.Team.Member hiding (userId) import Wire.API.User hiding (AccountStatus (..)) @@ -265,8 +263,8 @@ localAndRemoteUserWithConvId brig shouldBeLocal = do let go = do other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") let convId = one2OneConvId BaseProtocolProteusTag quid other - isLocal = qDomain quid == qDomain convId - if shouldBeLocal == isLocal + isLocalUntagged = qDomain quid == qDomain convId + if shouldBeLocal == isLocalUntagged then pure (qUnqualified quid, other, convId) else go go @@ -353,12 +351,6 @@ getActivationCode brig ep = do let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) pure $ (,) <$> akey <*> acode -getPhoneLoginCode :: Brig -> Phone -> Http (Maybe LoginCode) -getPhoneLoginCode brig p = do - r <- get $ brig . path "/i/users/login-code" . queryItem "phone" (toByteString' p) - let lbs = fromMaybe "" $ responseBody r - pure (LoginCode <$> (lbs ^? key "code" . _String)) - assertUpdateNotification :: (HasCallStack) => WS.WebSocket -> UserId -> UserUpdate -> IO () assertUpdateNotification ws uid upd = WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) @@ -537,23 +529,6 @@ decodeToken' r = fromMaybe (error "invalid access_token") $ do data LoginCodeType = LoginCodeSMS | LoginCodeVoice deriving (Eq) -sendLoginCode :: Brig -> Phone -> LoginCodeType -> Bool -> Http ResponseLBS -sendLoginCode b p typ force = - post $ - b - . path "/login/send" - . contentJson - . body js - where - js = - RequestBodyLBS - . encode - $ object - [ "phone" .= fromPhone p, - "voice_call" .= (typ == LoginCodeVoice), - "force" .= force - ] - postConnection :: Brig -> UserId -> UserId -> (MonadHttp m) => m ResponseLBS postConnection brig from to = post $ @@ -642,23 +617,6 @@ createUserWithHandle brig = do -- when using this function. pure (handle, userWithHandle) -getUserInfoFromHandle :: - (MonadIO m, MonadCatch m, MonadHttp m, HasCallStack) => - Brig -> - Domain -> - Handle -> - m UserProfile -getUserInfoFromHandle brig domain handle = do - u <- randomId - responseJsonError - =<< get - ( apiVersion "v1" - . brig - . paths ["users", "by-handle", toByteString' (domainText domain), toByteString' handle] - . zUser u - . expect2xx - ) - addClient :: (MonadHttp m, HasCallStack) => Brig -> @@ -733,47 +691,6 @@ getConversationQualified galley usr cnv = . paths ["conversations", toByteString' (qDomain cnv), toByteString' (qUnqualified cnv)] . zAuthAccess usr "conn" -createMLSConversation :: (MonadHttp m) => Galley -> UserId -> ClientId -> m ResponseLBS -createMLSConversation galley zusr c = do - let conv = - NewConv - [] - mempty - (checked "gossip") - mempty - Nothing - Nothing - Nothing - Nothing - roleNameWireAdmin - BaseProtocolMLSTag - post $ - galley - . path "/conversations" - . zUser zusr - . zConn "conn" - . zClient c - . json conv - -createMLSSubConversation :: - (MonadIO m, MonadHttp m) => - Galley -> - UserId -> - Qualified ConvId -> - SubConvId -> - m ResponseLBS -createMLSSubConversation galley zusr qcnv sconv = - get $ - galley - . paths - [ "conversations", - toByteString' (qDomain qcnv), - toByteString' (qUnqualified qcnv), - "subconversations", - toHeader sconv - ] - . zUser zusr - createConversation :: (MonadHttp m) => Galley -> UserId -> [Qualified UserId] -> m ResponseLBS createConversation galley zusr usersToAdd = do let conv = @@ -966,10 +883,6 @@ somePrekeys = Prekey (PrekeyId 26) "pQABARgaAqEAWCBMSQoQ6B35plB80i1O3AWlJSftCEbCbju97Iykg5+NWQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2" ] --- | The client ID of the first of 'someLastPrekeys' -someClientId :: ClientId -someClientId = ClientId 0x1dbfbe22c8a35cb2 - someLastPrekeys :: [LastPrekey] someLastPrekeys = [ lastPrekey "pQABARn//wKhAFggnCcZIK1pbtlJf4wRQ44h4w7/sfSgj5oWXMQaUGYAJ/sDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", @@ -1118,9 +1031,6 @@ aFewTimes (\_ -> pure . not . good) (const action) -retryT :: (MonadIO m, MonadMask m) => m a -> m a -retryT = recoverAll (exponentialBackoff 8000 <> limitRetries 3) . const - assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 2a8a5b2ba93..39a6dce3593 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -280,7 +280,6 @@ executable cargohold-integration , imports , kan-extensions , lens >=3.8 - , mime >=0.4 , mmorph , mtl , optparse-applicative diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 32c9e73b371..2116b776445 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -152,7 +152,6 @@ mkDerivation { imports kan-extensions lens - mime mmorph mtl optparse-applicative diff --git a/services/cargohold/test/integration/API/Util.hs b/services/cargohold/test/integration/API/Util.hs index 2c51dc9b29f..a1feeb7739a 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/services/cargohold/test/integration/API/Util.hs @@ -17,13 +17,6 @@ module API.Util ( randomUser, - uploadSimple, - decodeHeaderOrFail, - getContentType, - applicationText, - applicationOctetStream, - deleteAssetV3, - deleteAsset, downloadAsset, withMockFederator, ) @@ -33,26 +26,20 @@ 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.Default import Data.Id import Data.Qualified -import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Text.Encoding (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 @@ -86,71 +73,9 @@ randomUser = 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 diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index 93f361e34c3..f5b69fe2fd5 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -31,10 +31,7 @@ module TestSetup viewCargohold, createTestSetup, runFederationClient, - withFederationClient, - withFederationError, apiVersion, - unversioned, ) where @@ -45,7 +42,6 @@ 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 @@ -55,7 +51,6 @@ 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 @@ -103,16 +98,8 @@ removeVersionPrefix bs = do (_, 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) - } +viewUnversionedCargohold :: TestM Cargohold +viewUnversionedCargohold = mkRequest <$> view tsEndpoint viewCargohold :: TestM Cargohold viewCargohold = @@ -123,9 +110,6 @@ viewCargohold = 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) @@ -188,29 +172,3 @@ runFederationClient action = do 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/galley/default.nix b/services/galley/default.nix index b414e5b0551..362e174d34a 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -230,7 +230,6 @@ mkDerivation { bytestring bytestring-conversion call-stack - case-insensitive cassandra-util cassava cereal @@ -272,7 +271,6 @@ mkDerivation { random retry saml2-web-sso - schema-profunctor servant-client servant-client-core servant-server @@ -300,7 +298,6 @@ mkDerivation { uuid vector wai - wai-extra wai-utilities warp warp-tls diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 47474894165..64bb0d69b4f 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -472,7 +472,6 @@ executable galley-integration , bytestring , bytestring-conversion , call-stack - , case-insensitive , cassandra-util , cassava , cereal @@ -513,7 +512,6 @@ executable galley-integration , random , retry , saml2-web-sso >=0.20 - , schema-profunctor , servant-client , servant-client-core , servant-server @@ -541,7 +539,6 @@ executable galley-integration , uuid , vector , wai - , wai-extra , wai-utilities , warp , warp-tls >=3.2 diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 49165e64bc7..3e82b298246 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -19,7 +19,6 @@ module API.MLS.Mocks ( receiveCommitMock, receiveCommitMockByDomain, messageSentMock, - messageSentMockByDomain, welcomeMock, welcomeMockByDomain, sendMessageMock, @@ -65,12 +64,6 @@ receiveCommitMockByDomain clients = do messageSentMock :: Mock LByteString messageSentMock = "on-mls-message-sent" ~> RemoteMLSMessageOk -messageSentMockByDomain :: [Domain] -> Mock LByteString -messageSentMockByDomain reachables = do - domain <- frTargetDomain <$> getRequest - guard (domain `elem` reachables) - messageSentMock - welcomeMock :: Mock LByteString welcomeMock = "mls-welcome" ~> MLSWelcomeSent diff --git a/services/galley/test/integration/API/SQS.hs b/services/galley/test/integration/API/SQS.hs index 2057433b150..ccf45732c90 100644 --- a/services/galley/test/integration/API/SQS.hs +++ b/services/galley/test/integration/API/SQS.hs @@ -111,9 +111,6 @@ tUpdate expectedCount uids l (Just e) = liftIO $ do (Set.fromList $ billingUserIds) tUpdate _ _ l Nothing = liftIO $ assertFailure $ l <> ": Expected 1 TeamUpdate, got nothing" -updateMatcher :: TeamId -> TeamEvent -> Bool -updateMatcher tid e = e ^. eventType == E.TeamEvent'TEAM_UPDATE && decodeIdFromBS (e ^. teamId) == tid - assertTeamUpdate :: (HasCallStack) => String -> TeamId -> Int32 -> [UserId] -> TestM () assertTeamUpdate l tid c uids = assertIfWatcher l (\e -> e ^. eventType == E.TeamEvent'TEAM_UPDATE && decodeIdFromBS (e ^. teamId) == tid) $ tUpdate c uids diff --git a/services/galley/test/integration/API/Teams/LegalHold/Util.hs b/services/galley/test/integration/API/Teams/LegalHold/Util.hs index 6fd3eee176b..b0918506e84 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/Util.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/Util.hs @@ -529,18 +529,6 @@ putLHWhitelistTeam' g tid = do . paths ["i", "legalhold", "whitelisted-teams", toByteString' tid] ) -_deleteLHWhitelistTeam :: (HasCallStack) => TeamId -> TestM ResponseLBS -_deleteLHWhitelistTeam tid = do - galleyCall <- viewGalley - deleteLHWhitelistTeam' galleyCall tid - -deleteLHWhitelistTeam' :: (HasCallStack, MonadHttp m) => GalleyR -> TeamId -> m ResponseLBS -deleteLHWhitelistTeam' g tid = do - delete - ( g - . paths ["i", "legalhold", "whitelisted-teams", toByteString' tid] - ) - errWith :: (HasCallStack, Typeable a, FromJSON a) => Int -> (a -> Bool) -> ResponseLBS -> TestM () errWith wantStatus wantBody rsp = liftIO $ do assertEqual "" wantStatus (statusCode rsp) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 09241ea7534..6d7df5a1e23 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -27,22 +27,18 @@ import Bilge.Assert import Bilge.TestSession import Control.Applicative import Control.Concurrent.Async -import Control.Exception (throw) import Control.Lens hiding (from, to, uncons, (#), (.=)) import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.Codensity (lowerCodensity) -import Control.Monad.Except (ExceptT, runExceptT) import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson qualified as A import Data.Aeson.Lens (key, _String) import Data.ByteString qualified as BS -import Data.ByteString.Base64.URL qualified as B64U import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Char8 qualified as C import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as Lazy -import Data.CaseInsensitive qualified as CI import Data.Code qualified as Code import Data.Currency qualified as Currency import Data.Default @@ -51,7 +47,6 @@ import Data.Handle qualified as Handle import Data.HashMap.Strict qualified as HashMap import Data.Id import Data.Json.Util hiding ((#)) -import Data.Kind import Data.LegalHold (defUserLegalHoldStatus) import Data.List.NonEmpty (NonEmpty) import Data.List1 as List1 @@ -60,7 +55,7 @@ import Data.Map.Strict qualified as Map import Data.Misc import Data.ProtoLens qualified as Protolens import Data.ProtocolBuffers (encodeMessage) -import Data.Qualified hiding (isLocal) +import Data.Qualified import Data.Range import Data.Serialize (runPut) import Data.Set qualified as Set @@ -69,14 +64,12 @@ import Data.String.Conversions import Data.Text qualified as Text import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as Text -import Data.Text.Lazy.Encoding qualified as LT import Data.Time (getCurrentTime) import Data.Tuple.Extra import Data.UUID qualified as UUID import Data.UUID.V4 import Federator.MockServer import Federator.MockServer qualified as Mock -import GHC.TypeLits (KnownSymbol) import GHC.TypeNats import Galley.Intra.User (chunkify) import Galley.Options qualified as Opts @@ -86,17 +79,12 @@ import Galley.Types.UserList import Imports import Network.HTTP.Client qualified as HTTP import Network.HTTP.Media.MediaType -import Network.HTTP.Types qualified as HTTP import Network.URI (pathSegments) -import Network.Wai (defaultRequest) -import Network.Wai qualified as Wai -import Network.Wai.Test qualified as Wai import Network.Wai.Utilities.MockServer (withMockServer) import Servant import System.Exit import System.Process import System.Random -import Test.QuickCheck qualified as Q import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit @@ -123,7 +111,6 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley -import Wire.API.Federation.Domain (originDomainHeaderName) import Wire.API.Internal.Notification hiding (target) import Wire.API.MLS.LeafNode import Wire.API.MLS.Message @@ -134,12 +121,10 @@ import Wire.API.Message import Wire.API.Message.Proto qualified as Proto import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.ConversationsIntra -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version import Wire.API.Team -import Wire.API.Team.Feature import Wire.API.Team.Invitation import Wire.API.Team.Member hiding (userId) import Wire.API.Team.Member qualified as Team @@ -198,7 +183,7 @@ createBindingTeam = do createBindingTeam' :: (HasCallStack) => TestM (User, TeamId) createBindingTeam' = do - owner <- randomTeamCreator' + owner <- randomTeamCreator teams <- getTeams (User.userId owner) [] team <- assertOne $ view teamListTeams teams let tid = view teamId team @@ -311,12 +296,6 @@ createBindingTeamInternalWithCurrency name owner cur = do === statusCode pure tid -getTeamInternal :: (HasCallStack) => TeamId -> TestM TeamData -getTeamInternal tid = do - g <- viewGalley - r <- get (g . paths ["i/teams", toByteString' tid]) UserId -> TeamId -> TestM Team getTeam usr tid = do g <- viewGalley @@ -428,14 +407,6 @@ getTeamMemberInternal tid mid = do r <- get (g . paths ["i", "teams", toByteString' tid, "members", toByteString' mid]) UserId -> TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () -addTeamMember usr tid muid mperms mmbinv = do - g <- viewGalley - let payload = json (mkNewTeamMember muid mperms mmbinv) - post (g . paths ["teams", toByteString' tid, "members"] . zUser usr . zConn "conn" . payload) - !!! const 200 - === statusCode - -- | FUTUREWORK: do not use this, it's broken!! use 'addUserToTeam' instead! https://wearezeta.atlassian.net/browse/SQSERVICES-471 addTeamMemberInternal :: (HasCallStack) => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () addTeamMemberInternal tid muid mperms mmbinv = addTeamMemberInternal' tid muid mperms mmbinv !!! const 200 === statusCode @@ -731,26 +702,6 @@ postConvQualified u c n = do . zType "access" . json n -postConvWithRemoteUsersGeneric :: - (HasCallStack) => - Mock LByteString -> - UserId -> - Maybe ClientId -> - NewConv -> - TestM (Response (Maybe LByteString)) -postConvWithRemoteUsersGeneric m u c n = do - let mock = - ("get-not-fully-connected-backends" ~> NonConnectedBackends mempty) - <|> m - fmap fst $ - withTempMockFederator' mock $ - postConvQualified u c n {newConvName = setName (newConvName n)} - Maybe (Range n m Text) -> Maybe (Range n m Text) - setName Nothing = checked "federated gossip" - setName x = x - postConvWithRemoteUsers :: (HasCallStack) => UserId -> @@ -1033,15 +984,6 @@ getConvs u cids = do . zConn "conn" . json (ListConversations (unsafeRange cids)) -getConvClients :: (HasCallStack) => GroupId -> TestM ClientList -getConvClients gid = do - g <- viewGalley - responseJsonError - =<< get - ( g - . paths ["i", "group", B64U.encode $ unGroupId gid] - ) - getAllConvs :: (HasCallStack) => UserId -> TestM [Conversation] getAllConvs u = do g <- viewGalley @@ -1409,15 +1351,6 @@ postJoinCodeConv' mPw u j = do -- `json (JoinConversationByCode j Nothing)` and `json j` are equivalent, using the latter to test backwards compatibility . (if isJust mPw then json (JoinConversationByCode j mPw) else json j) -deleteFederation :: - (MonadHttp m, HasGalley m, MonadIO m) => - Domain -> - m ResponseLBS -deleteFederation dom = do - g <- viewGalley - delete $ - g . paths ["/i/federation", toByteString' dom] - putQualifiedAccessUpdate :: (MonadHttp m, HasGalley m, MonadIO m) => UserId -> @@ -1581,15 +1514,6 @@ registerRemoteConv convId originUser name othMembers = do protocol = ProtocolProteus } -getFeatureStatusMulti :: forall cfg. (KnownSymbol (FeatureSymbol cfg)) => Multi.TeamFeatureNoConfigMultiRequest -> TestM ResponseLBS -getFeatureStatusMulti req = do - g <- viewGalley - post - ( g - . paths ["i", "features-multi-teams", featureNameBS @cfg] - . json req - ) - ------------------------------------------------------------------------------- -- Common Assertions @@ -1961,21 +1885,12 @@ decodeQualifiedConvIdList = fmap mtpResults . responseJsonEither @ConvIdsPage zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' -zBot :: UserId -> Request -> Request -zBot = header "Z-Bot" . toByteString' - zClient :: ClientId -> Request -> Request zClient = header "Z-Client" . toByteString' zConn :: ByteString -> Request -> Request zConn = header "Z-Connection" -zProvider :: ProviderId -> Request -> Request -zProvider = header "Z-Provider" . toByteString' - -zConv :: ConvId -> Request -> Request -zConv = header "Z-Conversation" . toByteString' - zType :: ByteString -> Request -> Request zType = header "Z-Type" @@ -2068,16 +1983,6 @@ postConnection from to = do RequestBodyLBS . encode $ ConnectionRequest to (unsafeRange "some conv name") -postConnectionQualified :: UserId -> Qualified UserId -> TestM ResponseLBS -postConnectionQualified from (Qualified toUser toDomain) = do - brig <- viewBrig - post $ - brig - . paths ["connections", toByteString' toDomain, toByteString' toUser] - . contentJson - . zUser from - . zConn "conn" - -- | A copy of 'putConnection' from Brig integration tests. putConnection :: UserId -> UserId -> Relation -> TestM ResponseLBS putConnection from to r = do @@ -2144,11 +2049,8 @@ randomQualifiedUser = randomUser' False True True randomQualifiedId :: (MonadIO m) => Domain -> m (Qualified (Id a)) randomQualifiedId domain = Qualified <$> randomId <*> pure domain -randomTeamCreator :: (HasCallStack) => TestM UserId -randomTeamCreator = qUnqualified <$> randomUser' True True True - -randomTeamCreator' :: (HasCallStack) => TestM User -randomTeamCreator' = randomUser'' True True True +randomTeamCreator :: (HasCallStack) => TestM User +randomTeamCreator = randomUser'' True True True randomUser' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (Qualified UserId) randomUser' isCreator hasPassword hasEmail = userQualifiedId <$> randomUser'' isCreator hasPassword hasEmail @@ -2263,36 +2165,6 @@ deleteClient u c pw = do [ "password" .= pw ] --- TODO: Refactor, as used also in brig -isUserDeleted :: (HasCallStack) => UserId -> TestM Bool -isUserDeleted u = do - b <- viewBrig - r <- - get (b . paths ["i", "users", toByteString' u, "status"]) - error $ "getStatus: failed to parse response: " ++ show r - Just j -> do - let st = maybeFromJSON =<< j ^? key "status" - let decoded = fromMaybe (error $ "getStatus: failed to decode status" ++ show j) st - pure $ decoded == Deleted - where - maybeFromJSON :: (FromJSON a) => Value -> Maybe a - maybeFromJSON v = case fromJSON v of - Success a -> Just a - _ -> Nothing - -isMember :: UserId -> ConvId -> TestM Bool -isMember usr cnv = do - g <- viewGalley - res <- - get $ - g - . paths ["i", "conversations", toByteString' cnv, "members", toByteString' usr] - . expect2xx - pure $ isJust (responseJsonMaybe @Member res) - randomUserWithClient :: LastPrekey -> TestM (UserId, ClientId) randomUserWithClient lk = do (u, c) <- randomUserWithClientQualified lk @@ -2304,9 +2176,6 @@ randomUserWithClientQualified lk = do c <- randomClient (qUnqualified u) lk pure (u, c) -newNonce :: TestM (Id ()) -newNonce = randomId - fromBS :: (HasCallStack, FromByteString a, MonadIO m) => ByteString -> m a fromBS bs = case fromByteString bs of @@ -2399,9 +2268,6 @@ otrRecipients = . fmap Map.fromList . foldr ((uncurry Map.insert . fmap pure) . (\(a, b, c) -> (a, (b, c)))) mempty -genRandom :: (Q.Arbitrary a, MonadIO m) => m a -genRandom = liftIO . Q.generate $ Q.arbitrary - defPassword :: PlainTextPassword6 defPassword = plainTextPassword6Unsafe "topsecretdefaultpassword" @@ -2577,13 +2443,6 @@ deleteTeam owner tid = do !!! do const 202 === statusCode --- (Duplicate of 'Galley.Intra.User.getUsers'.) -getUsersByUid :: [UserId] -> TestM [User] -getUsersByUid = getUsersBy "ids" - -getUsersByHandle :: [Handle.Handle] -> TestM [User] -getUsersByHandle = getUsersBy "handles" - getUsersBy :: forall uidsOrHandles. (ToByteString uidsOrHandles) => ByteString -> [uidsOrHandles] -> TestM [User] getUsersBy keyName = chunkify $ \keys -> do brig <- viewBrig @@ -2598,11 +2457,8 @@ getUsersBy keyName = chunkify $ \keys -> do let accounts = fromJust $ responseJsonMaybe @[UserAccount] res pure $ fmap accountUser accounts -getUserProfile :: UserId -> UserId -> TestM UserProfile -getUserProfile zusr uid = do - brig <- view tsUnversionedBrig - res <- get (brig . zUser zusr . paths ["v1", "users", toByteString' uid]) - responseJsonError res +getUsersByHandle :: [Handle.Handle] -> TestM [User] +getUsersByHandle = getUsersBy "handles" upgradeClientToLH :: (HasCallStack) => UserId -> ClientId -> TestM () upgradeClientToLH zusr cid = @@ -2688,51 +2544,11 @@ withTempMockFederator' resp action = do $ \mockPort -> do withSettingsOverrides (\opts -> opts & Opts.federator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action --- Starts a servant Application in Network.Wai.Test session and runs the --- FederatedRequest against it. -makeFedRequestToServant :: - forall (api :: Type). - (HasServer api '[]) => - Domain -> - Server api -> - FederatedRequest -> - IO LByteString -makeFedRequestToServant originDomain server fedRequest = do - sresp <- Wai.runSession session app - let status = Wai.simpleStatus sresp - bdy = Wai.simpleBody sresp - if HTTP.statusIsSuccessful status - then pure bdy - else throw (Mock.MockErrorResponse status (LT.decodeUtf8 bdy)) - where - app :: Application - app = serve (Proxy @api) server - - session :: Wai.Session Wai.SResponse - session = do - Wai.srequest - ( Wai.SRequest - ( defaultRequest - { Wai.requestMethod = HTTP.methodPost, - Wai.pathInfo = [frRPC fedRequest], - Wai.requestHeaders = - [ (CI.mk "Content-Type", "application/json"), - (CI.mk "Accept", "application/json"), - (originDomainHeaderName, cs . domainText $ originDomain) - ] - } - ) - (frBody fedRequest) - ) - assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b assertRight = \case Left e -> liftIO $ assertFailure $ "Expected Right, got Left: " <> show e Right x -> pure x -assertRightT :: (MonadIO m, Show a, HasCallStack) => ExceptT a m b -> m b -assertRightT = assertRight <=< runExceptT - -- | Run a probe several times, until a "good" value materializes or until patience runs out -- (after ~2secs). -- If all retries were unsuccessful, 'aFewTimes' will return the last obtained value, even @@ -2751,14 +2567,6 @@ aFewTimesAssertBool msg good action = do result <- aFewTimes action good liftIO $ assertBool msg (good result) -checkUserUpdateEvent :: (HasCallStack) => UserId -> WS.WebSocket -> TestM () -checkUserUpdateEvent uid w = WS.assertMatch_ checkTimeout w $ \notif -> do - let j = Object $ List1.head (ntfPayload notif) - let etype = j ^? key "type" . _String - let euser = j ^?! key "user" ^? key "id" . _String - etype @?= Just "user.update" - euser @?= Just (UUID.toText (toUUID uid)) - checkUserDeleteEvent :: (HasCallStack) => UserId -> WS.Timeout -> WS.WebSocket -> TestM () checkUserDeleteEvent uid timeout_ w = WS.assertMatch_ timeout_ w $ \notif -> do let j = Object $ List1.head (ntfPayload notif) @@ -2864,10 +2672,6 @@ mockedFederatedBrigResponse users = do guardComponent Brig mockReply [mkProfile mem (Name name) | (mem, name) <- users] -fedRequestsForDomain :: (HasCallStack) => Domain -> Component -> [FederatedRequest] -> [FederatedRequest] -fedRequestsForDomain domain component = - filter $ \req -> frTargetDomain req == domain && frComponent req == component - parseFedRequest :: (FromJSON a) => FederatedRequest -> Either String a parseFedRequest fr = eitherDecode (frBody fr) @@ -2879,14 +2683,6 @@ assertTwo :: (HasCallStack, Show a) => [a] -> (a, a) assertTwo [a, b] = (a, b) assertTwo xs = error $ "Expected two elements, found " <> show xs -assertThree :: (HasCallStack, Show a) => [a] -> (a, a, a) -assertThree [a1, a2, a3] = (a1, a2, a3) -assertThree xs = error $ "Expected three elements, found " <> show xs - -assertNone :: (HasCallStack, MonadIO m, Show a) => [a] -> m () -assertNone [] = pure () -assertNone xs = liftIO . error $ "Expected exactly no elements, found " <> show xs - assertJust :: (HasCallStack, MonadIO m) => Maybe a -> m a assertJust (Just a) = pure a assertJust Nothing = liftIO $ error "Expected Just, got Nothing" @@ -2918,16 +2714,10 @@ generateRemoteAndConvIdWithDomain :: Domain -> Bool -> Local UserId -> TestM (Re generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do other <- Qualified <$> randomId <*> pure remoteDomain let convId = one2OneConvId BaseProtocolProteusTag (tUntagged lUserId) other - isLocal = tDomain lUserId == qDomain convId - if shouldBeLocal == isLocal + if shouldBeLocal == isLocal lUserId convId then pure (qTagUnsafe other, convId) else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId -matchFedRequest :: Domain -> Text -> FederatedRequest -> Bool -matchFedRequest domain reqpath req = - frTargetDomain req == domain - && frRPC req == reqpath - spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> IO ByteString spawn cp minput = do (mout, ex) <- withCreateProcess @@ -3038,24 +2828,6 @@ createAndConnectUsers domains = do (False, False) -> pure () pure users -putConversationProtocol :: (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) => UserId -> ClientId -> Qualified ConvId -> ProtocolTag -> m ResponseLBS -putConversationProtocol uid client (Qualified conv domain) protocol = do - galley <- viewGalley - put - ( galley - . paths ["conversations", toByteString' domain, toByteString' conv, "protocol"] - . zUser uid - . zConn "conn" - . zClient client - . Bilge.json (object ["protocol" .= protocol]) - ) - -assertMixedProtocol :: (MonadIO m, HasCallStack) => Conversation -> m ConversationMLSData -assertMixedProtocol conv = do - case cnvProtocol conv of - ProtocolMixed mlsData -> pure mlsData - _ -> liftIO $ assertFailure "Unexpected protocol" - connectBackend :: UserId -> Remote Backend -> TestM [Qualified UserId] connectBackend usr (tDomain &&& bUsers . tUnqualified -> (d, c)) = do users <- replicateM (fromIntegral c) (randomQualifiedId d) diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 749ea934531..630f030e3f2 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -24,21 +24,15 @@ module API.Util.TeamFeature where import API.Util (HasGalley (viewGalley), zUser) import API.Util qualified as Util import Bilge -import Control.Lens ((.~), (^?)) -import Control.Monad.Catch (MonadThrow) -import Data.Aeson (FromJSON, Result (Success), ToJSON, Value, fromJSON) -import Data.Aeson.Key qualified as Key -import Data.Aeson.Lens +import Control.Lens ((.~)) +import Data.Aeson (ToJSON) import Data.ByteString.Conversion (toByteString') import Data.Id (ConvId, TeamId, UserId) -import Data.Schema import GHC.TypeLits (KnownSymbol) import Galley.Options (featureFlags, settings) import Galley.Types.Teams import Imports -import Test.Tasty.HUnit (assertBool, assertFailure, (@?=)) import TestSetup -import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public withCustomSearchFeature :: FeatureTeamSearchVisibilityAvailability -> TestM () -> TestM () @@ -58,113 +52,6 @@ putTeamSearchVisibilityAvailableInternal tid statusValue = tid (Public.WithStatusNoLock statusValue Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) -getTeamFeatureInternal :: - forall cfg m. - (HasGalley m, MonadIO m, MonadHttp m, KnownSymbol (Public.FeatureSymbol cfg)) => - TeamId -> - m ResponseLBS -getTeamFeatureInternal tid = do - g <- viewGalley - get $ - g - . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] - -getTeamFeature :: - forall cfg m. - (HasGalley m, MonadIO m, MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg)) => - UserId -> - TeamId -> - m ResponseLBS -getTeamFeature uid tid = do - galley <- viewGalley - get $ - galley - . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] - . zUser uid - -getAllTeamFeatures :: - (HasCallStack, HasGalley m, MonadIO m, MonadHttp m) => - UserId -> - TeamId -> - m ResponseLBS -getAllTeamFeatures uid tid = do - g <- viewGalley - get $ - g - . paths ["teams", toByteString' tid, "features"] - . zUser uid - -getTeamFeatureFromAll :: - forall cfg m. - ( HasCallStack, - MonadThrow m, - HasGalley m, - MonadIO m, - MonadHttp m, - KnownSymbol (Public.FeatureSymbol cfg), - FromJSON (Public.WithStatus cfg) - ) => - UserId -> - TeamId -> - m (Public.WithStatus cfg) -getTeamFeatureFromAll uid tid = do - response :: Value <- responseJsonError =<< getAllTeamFeatures uid tid - let status = response ^? key (Key.fromText (Public.featureName @cfg)) - maybe (error "getting all features failed") pure (status >>= fromResult . fromJSON) - where - fromResult :: Result a -> Maybe a - fromResult (Success b) = Just b - fromResult _ = Nothing - -getAllFeatureConfigs :: - (HasCallStack, HasGalley m, Monad m, MonadHttp m) => - UserId -> - m ResponseLBS -getAllFeatureConfigs uid = do - g <- viewGalley - get $ - g - . paths ["feature-configs"] - . zUser uid - -getFeatureConfig :: - forall cfg m. - ( HasCallStack, - MonadThrow m, - HasGalley m, - MonadHttp m, - KnownSymbol (Public.FeatureSymbol cfg), - FromJSON (Public.WithStatus cfg) - ) => - UserId -> - m (Public.WithStatus cfg) -getFeatureConfig uid = do - response :: Value <- responseJsonError =<< getAllFeatureConfigs uid - let status = response ^? key (Key.fromText (Public.featureName @cfg)) - maybe (error "getting all feature configs failed") pure (status >>= fromResult . fromJSON) - where - fromResult :: Result a -> Maybe a - fromResult (Success b) = Just b - fromResult _ = Nothing - -putTeamFeature :: - forall cfg. - ( HasCallStack, - KnownSymbol (Public.FeatureSymbol cfg), - ToJSON (Public.WithStatusNoLock cfg) - ) => - UserId -> - TeamId -> - Public.WithStatusNoLock cfg -> - TestM ResponseLBS -putTeamFeature uid tid status = do - galley <- viewGalley - put $ - galley - . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] - . json status - . zUser uid - putTeamFeatureInternal :: forall cfg m. ( Monad m, @@ -186,50 +73,23 @@ putTeamFeatureInternal reqmod tid status = do . json status . reqmod -setLockStatusInternal :: - forall cfg. - ( HasCallStack, - KnownSymbol (Public.FeatureSymbol cfg) - ) => - (Request -> Request) -> - TeamId -> - Public.LockStatus -> - TestM ResponseLBS -setLockStatusInternal reqmod tid lockStatus = do - galley <- viewGalley - put $ - galley - . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, toByteString' lockStatus] - . reqmod - -patchTeamFeatureInternal :: - forall cfg. - ( HasCallStack, - KnownSymbol (Public.FeatureSymbol cfg), - ToSchema cfg - ) => - TeamId -> - Public.WithStatusPatch cfg -> - TestM ResponseLBS -patchTeamFeatureInternal = patchTeamFeatureInternalWithMod id - -patchTeamFeatureInternalWithMod :: +putTeamFeature :: forall cfg. ( HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), - ToSchema cfg + ToJSON (Public.WithStatusNoLock cfg) ) => - (Request -> Request) -> + UserId -> TeamId -> - Public.WithStatusPatch cfg -> + Public.WithStatusNoLock cfg -> TestM ResponseLBS -patchTeamFeatureInternalWithMod reqmod tid reqBody = do +putTeamFeature uid tid status = do galley <- viewGalley - patch $ + put $ galley - . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] - . json reqBody - . reqmod + . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] + . json status + . zUser uid getGuestLinkStatus :: (HasCallStack) => @@ -243,43 +103,26 @@ getGuestLinkStatus galley u cid = . paths ["conversations", toByteString' cid, "features", Public.featureNameBS @Public.GuestLinksConfig] . zUser u -checkTeamFeatureAllEndpoints :: - forall cfg. - ( HasCallStack, - IsFeatureConfig cfg, - ToSchema cfg, - Typeable cfg, - Eq cfg, - Show cfg, - KnownSymbol (FeatureSymbol cfg) - ) => - UserId -> +getTeamFeatureInternal :: + forall cfg m. + (HasGalley m, MonadIO m, MonadHttp m, KnownSymbol (Public.FeatureSymbol cfg)) => TeamId -> - WithStatus cfg -> - TestM () -checkTeamFeatureAllEndpoints uid tid expected = do - compareLeniently $ responseJsonUnsafe <$> getTeamFeatureInternal @cfg tid - compareLeniently $ responseJsonUnsafe <$> getTeamFeature @cfg uid tid - compareLeniently $ getTeamFeatureFromAll @cfg uid tid - compareLeniently $ getFeatureConfig uid - where - compareLeniently :: TestM (WithStatus cfg) -> TestM () - compareLeniently receive = do - received <- receive - liftIO $ do - wsStatus received @?= wsStatus expected - wsLockStatus received @?= wsLockStatus expected - wsConfig received @?= wsConfig expected - checkTtl (wsTTL received) (wsTTL expected) + m ResponseLBS +getTeamFeatureInternal tid = do + g <- viewGalley + get $ + g + . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] - checkTtl :: FeatureTTL -> FeatureTTL -> IO () - checkTtl (FeatureTTLSeconds actualTtl) (FeatureTTLSeconds expectedTtl) = - assertBool - ("expected the actual TTL to be greater than 0 and equal to or no more than 2 seconds less than " <> show expectedTtl <> ", but it was " <> show actualTtl) - ( actualTtl > 0 - && actualTtl <= expectedTtl - && abs (fromIntegral @Word @Int actualTtl - fromIntegral @Word @Int expectedTtl) <= 2 - ) - checkTtl FeatureTTLUnlimited FeatureTTLUnlimited = pure () - checkTtl FeatureTTLUnlimited _ = assertFailure "expected the actual TTL to be unlimited, but it was limited" - checkTtl _ FeatureTTLUnlimited = assertFailure "expected the actual TTL to be limited, but it was unlimited" +getTeamFeature :: + forall cfg m. + (HasGalley m, MonadIO m, MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg)) => + UserId -> + TeamId -> + m ResponseLBS +getTeamFeature uid tid = do + galley <- viewGalley + get $ + galley + . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] + . zUser uid diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index b925700365e..dedd9cc1dab 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -218,7 +218,6 @@ mkDerivation { tasty-hunit tasty-quickcheck text - time tinylog types-common wai-utilities diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index e2150a6251c..2c4777a19b2 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -556,7 +556,6 @@ test-suite gundeck-tests , tasty-hunit , tasty-quickcheck , text - , time , tinylog , types-common , wai-utilities diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index 7715d8c8a7c..b5953867211 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -30,7 +30,6 @@ import Control.Concurrent.Async import Control.Lens import Control.Monad.Catch (MonadCatch, catch) import Data.String.Conversions -import Data.Time import GHC.Generics import Gundeck.Options import Gundeck.ThreadBudget.Internal @@ -56,16 +55,6 @@ newtype NumberOfThreads = NumberOfThreads {fromNumberOfThreads :: Int} newtype MilliSeconds = MilliSeconds {fromMilliSeconds :: Int} deriving (Eq, Ord, Show, Generic, ToExpr) --- toMillisecondsCeiling 0.03 == MilliSeconds 30 --- toMillisecondsCeiling 0.003 == MilliSeconds 3 --- toMillisecondsCeiling 0.0003 == MilliSeconds 1 --- toMillisecondsCeiling 0.0000003 == MilliSeconds 1 -toMillisecondsCeiling :: NominalDiffTime -> MilliSeconds -toMillisecondsCeiling = MilliSeconds . ceiling . (* 1000) . toRational - -milliSecondsToNominalDiffTime :: MilliSeconds -> NominalDiffTime -milliSecondsToNominalDiffTime = fromRational . (/ 1000) . toRational . fromMilliSeconds - instance Arbitrary NumberOfThreads where arbitrary = NumberOfThreads <$> choose (1, 30) shrink (NumberOfThreads n) = NumberOfThreads <$> filter (> 0) (shrink n) @@ -112,9 +101,6 @@ instance LC.MonadLogger (ReaderT LogHistory IO) where delayms :: (MonadCatch m, MonadIO m) => MilliSeconds -> m () delayms = delay' . (* 1000) . fromMilliSeconds -delayndt :: (MonadCatch m, MonadIO m) => NominalDiffTime -> m () -delayndt = delay' . round . (* 1000) . (* 1000) . toRational - delay' :: (MonadCatch m, MonadIO m) => Int -> m () delay' microsecs = threadDelay microsecs `catch` \AsyncCancelled -> pure () @@ -146,14 +132,15 @@ tests = "thread budgets" [ -- flaky test case as described in https://wearezeta.atlassian.net/browse/BE-527 -- testCase "unit test" testThreadBudgets, - testProperty "qc stm (sequential)" propSequential + testProperty "qc stm (sequential)" propSequential, + testCase "thread buckets" testThreadBudgets ] ---------------------------------------------------------------------- -- deterministic unit test -_testThreadBudgets :: Assertion -_testThreadBudgets = do +testThreadBudgets :: Assertion +testThreadBudgets = do let timeUnits n = MilliSeconds $ lengthOfTimeUnit * n lengthOfTimeUnit = 5 -- if you make this larger, the test will run more slowly, and be -- less likely to have timing issues. if you make it too small, some of the calls to diff --git a/services/proxy/src/Proxy/API/Public.hs b/services/proxy/src/Proxy/API/Public.hs index 03fd4b65bd1..a33bafb1d9c 100644 --- a/services/proxy/src/Proxy/API/Public.hs +++ b/services/proxy/src/Proxy/API/Public.hs @@ -110,7 +110,7 @@ proxy e qparam keyname reroute path phost rq k = do else runProxy e waiReq (k res) onUpstreamError runInIO x _ next = do void . runInIO $ Logger.warn (msg (val "gateway error") ~~ field "error" (show x)) - next (errorRs' error502) + next (errorRs error502) spotifyToken :: Request -> Proxy Response spotifyToken rq = do diff --git a/weeder.toml b/weeder.toml index 5e2042081e4..e0ddc4c24e5 100644 --- a/weeder.toml +++ b/weeder.toml @@ -1,5 +1,57 @@ # weeder intro and further reading: https://github.com/ocharles/weeder?tab=readme-ov-file#weeder -roots = ["^Main.main$", "^Paths_.*", "^Testlib.RunServices.main$", "^Testlib.Run.main$", "^Test.Wire.API.Golden.Run.main$"] + +roots = [ # may of the entries here are about general-purpose module + # interfaces that make sense as a whole, but are *currently* + # only used in part. it's possible that we should remove + # those entries here and extend the tests to cover them. + + "^API.Cargohold.getFederationAsset", # FUTUREWORK: write tests that need this! + "^API.Cargohold.uploadAssetV3", # FUTUREWORK: write tests that need this! + "^API.Galley.consentToLegalHold", # FUTUREWORK: write tests that need this! + "^API.Galley.enableLegalHold", # FUTUREWORK: write tests that need this! + "^API.Galley.getLegalHoldStatus", # FUTUREWORK: write tests that need this! + "^Data.ETag.opaqueDigest", + "^Data.ETag._OpaqueDigest", + "^Data.ETag.opaqueMD5", + "^Data.ETag.opaqueSHA1", + "^Data.ETag.strictETag", + "^Data.ETag._StrictETag", + "^Data.ETag.weakETag", + "^Data.ETag._WeakETag", + "^Data.Qualified.isLocal", + "^Data.Range.(<|)", + "^Data.Range.rappend", + "^Data.Range.rcons", + "^Data.Range.rinc", + "^Data.Range.rsingleton", + "^Imports.getChar", + "^Imports.getContents", + "^Imports.interact", + "^Imports.putChar", + "^Imports.readIO", + "^Imports.readLn", + "^Main.main$", + "^Paths_.*", + "^Test.Cargohold.API.Util.shouldMatchALittle", + "^Test.Cargohold.API.Util.shouldMatchLeniently", + "^Test.Cargohold.API.Util.shouldMatchSloppily", + "^Testlib.JSON.(<$$$>)", + "^Testlib.JSON.member", + "^Testlib.Prelude.appendFile", + "^Testlib.Prelude.getChar", + "^Testlib.Prelude.getContents", + "^Testlib.Prelude.getLine", + "^Testlib.Prelude.interact", + "^Testlib.Prelude.readFile", + "^Testlib.Prelude.readIO", + "^Testlib.Prelude.readLn", + "^Testlib.Prelude.writeFile", + "^Testlib.Printing.gray", + "^Testlib.Printing.hline", + "^Testlib.Run.main$", + "^Testlib.RunServices.main$", + "^Test.Wire.API.Golden.Run.main$" + ] type-class-roots = true # `root-instances` is more precise, but requires more config maintenance. # FUTUREWORK: unused-types = true