diff --git a/cabal.project b/cabal.project index c01afff0585..c0a106450cb 100644 --- a/cabal.project +++ b/cabal.project @@ -166,3 +166,14 @@ package zauth ghc-options: -Werror package fedcalls ghc-options: -Werror + +-- NOTE: +-- - these packages are not provided by nix, reason being, that +-- there is a bug in the nixpkgs haskell compatibility which +-- makes it such that they cannot be installed by the nixpkgs code +-- - these packages have bounds that are justified with their current +-- dependency set, however, we have updated their dependencies, such +-- that they work with newer base and ghc (api) versions +allow-newer: + , proto-lens-protoc:base + , proto-lens-protoc:ghc diff --git a/changelog.d/5-internal/WPB-5175 b/changelog.d/5-internal/WPB-5175 new file mode 100644 index 00000000000..a7ba59aa8e2 --- /dev/null +++ b/changelog.d/5-internal/WPB-5175 @@ -0,0 +1 @@ +upgrade the GHC version to GHC 9.4 diff --git a/hack/bin/generate-local-nix-packages.sh b/hack/bin/generate-local-nix-packages.sh index c993e71188c..178f5515e65 100755 --- a/hack/bin/generate-local-nix-packages.sh +++ b/hack/bin/generate-local-nix-packages.sh @@ -4,7 +4,7 @@ set -euo pipefail SCRIPT_DIR=$(cd -- "$(dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) ROOT_DIR=$(cd -- "$SCRIPT_DIR/../../" &> /dev/null && pwd) -cabalFiles=$(find -L "$ROOT_DIR" -name '*.cabal' \ +cabalFiles=$(find "$ROOT_DIR" -name '*.cabal' \ | grep -v dist-newstyle | sort) warningFile=$(mktemp) diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index 3ca68cac789..faaf781496a 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -3,7 +3,6 @@ module Testlib.App where import Control.Monad.Reader import Control.Retry qualified as Retry import Data.Aeson hiding ((.=)) -import Data.Functor ((<&>)) import Data.IORef import Data.Text qualified as T import Data.Yaml qualified as Yaml @@ -43,10 +42,9 @@ readServiceConfig = readServiceConfig' . configName readServiceConfig' :: String -> App Value readServiceConfig' srvName = do - cfgFile <- - asks (.servicesCwdBase) <&> \case - Nothing -> "/etc/wire" srvName "conf" (srvName <> ".yaml") - Just p -> p srvName (srvName <> ".integration.yaml") + cfgFile <- asks \env -> case env.servicesCwdBase of + Nothing -> "/etc/wire" srvName "conf" (srvName <> ".yaml") + Just p -> p srvName (srvName <> ".integration.yaml") eith <- liftIO (Yaml.decodeFileEither cfgFile) case eith of diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index d07176f3278..2227d43942a 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -9,7 +9,6 @@ import Data.ByteString.Char8 qualified as C8 import Data.ByteString.Lazy qualified as L import Data.CaseInsensitive qualified as CI import Data.Function -import Data.Functor ((<&>)) import Data.List import Data.List.Split (splitOn) import Data.Maybe @@ -173,7 +172,7 @@ locationHeaderHost :: Response -> String locationHeaderHost resp = let location = C8.unpack . snd . fromJust $ locationHeader resp locationURI = fromJust $ parseURI location - locationHost = fromJust $ locationURI & uriAuthority <&> uriRegName + locationHost = uriRegName (fromJust (locationURI & uriAuthority)) in locationHost locationHeader :: Response -> Maybe (HTTP.HeaderName, ByteString) diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index a0b8778e998..a228aae86d6 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -18,7 +18,7 @@ import Data.Foldable import Data.Function import Data.Functor import Data.List.Split (splitOn) -import Data.Maybe +import Data.Maybe (fromMaybe) import Data.Scientific qualified as Sci import Data.String import Data.Text qualified as T @@ -287,7 +287,7 @@ printJSON = prettyJSON >=> liftIO . putStrLn prettyJSON :: MakesValue a => a -> App String prettyJSON x = - make x <&> Aeson.encodePretty <&> LC8.unpack + make x <&> LC8.unpack . Aeson.encodePretty jsonType :: Value -> String jsonType (Object _) = "Object" diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index b7915cffc67..8ce5bee7867 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -397,7 +397,7 @@ startProcess' domain execName config = do tempFile <- liftIO $ writeTempFile "/tmp" (execName <> "-" <> domain <> "-" <> ".yaml") (cs $ Yaml.encode config) (cwd, exe) <- - asks (.servicesCwdBase) <&> \case + asks \env -> case env.servicesCwdBase of Nothing -> (Nothing, execName) Just dir -> (Just (dir execName), "../../dist" execName) @@ -545,14 +545,13 @@ server 127.0.0.1:{port} max_fails=3 weight=1; (serviceName Spar, sm.spar.port), ("proxy", sm.proxy.port) ] - ( \case - (srv, p) -> do - let upstream = - upstreamTemplate - & Text.replace "{name}" (cs $ srv) - & Text.replace "{port}" (cs $ show p) - liftIO $ appendFile upstreamsCfg (cs upstream) - ) + \case + (srv, p) -> do + let upstream = + upstreamTemplate + & Text.replace "{name}" (cs $ srv) + & Text.replace "{port}" (cs $ show p) + liftIO $ appendFile upstreamsCfg (cs upstream) startNginz :: String -> FilePath -> FilePath -> App ProcessHandle startNginz domain conf workingDir = do diff --git a/integration/test/Testlib/Run.hs b/integration/test/Testlib/Run.hs index 349c44390cb..bba75ed0641 100644 --- a/integration/test/Testlib/Run.hs +++ b/integration/test/Testlib/Run.hs @@ -112,10 +112,9 @@ createGlobalEnv cfg = do liftIO . runAppWithEnv env $ do config <- readServiceConfig Galley relPath <- config %. "settings.mlsPrivateKeyPaths.removal.ed25519" & asString - path <- - asks (.servicesCwdBase) <&> \case - Nothing -> relPath - Just dir -> dir "galley" relPath + path <- asks \env' -> case env'.servicesCwdBase of + Nothing -> relPath + Just dir -> dir "galley" relPath bs <- liftIO $ B.readFile path pems <- case pemParseBS bs of Left err -> assertFailure $ "Could not parse removal key PEM: " <> err diff --git a/libs/http2-manager/http2-manager.cabal b/libs/http2-manager/http2-manager.cabal index 4aa3b54347d..3aed0c465ba 100644 --- a/libs/http2-manager/http2-manager.cabal +++ b/libs/http2-manager/http2-manager.cabal @@ -49,7 +49,7 @@ library default-language: Haskell2010 flag test-trailing-dot - description: "Whether or not include the trainling dot test" + description: "Whether or not include the trailing dot test" default: True test-suite http2-manager-tests diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs index 9ae1187481f..e2dd11a7853 100644 --- a/libs/schema-profunctor/src/Data/Schema.hs +++ b/libs/schema-profunctor/src/Data/Schema.hs @@ -296,6 +296,7 @@ instance HasOpt doc => FieldFunctor doc Maybe where -- | A schema for a one-field JSON object. field :: + forall doc' doc a b. HasField doc' doc => Text -> SchemaP doc' A.Value A.Value a b -> @@ -304,6 +305,7 @@ field = fieldOver id -- | A schema for a JSON object with a single optional field. optField :: + forall doc doc' a b. (HasOpt doc, HasField doc' doc) => Text -> SchemaP doc' A.Value A.Value a b -> @@ -312,6 +314,7 @@ optField = fieldF -- | Generalization of 'optField' with 'FieldFunctor'. fieldF :: + forall doc' doc f a b. (HasField doc' doc, FieldFunctor doc f) => Text -> SchemaP doc' A.Value A.Value a b -> @@ -362,32 +365,35 @@ fieldOver l name = fmap runIdentity . fieldOverF l name -- | Like 'field', but apply an arbitrary function to the -- documentation of the field. fieldWithDocModifier :: + forall doc' doc a b. HasField doc' doc => Text -> (doc' -> doc') -> SchemaP doc' A.Value A.Value a b -> SchemaP doc A.Object [A.Pair] a b -fieldWithDocModifier name modify sch = field name (over doc modify sch) +fieldWithDocModifier name modify sch = field @doc' @doc name (over doc modify sch) -- | Like 'optField', but apply an arbitrary function to the -- documentation of the field. optFieldWithDocModifier :: + forall doc doc' a b. (HasOpt doc, HasField doc' doc) => Text -> (doc' -> doc') -> SchemaP doc' A.Value A.Value a b -> SchemaP doc A.Object [A.Pair] a (Maybe b) -optFieldWithDocModifier name modify sch = optField name (over doc modify sch) +optFieldWithDocModifier name modify sch = optField @doc @doc' name (over doc modify sch) -- | Like 'fieldF', but apply an arbitrary function to the -- documentation of the field. fieldWithDocModifierF :: + forall doc' doc f a b. (HasField doc' doc, FieldFunctor doc f) => Text -> (doc' -> doc') -> SchemaP doc' A.Value A.Value a b -> SchemaP doc A.Object [A.Pair] a (f b) -fieldWithDocModifierF name modify sch = fieldF name (over doc modify sch) +fieldWithDocModifierF name modify sch = fieldF @doc' @doc name (over doc modify sch) -- | Change the input type of a schema. (.=) :: Profunctor p => (a -> a') -> p a' b -> p a b diff --git a/libs/types-common/src/Data/ETag.hs b/libs/types-common/src/Data/ETag.hs index db0d8f638f3..c042a042f43 100644 --- a/libs/types-common/src/Data/ETag.hs +++ b/libs/types-common/src/Data/ETag.hs @@ -43,13 +43,14 @@ import Control.Lens -- TODO: These package imports are only needed due to the -- use of GHCI. They should be removed by moving everything -- from cryptohash (which is deprecated) to cryptonite -import "cryptohash-md5" Crypto.Hash.MD5 qualified as MD5 -import "cryptohash-sha1" Crypto.Hash.SHA1 qualified as SHA1 + import Data.Attoparsec.ByteString.Char8 import Data.ByteString.Base16 qualified as Hex import Data.ByteString.Builder (byteString) import Data.ByteString.Conversion import Imports hiding (takeWhile) +import "cryptohash-md5" Crypto.Hash.MD5 qualified as MD5 +import "cryptohash-sha1" Crypto.Hash.SHA1 qualified as SHA1 data Digest = MD5 | SHA1 diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index 8acd18dee2b..915a606dd72 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -329,7 +329,7 @@ instance ToSchema (Fingerprint Rsa) where p :: Chars.Parser (Fingerprint Rsa) p = do bs <- parser - either fail pure (Fingerprint <$> B64.decode bs) + either fail (pure . Fingerprint) (B64.decode bs) instance Cql (Fingerprint a) where ctype = Tagged BlobColumn diff --git a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs index 5300165d9e0..c035797f739 100644 --- a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs +++ b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs @@ -27,10 +27,10 @@ module Wire.API.MakesFederatedCall Location (..), ShowComponent, Annotation, - exposeAnnotations, HasFeds (..), FedCallFrom' (..), Calls (..), + Wire.API.MakesFederatedCall.exposeAnnotations, ) where diff --git a/libs/wire-api/src/Wire/API/SwaggerHelper.hs b/libs/wire-api/src/Wire/API/SwaggerHelper.hs index 3e882b8ab5c..fa4310dea83 100644 --- a/libs/wire-api/src/Wire/API/SwaggerHelper.hs +++ b/libs/wire-api/src/Wire/API/SwaggerHelper.hs @@ -67,17 +67,17 @@ cleanupSwagger = if "Invalid " `T.isPrefixOf` desc && resp - ^? _Inline - . links - == pure mempty + ^? _Inline + . links + == pure mempty && resp - ^? _Inline - . content - == pure mempty + ^? _Inline + . content + == pure mempty && resp - ^? _Inline - . headers - == pure mempty + ^? _Inline + . headers + == pure mempty then resps else insert code resp resps Nothing -> insert code resp resps @@ -86,17 +86,17 @@ cleanupSwagger = if " not found" `T.isSuffixOf` desc && resp - ^? _Inline - . links - == pure mempty + ^? _Inline + . links + == pure mempty && resp - ^? _Inline - . content - == pure mempty + ^? _Inline + . content + == pure mempty && resp - ^? _Inline - . headers - == pure mempty + ^? _Inline + . headers + == pure mempty then resps else insert code resp resps Nothing -> insert code resp resps diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index 40fbb9a7af0..e25f3ec7577 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -93,9 +93,9 @@ instance ToSchema LHServiceStatus where instance ToSchema ViewLegalHoldService where schema = - object "ViewLegalHoldService" - $ toOutput .= recordSchema - `withParser` validateViewLegalHoldService + object "ViewLegalHoldService" $ + toOutput .= recordSchema + `withParser` validateViewLegalHoldService where toOutput :: ViewLegalHoldService -> (LHServiceStatus, Maybe ViewLegalHoldServiceInfo) toOutput = \case diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index d5d51060422..b34adac5dba 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -56,14 +56,14 @@ # 1. Update version number. # 2. Make the 'sha256' blank string. # 3. Run step 3. from how to add a git pin. -{ lib, fetchgit }: hself: hsuper: +{ lib, fetchgit, pkgs }: hself: hsuper: let gitPins = { transitive-anns = { src = fetchgit { url = "https://github.com/wireapp/transitive-anns"; - rev = "c3bdc423f84bf15fe8b3618b5dddd5764fc8a470"; - sha256 = "sha256-mWBZ2uY0shlxNRceyC2Zu1f3Kr4IDtT/rOL7CKWgilA="; + rev = "7caf82f8d1be0f994a557e0cdc87fde8e32d5420"; + sha256 = "sha256-rDIAbYpNGMBDOOE1hqLneRSVkCnj3cCQVYGKkhw8t7w="; }; }; amazonka = { @@ -214,12 +214,24 @@ let sha256 = "sha256-+rHcS+BwEFsXqPAHX/KZDIgv9zfk1dZl0LlZJ57Com4="; }; }; - # PR: https://github.com/freckle/hspec-junit-formatter/pull/24 - hspec-junit-formatter = { - src = fetchgit { - url = "https://github.com/akshaymankar/hspec-junit-formatter"; - rev = "acec31822cc4f90489d9940bad23b3fd6d1d7c75"; - sha256 = "sha256-4xGW3KHQKbTL+6+Q/gzfaMBP+J0npUe7tP5ZCQCB5+s="; + + text-icu-translit = { + src = pkgs.fetchFromGitHub { + owner = "wireapp"; + repo = "text-icu-translit"; + rev = "317bbd27ea5ae4e7f93836ee9ca664f9bde7c583"; + hash = "sha256-9uVqUTkLkE7U19FDjn5xt8JEHyJmosLPSnmW7kYbe5w="; + }; + }; + + # PR at https://github.com/google/ghc-source-gen/pull/102 + ghc-source-gen = { + version = "0.4.4.0"; + src = pkgs.fetchFromGitHub { + owner = "circuithub"; + repo = "ghc-source-gen"; + rev = "7a6aac047b706508e85ba2054b5bedbecfd7eb7a"; + hash = "sha256-DZu3XAOYLKcSpOYhjpb6IuXMvRHtGohTkL0nsCb/dT0="; }; }; }; diff --git a/nix/manual-overrides.nix b/nix/manual-overrides.nix index 8648f5c5e92..8e2fcb0b039 100644 --- a/nix/manual-overrides.nix +++ b/nix/manual-overrides.nix @@ -1,4 +1,4 @@ -{ libsodium, protobuf, hlib, mls-test-cli, fetchpatch }: +{ libsodium, protobuf, hlib, mls-test-cli, fetchpatch, ... }: # FUTUREWORK: Figure out a way to detect if some of these packages are not # actually marked broken, so we can cleanup this file on every nixpkgs bump. hself: hsuper: { @@ -10,7 +10,12 @@ hself: hsuper: { url = "https://gitlab.com/twittner/cql/-/merge_requests/11.patch"; sha256 = "sha256-qfcCRkKjSS1TEqPRVBU9Ox2DjsdGsYG/F3DrZ5JGoEI="; }); + ghc-source-gen = hlib.markUnbroken (hlib.doJailbreak hsuper.ghc-source-gen); + proto-lens-protoc = hlib.doJailbreak hsuper.proto-lens-protoc; + proto-lens-setup = hlib.doJailbreak hsuper.proto-lens-setup; hashtables = hsuper.hashtables_1_3; + # in case everything breaks with the hashable update, use this + # hashable = hsuper.callHackage "hashable" "1.4.2.0" {}; invertible = hlib.markUnbroken hsuper.invertible; lens-datetime = hlib.markUnbroken (hlib.doJailbreak hsuper.lens-datetime); monoidal-containers = hlib.doJailbreak hsuper.monoidal-containers; @@ -33,13 +38,14 @@ hself: hsuper: { sodium-crypto-sign = hlib.addPkgconfigDepend hsuper.sodium-crypto-sign libsodium.dev; text-icu-translit = hlib.markUnbroken (hlib.dontCheck hsuper.text-icu-translit); text-short = hlib.dontCheck hsuper.text-short; - template = hlib.markUnbroken hsuper.template; + template = hlib.markUnbroken (hlib.doJailbreak hsuper.template); type-errors = hlib.dontCheck hsuper.type-errors; th-abstraction = hsuper.th-abstraction_0_5_0_0; th-desugar = hlib.doJailbreak hsuper.th-desugar; wai-middleware-prometheus = hlib.doJailbreak hsuper.wai-middleware-prometheus; wai-predicates = hlib.markUnbroken hsuper.wai-predicates; - + # transitive-anns has flaky tests + transitive-anns = hlib.dontCheck hsuper.transitive-anns; http2-manager = hlib.enableCabalFlag hsuper.http2-manager "-f-test-trailing-dot"; # PR with fix: https://github.com/freckle/hspec-junit-formatter/pull/23 diff --git a/nix/overlay-docs.nix b/nix/overlay-docs.nix index 5175ccbe77b..5c1a233bb5f 100644 --- a/nix/overlay-docs.nix +++ b/nix/overlay-docs.nix @@ -1,5 +1,5 @@ self: super: rec { - python3 = super.python3.override ({ + python3 = super.python3.override { packageOverrides = pself: psuper: { rst2pdf = pself.callPackage ./pkgs/python-docs/rst2pdf.nix { }; sphinx-multiversion = pself.callPackage ./pkgs/python-docs/sphinx-multiversion.nix { }; @@ -7,7 +7,7 @@ self: super: rec { sphinxcontrib-kroki = pself.callPackage ./pkgs/python-docs/sphinxcontrib-kroki.nix { }; svg2rlg = pself.callPackage ./pkgs/python-docs/svg2rlg.nix { }; }; - }); + }; mls-test-cli = self.callPackage ./pkgs/mls-test-cli { }; diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index 308904450dc..9b755e9b6aa 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -1,7 +1,6 @@ { fetchFromGitHub , rustPlatform }: - # TODO: migrate to crate2nix once # https://github.com/nix-community/crate2nix/issues/310 is fixed rustPlatform.buildRustPackage rec { diff --git a/nix/pkgs/python-docs/sphinx_reredirects.nix b/nix/pkgs/python-docs/sphinx_reredirects.nix index 1bff3180551..a5c05d758cb 100644 --- a/nix/pkgs/python-docs/sphinx_reredirects.nix +++ b/nix/pkgs/python-docs/sphinx_reredirects.nix @@ -1,15 +1,14 @@ { fetchPypi , buildPythonPackage , sphinx -, }: buildPythonPackage rec { - + doCheck = false; pname = "sphinx_reredirects"; - version = "0.1.1"; + version = "0.1.2"; src = fetchPypi { inherit pname version; - sha256 = "sha256:RRmkXTFskhxGMnty/kEOHnoy/lFpR0EpYCCwygCPvO4="; + sha256 = "sha256-oOchMwR1mwHtwi8DLxcVocYRdvyPFnFk56Urn+7JrGQ="; }; propagatedBuildInputs = [ diff --git a/nix/pkgs/python-docs/sphinxcontrib-kroki.nix b/nix/pkgs/python-docs/sphinxcontrib-kroki.nix index f65a43a1352..179c6cad862 100644 --- a/nix/pkgs/python-docs/sphinxcontrib-kroki.nix +++ b/nix/pkgs/python-docs/sphinxcontrib-kroki.nix @@ -3,10 +3,9 @@ , sphinx , requests , pyyaml -, }: buildPythonPackage rec { - + doCheck = false; pname = "sphinxcontrib-kroki"; version = "1.3.0"; src = fetchPypi { diff --git a/nix/wire-server.nix b/nix/wire-server.nix index f22c2603659..7d0f843e9c7 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -91,7 +91,8 @@ let attrsets = lib.attrsets; pinnedPackages = import ./haskell-pins.nix { - fetchgit = pkgs.fetchgit; + inherit pkgs; + inherit (pkgs) fetchgit; inherit lib; }; @@ -140,7 +141,7 @@ let bench ]; manualOverrides = import ./manual-overrides.nix (with pkgs; { - inherit hlib libsodium protobuf mls-test-cli fetchpatch; + inherit hlib libsodium protobuf mls-test-cli fetchpatch pkgs; }); executables = hself: hsuper: @@ -153,7 +154,7 @@ let ) executablesMap; - hPkgs = localMods@{ enableOptimization, enableDocs, enableTests }: pkgs.haskell.packages.ghc92.override { + hPkgs = localMods@{ enableOptimization, enableDocs, enableTests }: pkgs.haskell.packages.ghc94.override { overrides = lib.composeManyExtensions [ pinnedPackages (localPackages localMods) @@ -389,16 +390,7 @@ let }; }; - # FIXME: when upgrading the ghc version, we - # should have to upgrade ormolu to support - # the new parser and get rid of these (then unnecessary) - # overrides - inherit (pkgs.haskell.packages.ghc92.override { - overrides = hfinal: hprev: { - ormolu = hfinal.ormolu_0_5_0_1; - ghc-lib-parser = hprev.ghc-lib-parser_9_2_8_20230729; - }; - }) ormolu; + ormolu = pkgs.haskell.packages.ghc94.ormolu_0_5_2_0; # Tools common between CI and developers commonTools = [ @@ -470,7 +462,6 @@ let }; in { - inherit ciImage hoogleImage; images = images localModsEnableAll; @@ -486,11 +477,12 @@ in devEnv = pkgs.buildEnv { name = "wire-server-dev-env"; + ignoreCollisions = true; paths = commonTools ++ [ pkgs.bash pkgs.crate2nix pkgs.dash - (pkgs.haskell-language-server.override { supportedGhcVersions = [ "92" ]; }) + (pkgs.haskell-language-server.override { supportedGhcVersions = [ "94" ]; }) pkgs.ghcid pkgs.kind pkgs.netcat @@ -530,7 +522,6 @@ in inherit brig-templates; haskellPackages = hPkgs localModsEnableAll; haskellPackagesUnoptimizedNoDocs = hPkgs localModsOnlyTests; - allLocalPackages = pkgs.symlinkJoin { name = "all-local-packages"; paths = map (e: (hPkgs localModsEnableAll).${e}) wireServerPackages; diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 2f7e50ffe75..e298ebf14fb 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -146,7 +146,7 @@ createConnectionToLocalUser self conn target = do accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) accept s2o o2s = do - when (ucStatus s2o `notElem` [Sent, Accepted]) $ + unless (ucStatus s2o `elem` [Sent, Accepted]) $ checkLimit self lift . Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -168,7 +168,7 @@ createConnectionToLocalUser self conn target = do resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) resend s2o o2s = do - when (ucStatus s2o `notElem` [Sent, Accepted]) $ + unless (ucStatus s2o `elem` [Sent, Accepted]) $ checkLimit self lift . Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index e5c223e7c86..b076e067918 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -170,11 +170,11 @@ federatedEndpointsSwaggerDocsAPIs = internalEndpointsSwaggerDocsAPIs :: Servant.Server InternalEndpointsSwaggerDocsAPI internalEndpointsSwaggerDocsAPIs = - internalEndpointsSwaggerDocsAPI "brig" 9082 BrigInternalAPI.swaggerDoc - :<|> internalEndpointsSwaggerDocsAPI "cannon" 9093 CannonInternalAPI.swaggerDoc - :<|> internalEndpointsSwaggerDocsAPI "cargohold" 9094 CargoholdInternalAPI.swaggerDoc - :<|> internalEndpointsSwaggerDocsAPI "galley" 9095 GalleyInternalAPI.swaggerDoc - :<|> internalEndpointsSwaggerDocsAPI "spar" 9098 SparInternalAPI.swaggerDoc + internalEndpointsSwaggerDocsAPI @"brig" "brig" 9082 BrigInternalAPI.swaggerDoc + :<|> internalEndpointsSwaggerDocsAPI @"cannon" "cannon" 9093 CannonInternalAPI.swaggerDoc + :<|> internalEndpointsSwaggerDocsAPI @"cargohold" "cargohold" 9094 CargoholdInternalAPI.swaggerDoc + :<|> internalEndpointsSwaggerDocsAPI @"galley" "galley" 9095 GalleyInternalAPI.swaggerDoc + :<|> internalEndpointsSwaggerDocsAPI @"spar" "spar" 9098 SparInternalAPI.swaggerDoc -- | Serves Swagger docs for public endpoints -- @@ -229,7 +229,11 @@ versionedSwaggerDocsAPI Nothing = allroutes (throwError listAllVersionsResp) -- empty. It would have been too tedious to create them. Please add -- pre-generated docs on version increase as it's done in -- `versionedSwaggerDocsAPI`. +-- +-- If you're having issues with this function not typechecking when it should, +-- be sure to supply the type argument explicitly internalEndpointsSwaggerDocsAPI :: + forall service. String -> PortNumber -> S.OpenApi -> diff --git a/services/brig/src/Brig/API/Public/Swagger.hs b/services/brig/src/Brig/API/Public/Swagger.hs index c896a10f7e7..1141b5f0bb3 100644 --- a/services/brig/src/Brig/API/Public/Swagger.hs +++ b/services/brig/src/Brig/API/Public/Swagger.hs @@ -20,6 +20,7 @@ import Data.Aeson qualified as A import Data.FileEmbed import Data.HashMap.Strict.InsOrd qualified as HM import Data.HashSet.InsOrd qualified as InsOrdSet +import Data.Kind qualified as Kind import Data.OpenApi qualified as S import Data.OpenApi.Declare qualified as S import Data.Text qualified as T @@ -40,6 +41,7 @@ type SwaggerDocsAPIBase = SwaggerSchemaUI "swagger-ui" "swagger.json" type VersionedSwaggerDocsAPI = "api" :> Header VersionHeader VersionNumber :> SwaggerDocsAPIBase +type ServiceSwaggerDocsAPIBase :: Symbol -> Kind.Type type ServiceSwaggerDocsAPIBase service = SwaggerSchemaUI service (AppendSymbol service "-swagger.json") type VersionedSwaggerDocsAPIBase service = Header VersionHeader VersionNumber :> ServiceSwaggerDocsAPIBase service diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index 11dababb74b..cb687c41bea 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -123,9 +123,7 @@ mkEnv lgr opts emailOpts mgr = do mkAwsEnv g ses dyn sqs = do baseEnv <- AWS.newEnv AWS.discover - <&> maybe id AWS.configureService ses - <&> maybe id AWS.configureService dyn - <&> AWS.configureService sqs + <&> AWS.configureService sqs . maybe id AWS.configureService dyn . maybe id AWS.configureService ses pure $ baseEnv { AWS.logger = awsLogger g, @@ -230,7 +228,7 @@ sendMail m = do ^. AWS.serviceError_status == status400 && "Invalid domain name" - `Text.isPrefixOf` AWS.toText (se ^. AWS.serviceError_code) -> + `Text.isPrefixOf` AWS.toText (se ^. AWS.serviceError_code) -> throwM SESInvalidDomain _ -> throwM (GeneralError x) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index f5ecdff2ae2..1992e2a2f51 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -197,16 +197,18 @@ pendingActivationCleanup = do ) API.deleteUsersNoVerify $ - catMaybes - ( uids <&> \(isExpired, isPendingInvitation, uid) -> + mapMaybe + ( \(isExpired, isPendingInvitation, uid) -> if isExpired && isPendingInvitation then Just uid else Nothing ) + uids liftSem . UsersPendingActivationStore.removeMultiple $ - catMaybes - ( uids <&> \(isExpired, _isPendingInvitation, uid) -> + mapMaybe + ( \(isExpired, _isPendingInvitation, uid) -> if isExpired then Just uid else Nothing ) + uids threadDelayRandom where diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 160894c29c6..eeec7fe8d9a 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -49,7 +49,7 @@ ensurePermissions u t perms = do throwStd insufficientTeamPermissions where check :: Maybe TeamMember -> Bool - check (Just m) = and $ hasPermission m <$> perms + check (Just m) = all (hasPermission m) perms check Nothing = False -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). @@ -64,5 +64,5 @@ ensurePermissionToAddUser u t inviteePerms = do check :: Maybe TeamMember -> Bool check (Just inviter) = hasPermission inviter AddTeamMember - && and (mayGrantPermission inviter <$> Set.toList (inviteePerms ^. self)) + && all (mayGrantPermission inviter) (Set.toList (inviteePerms ^. self)) check Nothing = False diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 161902c4bc7..5f64598542d 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -64,7 +64,7 @@ createPopulatedBindingTeamWithNamesAndHandles :: Int -> m (TeamId, User, [User]) createPopulatedBindingTeamWithNamesAndHandles brig numMembers = do - names <- forM [1 .. numMembers] $ const randomName + names <- replicateM numMembers randomName (tid, owner, mems) <- createPopulatedBindingTeamWithNames brig names membersWithHandle <- mapM (setRandomHandle brig) mems ownerWithHandle <- setRandomHandle brig owner @@ -76,7 +76,7 @@ createPopulatedBindingTeam :: Int -> m (TeamId, UserId, [User]) createPopulatedBindingTeam brig numMembers = do - names <- forM [1 .. numMembers] $ const randomName + names <- replicateM numMembers randomName (tid, owner, others) <- createPopulatedBindingTeamWithNames brig names pure (tid, userId owner, others) diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index a1b0b8cd6b4..01c1dc64ccd 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -165,7 +165,7 @@ check :: [Status] -> Request -> Request check allowed r = r { Http.checkResponse = \rq rs -> - when (responseStatus rs `notElem` allowed) $ + unless (responseStatus rs `elem` allowed) $ let ex = StatusCodeException (rs {responseBody = ()}) mempty in throwM $ HttpExceptionRequest rq ex } diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index eff357a58a2..0874f6771d3 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -1700,7 +1700,9 @@ testSelfConversationList isBelowV3 = do responseJsonError =<< listEndpoint u Nothing (Just 100) ) Nothing $ guard . isMLSSelf u <$> mtpResults convIds + pure . getAlt $ + foldMap (Alt . guard . isMLSSelf u) $ + mtpResults convIds getConvPageV2 u s c = do g <- view tsUnversionedGalley diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index d9efba2945c..f3580150100 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -33,6 +33,7 @@ import Brig.Types.Intra (UserSet (..)) import Brig.Types.Test.Arbitrary () import Brig.Types.User.Event qualified as Ev import Cassandra.Exec qualified as Cql +import Control.Category ((>>>)) import Control.Concurrent.Chan import Control.Lens hiding ((#)) import Data.Id @@ -723,13 +724,14 @@ testOldClientsBlockDeviceHandshake = do approveLegalHoldDevice (Just defPassword) uid uid tid !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid tid liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - getInternalClientsFull (UserSet $ Set.fromList [uid]) - <&> userClientsFull - <&> Map.elems - <&> Set.unions - <&> Set.toList - <&> (\[x] -> x) - <&> clientId + getInternalClientsFull (UserSet $ Set.singleton uid) + <&> do + userClientsFull + >>> Map.elems + >>> Set.unions + >>> Set.toList + >>> head + >>> clientId putLHWhitelistTeam tid !!! const 200 === statusCode @@ -804,14 +806,14 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect liftIO $ assertEqual "approving should change status" (if approveLH then UserLegalHoldEnabled else UserLegalHoldPending) userStatus if approveLH then - getInternalClientsFull (UserSet $ Set.fromList [legalholder]) - <&> userClientsFull - <&> Map.elems - <&> Set.unions - <&> Set.toList - <&> (\[x] -> x) - <&> clientId - <&> Just + getInternalClientsFull (UserSet $ Set.singleton legalholder) + <&> do + userClientsFull + >>> Map.elems + >>> Set.unions + >>> Set.toList + >>> listToMaybe + >>> fmap clientId else pure Nothing doDisableLH :: HasCallStack => TestM () @@ -1127,13 +1129,14 @@ testClaimKeys testcase = do approveLegalHoldDevice (Just defPassword) uid uid team !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid team liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - getInternalClientsFull (UserSet $ Set.fromList [uid]) - <&> userClientsFull - <&> Map.elems - <&> Set.unions - <&> Set.toList - <&> (\[x] -> x) - <&> clientId + getInternalClientsFull (UserSet $ Set.singleton uid) + <&> do + userClientsFull + >>> Map.elems + >>> Set.unions + >>> Set.toList + >>> head + >>> clientId let makePeerClient :: TestM () makePeerClient = case testcase of diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 6096d1d795d..d5884a6e595 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -33,6 +33,7 @@ import Brig.Types.Intra (UserSet (..)) import Brig.Types.Test.Arbitrary () import Brig.Types.User.Event qualified as Ev import Cassandra.Exec qualified as Cql +import Control.Category ((>>>)) import Control.Concurrent.Chan import Control.Lens import Data.Id @@ -647,13 +648,14 @@ testOldClientsBlockDeviceHandshake = do approveLegalHoldDevice (Just defPassword) uid uid tid !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid tid liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - getInternalClientsFull (UserSet $ Set.fromList [uid]) - <&> userClientsFull - <&> Map.elems - <&> Set.unions - <&> Set.toList - <&> (\[x] -> x) - <&> clientId + getInternalClientsFull (UserSet $ Set.singleton uid) + <&> do + userClientsFull + >>> Map.elems + >>> Set.unions + >>> Set.toList + >>> head + >>> clientId withDummyTestServiceForTeam' legalholder tid $ \_ _chan -> do grantConsent tid legalholder @@ -724,13 +726,14 @@ testClaimKeys testcase = do approveLegalHoldDevice (Just defPassword) uid uid team !!! testResponse 200 Nothing UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid team liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - getInternalClientsFull (UserSet $ Set.fromList [uid]) - <&> userClientsFull - <&> Map.elems - <&> Set.unions - <&> Set.toList - <&> (\[x] -> x) - <&> clientId + getInternalClientsFull (UserSet $ Set.singleton uid) + <&> do + userClientsFull + >>> Map.elems + >>> Set.unions + >>> Set.toList + >>> head + >>> clientId let makePeerClient :: TestM () makePeerClient = case testcase of diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index ab8dd27c69c..9de09390334 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -64,6 +64,7 @@ import Amazonka.SNS.Lens qualified as SNS import Amazonka.SQS qualified as SQS import Amazonka.SQS.Lens qualified as SQS import Amazonka.SQS.Types +import Control.Category ((>>>)) import Control.Error hiding (err, isRight) import Control.Lens hiding ((.=)) import Control.Monad.Catch @@ -164,8 +165,9 @@ mkEnv lgr opts mgr = do mkAwsEnv g sqs sns = do baseEnv <- AWS.newEnv AWS.discover - <&> AWS.configureService sqs - <&> AWS.configureService (sns & set AWS.service_timeout (Just (AWS.Seconds 5))) + <&> do + AWS.configureService sqs + >>> AWS.configureService (sns & set AWS.service_timeout (Just (AWS.Seconds 5))) pure $ baseEnv { AWS.logger = awsLogger g, diff --git a/services/gundeck/src/Gundeck/Push/Websocket.hs b/services/gundeck/src/Gundeck/Push/Websocket.hs index 0c9ebc51a3d..c6a9190aba0 100644 --- a/services/gundeck/src/Gundeck/Push/Websocket.hs +++ b/services/gundeck/src/Gundeck/Push/Websocket.hs @@ -381,7 +381,7 @@ send n pp = check r = r { Http.checkResponse = \rq rs -> - when (responseStatus rs `notElem` [status200, status410]) $ + unless (responseStatus rs `elem` [status200, status410]) $ let ex = StatusCodeException (rs {responseBody = ()}) mempty in throwM $ HttpExceptionRequest rq ex } diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 43a27b912da..56922274c00 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -845,7 +845,7 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do lift $ ST.runValidExternalIdBoth (\ma mb -> (&&) <$> ma <*> mb) - (\uref -> getUserByUrefUnsafe uref <&> (`elem` allowedValues) . fmap userId) + (fmap ((`elem` allowedValues) . fmap userId) . getUserByUrefUnsafe) (fmap (`elem` allowedValues) . getUserIdByScimExternalId tid) veid unless isGood $ diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 8e10682c2a3..a28d3f5ca60 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1464,7 +1464,7 @@ specAux = do . header "Z-User" (toByteString' $ if tryowner then owner else newmember) . expect2xx ) - parsedResp <- either (error . show) pure $ selfUser <$> Intra.parseResponse @SelfProfile "brig" rawResp + parsedResp <- either (error . show) (pure . selfUser) (Intra.parseResponse @SelfProfile "brig" rawResp) liftIO $ userTeam parsedResp `shouldSatisfy` isJust permses :: [Permissions] permses = diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 709a659088d..9c2d61e2f99 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -538,8 +538,7 @@ testCsvData tid owner uid mbeid mbsaml hasissuer = do decodeCSV :: Csv.FromNamedRecord a => LByteString -> [a] decodeCSV bstr = - either (error "could not decode csv") id $ - Csv.decodeByName bstr <&> (V.toList . snd) + either (error "could not decode csv") (V.toList . snd) (Csv.decodeByName bstr) testCreateUserWithPass :: TestSpar () testCreateUserWithPass = do diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index eeac183d19d..dbe3b5087cc 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -629,7 +629,7 @@ instance IsUser (WrappedScimUser SparTag) where maybeLocale = Just ( \u -> - case Scim.User.preferredLanguage (fromWrappedScimUser u) >>= (\l -> parseLanguage l <&> flip Locale Nothing) of + case Scim.User.preferredLanguage (fromWrappedScimUser u) >>= (fmap (flip Locale Nothing) . parseLanguage) of -- this should match the default user locale in brig options Nothing -> Just (Locale (Language EN) Nothing) Just l -> Just l diff --git a/tools/db/move-team/src/ParseSchema.hs b/tools/db/move-team/src/ParseSchema.hs index 7b01731ebee..eddeed20f30 100644 --- a/tools/db/move-team/src/ParseSchema.hs +++ b/tools/db/move-team/src/ParseSchema.hs @@ -113,7 +113,7 @@ createTable = do betweenBrackets $ catMaybes <$> ((Just <$> column) <|> (Nothing <$ primaryKeyAtEndOfColumns)) - `sepBy` lexeme "," + `sepBy` lexeme "," noise pure (CreateTable ks tn cols) diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs index 4c7525d041c..983d9875132 100644 --- a/tools/stern/test/integration/Util.hs +++ b/tools/stern/test/integration/Util.hs @@ -109,10 +109,10 @@ randomPhone = liftIO $ do pure $ fromMaybe (error "Invalid random phone#") phone randomEmailUser :: HasCallStack => TestM (UserId, Email) -randomEmailUser = randomUserProfile'' False False True <&> first ((.userId) . selfUser) <&> second fst +randomEmailUser = randomUserProfile'' False False True <&> bimap ((.userId) . selfUser) fst randomPhoneUser :: HasCallStack => TestM (UserId, Phone) -randomPhoneUser = randomUserProfile'' False False True <&> first ((.userId) . selfUser) <&> second snd +randomPhoneUser = randomUserProfile'' False False True <&> bimap ((.userId) . selfUser) snd randomEmailPhoneUser :: HasCallStack => TestM (UserId, (Email, Phone)) randomEmailPhoneUser = randomUserProfile'' False False True <&> first ((.userId) . selfUser)