Polysemy error handling (#2239)

* Introduce static error machinery

* Migrate galley to static errors

* Migrate brig to static errors

* Migrate cargohold to static errors

* Remove ErrorDescription module

changelog.d/3-bug-fixes/polysemy-errors-4

@@ -0,0 +1 @@
+Conversation rename endpoints now return 204 instead of 404 when the conversation name is unchanged

changelog.d/5-internal/improved-can-throw

@@ -0,0 +1 @@
+The `CanThrow` combinator can now be used to set the corresponding error effects in polysemy handlers.

changelog.d/5-internal/polysemy-error-handling

@@ -0,0 +1 @@
+Most error effects in Galley are now defined at the granularity of single error values. For example, a handler throwing `ConvNotFound` will now directly declare `ConvNotFound` (as a promoted constructor) among its error effects, instead of the generic `ConversationError` that was used before. Correspondingly, all such fine-grained Galley errors have been moved to wire-api as constructors of a single enumerated type `GalleyError`, and similarly for Brig, Cannon and Cargohold.

docs/developer/servant.md

@@ -25,9 +25,9 @@ This is an alternative to `UVerb`, designed to prevent any HTTP-specific informa
 
 ## `CanThrow`
 
-This can be used to add an error response to the Swagger documentation. It currently does nothing to the Servant API itself, but this might change in the future, as polysemy is introduced in more services and integrated with Servant. The argument of `CanThrow` can be an `ErrorDescription` type, which is a type-level representation of a possible error.
+This can be used to add an error response to the Swagger documentation. In services that use polysemy for error handling (currently only Galley), it also adds a corresponding error effect to the type of the handler. The argument of `CanThrow` can be of a custom kind, usually a service-specific error kind (such as `GalleyError`, `BrigError`, etc...), but kind `*` can also be used.
 
-Note thtat `ErrorDescription` types can also be used directly as `MultiVerb` responses. This is useful for handlers that can return errors as part of their return type, instead of simply throwing them as IO exceptions. If an error is part of `MultiVerb`, there is no need to also report it with `CanThrow`.
+Note that error types can also be turned into `MultiVerb` responses using the `ErrorResponse` combinator. This is useful for handlers that can return errors as part of their return type, instead of simply throwing them as IO exceptions or using polysemy. If an error is part of `MultiVerb`, there is no need to also report it with `CanThrow`.
 
 ## `QualifiedCapture`
 

libs/galley-types/src/Galley/Types/Teams.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -93,6 +94,7 @@ module Galley.Types.Teams
     self,
     copy,
     Perm (..),
+    SPerm (..),
     permToInt,
     permsToInt,
     intToPerm,
@@ -142,6 +144,7 @@ import qualified Data.Set as Set
 import Data.String.Conversions (cs)
 import Imports
 import Test.QuickCheck (Arbitrary)
+import Wire.API.Error.Galley
 import Wire.API.Event.Team
 import Wire.API.Team
 import Wire.API.Team.Conversation
@@ -430,6 +433,8 @@ roleHiddenPermissions role = HiddenPermissions p p
 
 -- | See Note [hidden team roles]
 class IsPerm perm where
+  type PermError (e :: perm) :: GalleyError
+
   roleHasPerm :: Role -> perm -> Bool
   roleGrantsPerm :: Role -> perm -> Bool
   hasPermission :: TeamMember -> perm -> Bool
@@ -438,12 +443,16 @@ class IsPerm perm where
   mayGrantPermission tm perm = maybe False (`roleGrantsPerm` perm) . permissionsRole $ tm ^. permissions
 
 instance IsPerm Perm where
+  type PermError p = 'MissingPermission ('Just p)
+
   roleHasPerm r p = p `Set.member` (rolePermissions r ^. self)
   roleGrantsPerm r p = p `Set.member` (rolePermissions r ^. copy)
   hasPermission tm p = p `Set.member` (tm ^. permissions . self)
   mayGrantPermission tm p = p `Set.member` (tm ^. permissions . copy)
 
 instance IsPerm HiddenPerm where
+  type PermError p = OperationDenied
+
   roleHasPerm r p = p `Set.member` (roleHiddenPermissions r ^. hself)
   roleGrantsPerm r p = p `Set.member` (roleHiddenPermissions r ^. hcopy)
 

libs/schema-profunctor/src/Data/Schema.hs

@@ -103,6 +103,7 @@ import qualified Data.Swagger.Internal as S
 import qualified Data.Text as T
 import qualified Data.Vector as V
 import Imports hiding (Product)
+import Numeric.Natural
 
 type Declare = S.Declare (S.Definitions S.Schema)
 
@@ -501,6 +502,9 @@ instance With Text where
 instance With Integer where
   with _ = (A.parseJSON >=>)
 
+instance With Natural where
+  with _ = (A.parseJSON >=>)
+
 instance With Bool where
   with = A.withBool
 
@@ -770,6 +774,9 @@ instance HasEnum Text NamedSwaggerDoc where
 instance HasEnum Integer NamedSwaggerDoc where
   mkEnum = mkSwaggerEnum S.SwaggerInteger
 
+instance HasEnum Natural NamedSwaggerDoc where
+  mkEnum = mkSwaggerEnum S.SwaggerInteger
+
 instance HasEnum Bool NamedSwaggerDoc where
   mkEnum = mkSwaggerEnum S.SwaggerBoolean
 

libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs

@@ -33,8 +33,8 @@ import Wire.API.Conversation.Protocol
 import Wire.API.Conversation.Role (RoleName)
 import Wire.API.Federation.API.Common
 import Wire.API.Federation.Endpoint
-import Wire.API.Message (MessageNotSent, MessageSendingStatus, PostOtrResponse, Priority)
-import Wire.API.User.Client (UserClientMap)
+import Wire.API.Message
+import Wire.API.Routes.Public.Galley
 import Wire.API.Util.Aeson (CustomEncoded (..))
 
 -- FUTUREWORK: data types, json instances, more endpoints. See

libs/wire-api-federation/src/Wire/API/Federation/Error.hs

@@ -87,6 +87,7 @@ import qualified Network.HTTP2.Frame as HTTP2
 import Network.TLS
 import qualified Network.Wai.Utilities.Error as Wai
 import Servant.Client
+import Wire.API.Error
 
 -- | Transport-layer errors in federator client.
 data FederatorClientHTTP2Error
@@ -143,6 +144,9 @@ data FederationError
 
 instance Exception FederationError
 
+instance APIError FederationError where
+  toWai = federationErrorToWai
+
 federationErrorToWai :: FederationError -> Wai.Error
 federationErrorToWai FederationNotImplemented = federationNotImplemented
 federationErrorToWai FederationNotConfigured = federationNotConfigured

libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MessageSendResponse.hs

@@ -25,6 +25,7 @@ import GHC.Exts (IsList (fromList))
 import Imports
 import Wire.API.Federation.API.Galley (MessageSendResponse (..))
 import Wire.API.Message
+import Wire.API.Routes.Public.Galley
 import Wire.API.User.Client (QualifiedUserClients (..))
 
 missing :: QualifiedUserClients

libs/wire-api/package.yaml

@@ -65,6 +65,7 @@ library:
   - mime >=0.4
   - mtl
   - pem >=0.2
+  - polysemy
   - protobuf >=0.2
   - proto-lens
   - QuickCheck >=2.14

libs/wire-api/src/Wire/API/Asset.hs

@@ -85,12 +85,11 @@ import qualified Data.Text.Encoding as T
 import qualified Data.Text.Encoding.Error as T
 import Data.Time.Clock
 import qualified Data.UUID as UUID
-import GHC.TypeLits
 import Imports
 import Servant
 import URI.ByteString
 import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..))
-import Wire.API.ErrorDescription
+import Wire.API.Error
 import Wire.API.Routes.MultiVerb
 
 --------------------------------------------------------------------------------
@@ -408,14 +407,13 @@ data LocalOrRemoteAsset
   | RemoteAsset (SourceIO ByteString)
 
 instance
-  ( ResponseType r0 ~ ErrorDescription code label desc,
-    ResponseType r1 ~ AssetLocation Absolute,
+  ( ResponseType r1 ~ AssetLocation Absolute,
     ResponseType r2 ~ SourceIO ByteString,
-    KnownSymbol desc
+    KnownError (MapError e)
   ) =>
-  AsUnion '[r0, r1, r2] (Maybe LocalOrRemoteAsset)
+  AsUnion '[ErrorResponse e, r1, r2] (Maybe LocalOrRemoteAsset)
   where
-  toUnion Nothing = Z (I mkErrorDescription)
+  toUnion Nothing = Z (I (dynError @(MapError e)))
   toUnion (Just (LocalAsset loc)) = S (Z (I loc))
   toUnion (Just (RemoteAsset asset)) = S (S (Z (I asset)))
 

libs/wire-api/src/Wire/API/Conversation/Action.hs

@@ -25,6 +25,8 @@ module Wire.API.Conversation.Action
     SomeConversationAction (..),
     conversationActionToEvent,
     conversationActionPermission,
+    ConversationActionPermission,
+    sConversationActionPermission,
   )
 where
 
@@ -159,16 +161,20 @@ instance Arbitrary SomeConversationAction where
       SomeSing sb -> do
         $(sCases ''ConversationActionTag [|sb|] [|SomeConversationAction sb <$> arbitrary|])
 
-conversationActionPermission :: ConversationActionTag -> Action
-conversationActionPermission ConversationJoinTag = AddConversationMember
-conversationActionPermission ConversationLeaveTag = LeaveConversation
-conversationActionPermission ConversationRemoveMembersTag = RemoveConversationMember
-conversationActionPermission ConversationMemberUpdateTag = ModifyOtherConversationMember
-conversationActionPermission ConversationDeleteTag = DeleteConversation
-conversationActionPermission ConversationRenameTag = ModifyConversationName
-conversationActionPermission ConversationMessageTimerUpdateTag = ModifyConversationMessageTimer
-conversationActionPermission ConversationReceiptModeUpdateTag = ModifyConversationReceiptMode
-conversationActionPermission ConversationAccessDataTag = ModifyConversationAccess
+$( singletons
+     [d|
+       conversationActionPermission :: ConversationActionTag -> Action
+       conversationActionPermission ConversationJoinTag = AddConversationMember
+       conversationActionPermission ConversationLeaveTag = LeaveConversation
+       conversationActionPermission ConversationRemoveMembersTag = RemoveConversationMember
+       conversationActionPermission ConversationMemberUpdateTag = ModifyOtherConversationMember
+       conversationActionPermission ConversationDeleteTag = DeleteConversation
+       conversationActionPermission ConversationRenameTag = ModifyConversationName
+       conversationActionPermission ConversationMessageTimerUpdateTag = ModifyConversationMessageTimer
+       conversationActionPermission ConversationReceiptModeUpdateTag = ModifyConversationReceiptMode
+       conversationActionPermission ConversationAccessDataTag = ModifyConversationAccess
+       |]
+ )
 
 conversationActionToEvent ::
   forall tag.

libs/wire-api/src/Wire/API/Conversation/Role.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 -- This file is part of the Wire Server implementation.
@@ -38,7 +39,18 @@ module Wire.API.Conversation.Role
 
     -- * Action
     Action (..),
+    SAction (..),
     Actions (..),
+    ActionName,
+    AddConversationMemberSym0,
+    RemoveConversationMemberSym0,
+    ModifyConversationNameSym0,
+    ModifyConversationMessageTimerSym0,
+    ModifyConversationReceiptModeSym0,
+    ModifyConversationAccessSym0,
+    ModifyOtherConversationMemberSym0,
+    LeaveConversationSym0,
+    DeleteConversationSym0,
 
     -- * helpers
     isValidRoleName,
@@ -61,13 +73,14 @@ import qualified Data.Aeson.TH as A
 import Data.Attoparsec.Text
 import Data.ByteString.Conversion
 import Data.Hashable
-import Data.Proxy (Proxy (..))
 import Data.Range (fromRange, genRangeText)
 import Data.Schema
 import qualified Data.Set as Set
+import Data.Singletons.TH
 import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
 import qualified Deriving.Swagger as S
+import GHC.TypeLits
 import Imports
 import qualified Test.QuickCheck as QC
 import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))
@@ -267,6 +280,17 @@ data Action
   deriving (Arbitrary) via (GenericUniform Action)
   deriving (S.ToSchema) via (S.CustomSwagger '[S.ConstructorTagModifier S.CamelToSnake] Action)
 
+type family ActionName (a :: Action) :: Symbol where
+  ActionName 'AddConversationMember = "add_conversation_member"
+  ActionName 'RemoveConversationMember = "remove_conversation_member"
+  ActionName 'ModifyConversationName = "modify_conversation_name"
+  ActionName 'ModifyConversationMessageTimer = "modify_conversation_message_timer"
+  ActionName 'ModifyConversationReceiptMode = "modify_conversation_receipt_mode"
+  ActionName 'ModifyConversationAccess = "modify_conversation_access"
+  ActionName 'ModifyOtherConversationMember = "modify_other_conversation_member"
+  ActionName 'LeaveConversation = "leave_conversation"
+  ActionName 'DeleteConversation = "delete_conversation"
+
 typeConversationRoleAction :: Doc.DataType
 typeConversationRoleAction =
   Doc.string $
@@ -283,3 +307,5 @@ typeConversationRoleAction =
       ]
 
 A.deriveJSON A.defaultOptions {A.constructorTagModifier = A.camelTo2 '_'} ''Action
+
+$(genSingletons [''Action])