Galley polysemy (5/5) - Final cleanup

changelog.d/5-internal/polysemy-monad

@@ -0,0 +1 @@
+Replace Galley monad with polysemy's Sem throughout Galley

hack/bin/split-member-constraints.py

@@ -0,0 +1,33 @@
+#!/usr/bin/env python3
+
+# This script splits all polysemy `Members` constraints into multiple `Member`
+# constraints. The intended usage is to find redundant effects in function
+# signatures.
+#
+# Example usage:
+#
+# $ git status # make sure working directory is clean
+# $ fd -ehs services/galley/src -x hack/bin/split-member-constraints.py '{}' '{}'
+# $ WIRE_STACK_OPTIONS="$WIRE_STACK_OPTIONS --ghc-options='-Wredundant-constraints -Wwarn'" make
+# $ git reset --hard
+#
+# Now you can scroll back to find a list of redundant constraint warnings and
+# fix them, but note that the line numbers are no longer accurate.
+
+import re
+import sys
+
+def make_constraint(e):
+    e = e.strip()
+    if ' ' in e:
+        e = '(' + e + ')'
+    return f'Member {e} r'
+
+def f(m):
+    effects = re.split(r'\s*,\s*', m.group(1))
+    constraints = ', '.join(make_constraint(e) for e in effects)
+    return f'({constraints})'
+
+code = open(sys.argv[1]).read()
+print(re.sub(r"Members\s+'\[\s*([^\]]*)\s*\]\s+r", f, code, flags=re.MULTILINE),
+    file=open(sys.argv[2], 'w'), end='')

libs/wire-api/src/Wire/API/Routes/Public.hs

@@ -18,43 +18,105 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
-module Wire.API.Routes.Public where
+module Wire.API.Routes.Public
+  ( -- * nginz combinators
+    ZUser,
+    ZLocalUser,
+    ZConn,
+    ZOptUser,
+    ZOptConn,
+
+    -- * Swagger combinators
+    OmitDocs,
+  )
+where
 
 import Control.Lens ((<>~))
+import Data.Domain
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Id as Id
+import Data.Kind
 import Data.Metrics.Servant
+import Data.Qualified
 import Data.Swagger
 import GHC.Base (Symbol)
 import GHC.TypeLits (KnownSymbol)
 import Imports hiding (All, head)
 import Servant hiding (Handler, JSON, addHeader, respond)
-import Servant.API.Modifiers (FoldLenient, FoldRequired)
+import Servant.API.Modifiers
 import Servant.Swagger (HasSwagger (toSwagger))
 
+mapRequestArgument ::
+  forall mods a b.
+  (SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
+  (a -> b) ->
+  RequestArgument mods a ->
+  RequestArgument mods b
+mapRequestArgument f x =
+  case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods)) of
+    (STrue, STrue) -> fmap f x
+    (STrue, SFalse) -> f x
+    (SFalse, STrue) -> (fmap . fmap) f x
+    (SFalse, SFalse) -> fmap f x
+
 -- This type exists for the special 'HasSwagger' and 'HasServer' instances. It
 -- shows the "Authorization" header in the swagger docs, but expects the
 -- "Z-Auth" header in the server. This helps keep the swagger docs usable
 -- through nginz.
-data ZUserType = ZAuthUser | ZAuthConn
+data ZType
+  = -- | Get a 'UserID' from the Z-Auth header
+    ZAuthUser
+  | -- | Same as 'ZAuthUser', but return a 'Local UserId' using the domain in the context
+    ZLocalAuthUser
+  | -- | Get a 'ConnId' from the Z-Conn header
+    ZAuthConn
+
+class
+  (KnownSymbol (ZHeader ztype), FromHttpApiData (ZParam ztype)) =>
+  IsZType (ztype :: ZType)
+  where
+  type ZHeader ztype :: Symbol
+  type ZParam ztype :: *
+  type ZQualifiedParam ztype :: *
+  type ZConstraint ztype (ctx :: [*]) :: Constraint
+
+  qualifyZParam :: ZConstraint ztype ctx => Context ctx -> ZParam ztype -> ZQualifiedParam ztype
+
+instance IsZType 'ZLocalAuthUser where
+  type ZHeader 'ZLocalAuthUser = "Z-User"
+  type ZParam 'ZLocalAuthUser = UserId
+  type ZQualifiedParam 'ZLocalAuthUser = Local UserId
+  type ZConstraint 'ZLocalAuthUser ctx = HasContextEntry ctx Domain
+
+  qualifyZParam ctx = toLocalUnsafe (getContextEntry ctx)
+
+instance IsZType 'ZAuthUser where
+  type ZHeader 'ZAuthUser = "Z-User"
+  type ZParam 'ZAuthUser = UserId
+  type ZQualifiedParam 'ZAuthUser = UserId
+  type ZConstraint 'ZAuthUser ctx = ()
 
-type family ZUserHeader (ztype :: ZUserType) :: Symbol where
-  ZUserHeader 'ZAuthUser = "Z-User"
-  ZUserHeader 'ZAuthConn = "Z-Connection"
+  qualifyZParam _ = id
 
-type family ZUserParam (ztype :: ZUserType) :: * where
-  ZUserParam 'ZAuthUser = UserId
-  ZUserParam 'ZAuthConn = ConnId
+instance IsZType 'ZAuthConn where
+  type ZHeader 'ZAuthConn = "Z-Connection"
+  type ZParam 'ZAuthConn = ConnId
+  type ZQualifiedParam 'ZAuthConn = ConnId
+  type ZConstraint 'ZAuthConn ctx = ()
 
-data ZAuthServant (ztype :: ZUserType) (opts :: [*])
+  qualifyZParam _ = id
+
+data ZAuthServant (ztype :: ZType) (opts :: [*])
 
 type InternalAuthDefOpts = '[Servant.Required, Servant.Strict]
 
 type InternalAuth ztype opts =
   Header'
     opts
-    (ZUserHeader ztype)
-    (ZUserParam ztype)
+    (ZHeader ztype)
+    (ZParam ztype)
+
+type ZLocalUser = ZAuthServant 'ZLocalAuthUser InternalAuthDefOpts
 
 type ZUser = ZAuthServant 'ZAuthUser InternalAuthDefOpts
 
@@ -76,24 +138,33 @@ instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthUser _opts :> api) whe
             _securitySchemeDescription = Just "Must be a token retrieved by calling 'POST /login' or 'POST /access'. It must be presented in this format: 'Bearer \\<token\\>'."
           }
 
+instance HasSwagger api => HasSwagger (ZAuthServant 'ZLocalAuthUser opts :> api) where
+  toSwagger _ = toSwagger (Proxy @(ZAuthServant 'ZAuthUser opts :> api))
+
 instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthConn _opts :> api) where
   toSwagger _ = toSwagger (Proxy @api)
 
 instance
-  ( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
+  ( IsZType ztype,
+    HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
+    ZConstraint ztype ctx,
     SBoolI (FoldLenient opts),
     SBoolI (FoldRequired opts),
-    HasServer api ctx,
-    KnownSymbol (ZUserHeader ztype),
-    FromHttpApiData (ZUserParam ztype)
+    HasServer api ctx
   ) =>
   HasServer (ZAuthServant ztype opts :> api) ctx
   where
-  type ServerT (ZAuthServant ztype opts :> api) m = ServerT (InternalAuth ztype opts :> api) m
+  type
+    ServerT (ZAuthServant ztype opts :> api) m =
+      RequestArgument opts (ZQualifiedParam ztype) -> ServerT api m
 
-  route _ = Servant.route (Proxy @(InternalAuth ztype opts :> api))
-  hoistServerWithContext _ pc nt s =
-    Servant.hoistServerWithContext (Proxy @(InternalAuth ztype opts :> api)) pc nt s
+  route _ ctx subserver =
+    Servant.route
+      (Proxy @(InternalAuth ztype opts :> api))
+      ctx
+      (fmap (. mapRequestArgument @opts (qualifyZParam @ztype ctx)) subserver)
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
 instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where
   getRoutes = getRoutes @api