[fix] apply changes asked for by Paolo and Akshay

- make code that was messed up by hlint easier to read
- add some documentation to the nix code

cabal.project

@@ -167,6 +167,13 @@ package zauth
 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

integration/test/Testlib/App.hs

@@ -42,14 +42,9 @@ readServiceConfig = readServiceConfig' . configName
 
 readServiceConfig' :: String -> App Value
 readServiceConfig' srvName = do
-  cfgFile <-
-    asks
-      ( ( \case
-            Nothing -> "/etc/wire" </> srvName </> "conf" </> (srvName <> ".yaml")
-            Just p -> p </> srvName </> (srvName <> ".integration.yaml")
-        )
-          . (.servicesCwdBase)
-      )
+  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

integration/test/Testlib/ModService.hs

@@ -397,14 +397,10 @@ startProcess' domain execName config = do
   tempFile <- liftIO $ writeTempFile "/tmp" (execName <> "-" <> domain <> "-" <> ".yaml") (cs $ Yaml.encode config)
 
   (cwd, exe) <-
-    asks
-      ( ( \case
-            Nothing -> (Nothing, execName)
-            Just dir ->
-              (Just (dir </> execName), "../../dist" </> execName)
-        )
-          . (.servicesCwdBase)
-      )
+    asks \env -> case env.servicesCwdBase of
+      Nothing -> (Nothing, execName)
+      Just dir ->
+        (Just (dir </> execName), "../../dist" </> execName)
 
   (_, Just stdoutHdl, Just stderrHdl, ph) <- liftIO $ createProcess (proc exe ["-c", tempFile]) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe}
   let prefix = "[" <> execName <> "@" <> domain <> "] "
@@ -549,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

integration/test/Testlib/Run.hs

@@ -112,14 +112,9 @@ createGlobalEnv cfg = do
     liftIO . runAppWithEnv env $ do
       config <- readServiceConfig Galley
       relPath <- config %. "settings.mlsPrivateKeyPaths.removal.ed25519" & asString
-      path <-
-        asks
-          ( ( \case
-                Nothing -> relPath
-                Just dir -> dir </> "galley" </> relPath
-            )
-              . ((.servicesCwdBase))
-          )
+      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

nix/haskell-pins.nix

@@ -224,6 +224,7 @@ let
       };
     };
 
+    # PR at https://github.com/google/ghc-source-gen/pull/102
     ghc-source-gen = {
       version = "0.4.4.0";
       src = pkgs.fetchFromGitHub {

nix/manual-overrides.nix

@@ -1,4 +1,4 @@
-{ libsodium, protobuf, hlib, mls-test-cli, fetchpatch, pkgs }:
+{ 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: {

nix/wire-server.nix

@@ -523,7 +523,7 @@ in
   haskellPackages = hPkgs localModsEnableAll;
   haskellPackagesUnoptimizedNoDocs = hPkgs localModsOnlyTests;
   allLocalPackages = pkgs.symlinkJoin {
-    name = "all-local-packages"; 
+    name = "all-local-packages";
     paths = map (e: (hPkgs localModsEnableAll).${e}) wireServerPackages;
   };
 

services/galley/test/integration/API/MLS.hs

@@ -35,6 +35,7 @@ import Data.Json.Util hiding ((#))
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.List1 hiding (head)
 import Data.Map qualified as Map
+import Data.Monoid (Alt (Alt, getAlt))
 import Data.Qualified
 import Data.Range
 import Data.Set qualified as Set
@@ -1700,7 +1701,9 @@ testSelfConversationList isBelowV3 = do
         responseJsonError
           =<< listEndpoint u Nothing (Just 100)
             <!! const 200 === statusCode
-      pure $ foldr ((<|>) . guard . isMLSSelf u) Nothing (mtpResults convIds)
+      pure . getAlt $
+        foldMap (Alt . guard . isMLSSelf u) $
+          mtpResults convIds
 
     getConvPageV2 u s c = do
       g <- view tsUnversionedGalley

services/galley/test/integration/API/Teams/LegalHold.hs

@@ -724,7 +724,12 @@ testOldClientsBlockDeviceHandshake = do
         UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid tid
         liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus
         getInternalClientsFull (UserSet $ Set.singleton uid)
-          <&> clientId . head . Set.toList . Set.unions . Map.elems . userClientsFull
+          <&> userClientsFull
+          >>> Map.elems
+          >>> Set.unions
+          >>> Set.toList
+          >>> head
+          >>> clientId
 
   putLHWhitelistTeam tid !!! const 200 === statusCode
 
@@ -800,7 +805,12 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect
         if approveLH
           then
             getInternalClientsFull (UserSet $ Set.singleton legalholder)
-              <&> fmap clientId . listToMaybe . Set.toList . Set.unions . Map.elems . userClientsFull
+              <&> userClientsFull
+              >>> Map.elems
+              >>> Set.unions
+              >>> Set.toList
+              >>> listToMaybe
+              >>> fmap clientId
           else pure Nothing
 
       doDisableLH :: HasCallStack => TestM ()
@@ -1117,7 +1127,12 @@ testClaimKeys testcase = do
         UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid team
         liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus
         getInternalClientsFull (UserSet $ Set.singleton uid)
-          <&> clientId . head . Set.toList . Set.unions . Map.elems . userClientsFull
+          <&> userClientsFull
+          >>> Map.elems
+          >>> Set.unions
+          >>> Set.toList
+          >>> head
+          >>> clientId
 
   let makePeerClient :: TestM ()
       makePeerClient = case testcase of

services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs

@@ -648,7 +648,12 @@ testOldClientsBlockDeviceHandshake = do
         UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid tid
         liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus
         getInternalClientsFull (UserSet $ Set.singleton uid)
-          <&> clientId . head . Set.toList . Set.unions . Map.elems . userClientsFull
+          <&> userClientsFull
+          >>> Map.elems
+          >>> Set.unions
+          >>> Set.toList
+          >>> head
+          >>> clientId
 
   withDummyTestServiceForTeam' legalholder tid $ \_ _chan -> do
     grantConsent tid legalholder
@@ -720,7 +725,12 @@ testClaimKeys testcase = do
         UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped uid team
         liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus
         getInternalClientsFull (UserSet $ Set.singleton uid)
-          <&> clientId . head . Set.toList . Set.unions . Map.elems . userClientsFull
+          <&> userClientsFull
+          >>> Map.elems
+          >>> Set.unions
+          >>> Set.toList
+          >>> head
+          >>> clientId
 
   let makePeerClient :: TestM ()
       makePeerClient = case testcase of

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
@@ -163,7 +164,9 @@ mkEnv lgr opts mgr = do
     mkEndpoint svc e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) svc
     mkAwsEnv g sqs sns = do
       baseEnv <-
-        AWS.newEnv AWS.discover <&> AWS.configureService (sns & set AWS.service_timeout (Just (AWS.Seconds 5))) . AWS.configureService sqs
+        AWS.newEnv AWS.discover
+          <&> AWS.configureService sqs
+          >>> AWS.configureService (sns & set AWS.service_timeout (Just (AWS.Seconds 5)))
       pure $
         baseEnv
           { AWS.logger = awsLogger g,