Introduce VersionNumber newtype. (#3075)

* Introduce VersionNumber newtype.

See `/libs/wire-api/test/unit/Test/Wire/API/Routes/Version.hs` for explanation.

Co-authored-by: Sven Tennie <[email protected]>
Co-authored-by: Paolo Capriotti <[email protected]>
Co-authored-by: Stefan Matting <[email protected]>
Co-authored-by: Leif Battermann <[email protected]>

changelog.d/5-internal/play-with-version-types

@@ -0,0 +1 @@
+Introduce VersionNumber newtype (see `/libs/wire-api/src/Wire/API/Routes/Version.hs` for explanation)

libs/wire-api/default.nix

@@ -43,6 +43,8 @@
 , hex
 , hostname-validate
 , hscim
+, hspec
+, hspec-wai
 , http-api-data
 , http-media
 , http-types
@@ -87,6 +89,7 @@
 , tagged
 , tasty
 , tasty-expected-failure
+, tasty-hspec
 , tasty-hunit
 , tasty-quickcheck
 , text
@@ -223,6 +226,9 @@ mkDerivation {
     filepath
     hex
     hscim
+    hspec
+    hspec-wai
+    http-types
     imports
     iso3166-country-codes
     iso639
@@ -238,11 +244,13 @@ mkDerivation {
     saml2-web-sso
     schema-profunctor
     servant
+    servant-server
     servant-swagger-ui
     string-conversions
     swagger2
     tasty
     tasty-expected-failure
+    tasty-hspec
     tasty-hunit
     tasty-quickcheck
     text
@@ -253,6 +261,7 @@ mkDerivation {
     uri-bytestring
     uuid
     vector
+    wai
     wire-message-proto-lens
   ];
   license = lib.licenses.agpl3Only;

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TemplateHaskell #-}
 -- This file is part of the Wire Server implementation.
@@ -28,23 +29,23 @@ module Wire.API.Routes.Version
 
     -- * Version
     Version (..),
+    VersionNumber (..),
     supportedVersions,
     developmentVersions,
-    readVersionNumber,
-    mkVersion,
-    toPathComponent,
 
     -- * Servant combinators
     Until,
     From,
   )
 where
 
+import Control.Error (note)
 import Control.Lens ((?~))
 import Data.Aeson (FromJSON, ToJSON (..))
 import qualified Data.Aeson as Aeson
 import Data.Bifunctor
-import Data.ByteString.Conversion (ToByteString (builder))
+import qualified Data.Binary.Builder as Builder
+import Data.ByteString.Conversion (ToByteString (builder), toByteString')
 import qualified Data.ByteString.Lazy as LBS
 import Data.Domain
 import Data.Schema
@@ -57,52 +58,87 @@ import Servant
 import Servant.Swagger
 import Wire.API.Routes.Named
 import Wire.API.VersionInfo
+import Wire.Arbitrary (Arbitrary, GenericUniform (GenericUniform))
 
--- | Version of the public API. Check the documentation in the *docs* directory
--- for a checklist when adding a new version.
+-- | Version of the public API.  Serializes to `"v<n>"`.  See 'VersionNumber' below for one
+-- that serializes to `<n>`.  See `/libs/wire-api/test/unit/Test/Wire/API/Routes/Version.hs`
+-- for serialization rules.
+--
+-- If you add or remove versions from this type, make sure 'versionInt', 'supportedVersions',
+-- and 'developmentVersions' stay in sync; everything else here should keep working without
+-- change.  See also documentation in the *docs* directory.
 -- https://docs.wire.com/developer/developer/api-versioning.html#version-bump-checklist
 data Version = V0 | V1 | V2 | V3 | V4
-  deriving stock (Eq, Ord, Bounded, Enum, Show)
+  deriving stock (Eq, Ord, Bounded, Enum, Show, Generic)
   deriving (FromJSON, ToJSON) via (Schema Version)
+  deriving (Arbitrary) via (GenericUniform Version)
+
+-- | Manual enumeration of version integrals (the `<n>` in the constructor `V<n>`).
+--
+-- This is not the same as 'fromEnum': we will remove unsupported versions in the future,
+-- which will cause `<n>` and `fromEnum V<n>` to diverge.  `Enum` should not be understood as
+-- a bijection between meaningful integers and versions, but merely as a convenient way to say
+-- `allVersions = [minBound..]`.
+versionInt :: Integral i => Version -> i
+versionInt V0 = 0
+versionInt V1 = 1
+versionInt V2 = 2
+versionInt V3 = 3
+versionInt V4 = 4
+
+supportedVersions :: [Version]
+supportedVersions = [minBound .. V4]
+
+developmentVersions :: [Version]
+developmentVersions = [V4]
+
+----------------------------------------------------------------------
+
+versionText :: Version -> Text
+versionText = ("v" <>) . toUrlPiece . versionInt @Int
+
+versionByteString :: Version -> ByteString
+versionByteString = ("v" <>) . toByteString' . versionInt @Int
 
 instance ToSchema Version where
-  schema =
-    enum @Integer "Version" . mconcat $
-      [ element 0 V0,
-        element 1 V1,
-        element 2 V2,
-        element 3 V3,
-        element 4 V4
-      ]
-
-mkVersion :: Integer -> Maybe Version
-mkVersion n = case Aeson.fromJSON (Aeson.Number (fromIntegral n)) of
-  Aeson.Error _ -> Nothing
-  Aeson.Success v -> pure v
+  schema = enum @Text "Version" . mconcat $ (\v -> element (versionText v) v) <$> [minBound ..]
 
 instance FromHttpApiData Version where
-  parseHeader = first Text.pack . Aeson.eitherDecode . LBS.fromStrict
-  parseUrlPiece = parseHeader . Text.encodeUtf8
+  parseQueryParam v = note ("Unknown version: " <> v) $
+    getAlt $
+      flip foldMap [minBound ..] $ \s ->
+        guard (versionText s == v) $> s
 
 instance ToHttpApiData Version where
-  toHeader = LBS.toStrict . Aeson.encode
-  toUrlPiece = Text.decodeUtf8 . toHeader
+  toHeader = versionByteString
+  toUrlPiece = versionText
 
 instance ToByteString Version where
-  builder = toEncodedUrlPiece
+  builder = Builder.fromByteString . versionByteString
+
+-- | Wrapper around 'Version' that serializes to integers `<n>`, as needed in
+-- eg. `VersionInfo`.  See `/libs/wire-api/test/unit/Test/Wire/API/Routes/Version.hs` for
+-- serialization rules.
+newtype VersionNumber = VersionNumber {fromVersionNumber :: Version}
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving newtype (Bounded, Enum)
+  deriving (FromJSON, ToJSON) via (Schema VersionNumber)
+  deriving (Arbitrary) via (GenericUniform Version)
+
+instance ToSchema VersionNumber where
+  schema =
+    enum @Integer "VersionNumber" . mconcat $ (\v -> element (versionInt v) (VersionNumber v)) <$> [minBound ..]
 
--- | `Version` as it appears in an URL path
---
--- >>> toPathComponent V1
--- "v1"
-toPathComponent :: Version -> ByteString
-toPathComponent v = "v" <> toHeader v
+instance FromHttpApiData VersionNumber where
+  parseHeader = first Text.pack . Aeson.eitherDecode . LBS.fromStrict
+  parseUrlPiece = parseHeader . Text.encodeUtf8
 
-supportedVersions :: [Version]
-supportedVersions = [minBound .. maxBound]
+instance ToHttpApiData VersionNumber where
+  toHeader = LBS.toStrict . Aeson.encode
+  toUrlPiece = Text.decodeUtf8 . toHeader
 
-developmentVersions :: [Version]
-developmentVersions = [V4]
+instance ToByteString VersionNumber where
+  builder = toEncodedUrlPiece
 
 -- | Information related to the public API version.
 --
@@ -111,8 +147,8 @@ developmentVersions = [V4]
 -- backend, in order to decide how to form request paths, and how to deal with
 -- federated backends and qualified user IDs.
 data VersionInfo = VersionInfo
-  { vinfoSupported :: [Version],
-    vinfoDevelopment :: [Version],
+  { vinfoSupported :: [VersionNumber],
+    vinfoDevelopment :: [VersionNumber],
     vinfoFederation :: Bool,
     vinfoDomain :: Domain
   }
@@ -130,7 +166,7 @@ instance ToSchema VersionInfo where
       example :: VersionInfo
       example =
         VersionInfo
-          { vinfoSupported = supportedVersions,
+          { vinfoSupported = VersionNumber <$> supportedVersions,
             vinfoDevelopment = [maxBound],
             vinfoFederation = False,
             vinfoDomain = Domain "example.com"

libs/wire-api/src/Wire/API/Routes/Version/Wai.hs

@@ -17,36 +17,50 @@
 
 module Wire.API.Routes.Version.Wai where
 
+import Control.Monad.Except (throwError)
 import Data.ByteString.Conversion
-import qualified Data.Text.Lazy as LText
+import Data.EitherR (fmapL)
+import Data.String.Conversions (cs)
+import qualified Data.Text as T
 import Imports
 import qualified Network.HTTP.Types as HTTP
 import Network.Wai
 import Network.Wai.Middleware.Rewrite
 import Network.Wai.Utilities.Error
 import Network.Wai.Utilities.Response
+import Web.HttpApiData (parseUrlPiece, toUrlPiece)
 import Wire.API.Routes.Version
 
 -- | Strip off version prefix. Return 404 if the version is not supported.
 versionMiddleware :: Set Version -> Middleware
 versionMiddleware disabledAPIVersions app req k = case parseVersion (removeVersionHeader req) of
-  Nothing -> app req k
-  Just (req', n) -> case mkVersion n of
-    Just v | v `notElem` disabledAPIVersions -> app (addVersionHeader v req') k
-    _ ->
-      k $
-        errorRs' $
-          mkError HTTP.status404 "unsupported-version" $
-            "Version " <> LText.pack (show n) <> " is not supported"
-
-parseVersion :: Request -> Maybe (Request, Integer)
+  Right (req', v) ->
+    if v `elem` disabledAPIVersions
+      then err (toUrlPiece v)
+      else app (addVersionHeader v req') k
+  Left (BadVersion v) -> err v
+  Left NoVersion -> app req k
+  where
+    err :: Text -> IO ResponseReceived
+    err v =
+      k . errorRs' . mkError HTTP.status404 "unsupported-version" $
+        "Version " <> cs v <> " is not supported"
+
+data ParseVersionError = NoVersion | BadVersion Text
+
+parseVersion :: Request -> Either ParseVersionError (Request, Version)
 parseVersion req = do
   (version, pinfo) <- case pathInfo req of
-    [] -> Nothing
+    [] -> throwError NoVersion
     (x : xs) -> pure (x, xs)
-  n <- readVersionNumber version
+  unless (looksLikeVersion version) $
+    throwError NoVersion
+  n <- fmapL (const $ BadVersion version) $ parseUrlPiece version
   pure (rewriteRequestPure (\(_, q) _ -> (pinfo, q)) req, n)
 
+looksLikeVersion :: Text -> Bool
+looksLikeVersion version = case T.splitAt 1 version of (h, t) -> h == "v" && T.all isDigit t
+
 removeVersionHeader :: Request -> Request
 removeVersionHeader req =
   req

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

@@ -20,7 +20,6 @@ module Wire.API.VersionInfo
     vinfoObjectSchema,
 
     -- * Version utilities
-    readVersionNumber,
     versionHeader,
     VersionHeader,
 
@@ -36,8 +35,6 @@ import qualified Data.CaseInsensitive as CI
 import Data.Metrics.Servant
 import Data.Schema
 import Data.Singletons
-import qualified Data.Text as Text
-import qualified Data.Text.Read as Text
 import GHC.TypeLits
 import Imports
 import qualified Network.Wai as Wai
@@ -51,13 +48,6 @@ import Wire.API.Routes.ClientAlgebra
 vinfoObjectSchema :: ValueSchema NamedSwaggerDoc v -> ObjectSchema SwaggerDoc [v]
 vinfoObjectSchema sch = field "supported" (array sch)
 
-readVersionNumber :: Text -> Maybe Integer
-readVersionNumber v = do
-  ('v', rest) <- Text.uncons v
-  case Text.decimal rest of
-    Right (n, "") -> pure n
-    _ -> Nothing
-
 type VersionHeader = "X-Wire-API-Version"
 
 versionHeader :: CI.CI ByteString

libs/wire-api/test/unit/Main.hs

@@ -21,6 +21,7 @@ module Main
 where
 
 import Imports
+import System.IO.Unsafe (unsafePerformIO)
 import Test.Tasty
 import qualified Test.Wire.API.Call.Config as Call.Config
 import qualified Test.Wire.API.Conversation as Conversation
@@ -33,6 +34,7 @@ import qualified Test.Wire.API.Roundtrip.HttpApiData as Roundtrip.HttpApiData
 import qualified Test.Wire.API.Roundtrip.MLS as Roundtrip.MLS
 import qualified Test.Wire.API.Routes as Routes
 import qualified Test.Wire.API.Routes.Version as Routes.Version
+import qualified Test.Wire.API.Routes.Version.Wai as Routes.Version.Wai
 import qualified Test.Wire.API.Swagger as Swagger
 import qualified Test.Wire.API.Team.Export as Team.Export
 import qualified Test.Wire.API.Team.Member as Team.Member
@@ -63,5 +65,6 @@ main =
         Conversation.tests,
         MLS.tests,
         Routes.Version.tests,
+        unsafePerformIO Routes.Version.Wai.tests,
         RawJson.tests
       ]

libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs

@@ -47,6 +47,7 @@ import qualified Wire.API.Provider.Service as Provider.Service
 import qualified Wire.API.Provider.Service.Tag as Provider.Service.Tag
 import qualified Wire.API.Push.Token as Push.Token
 import qualified Wire.API.Routes.Internal.Galley.TeamsIntra as TeamsIntra
+import qualified Wire.API.Routes.Version as Routes.Version
 import qualified Wire.API.SystemSettings as SystemSettings
 import qualified Wire.API.Team as Team
 import qualified Wire.API.Team.Conversation as Team.Conversation
@@ -316,6 +317,8 @@ tests =
       testRoundTrip @User.Search.TeamContact,
       testRoundTrip @(Wrapped.Wrapped "some_int" Int),
       testRoundTrip @Conversation.Action.SomeConversationAction,
+      testRoundTrip @Routes.Version.Version,
+      testRoundTrip @Routes.Version.VersionNumber,
       testRoundTrip @TeamsIntra.GuardLegalholdPolicyConflicts,
       testRoundTrip @TeamsIntra.TeamStatus,
       testRoundTrip @TeamsIntra.TeamStatusUpdate,

libs/wire-api/test/unit/Test/Wire/API/Roundtrip/HttpApiData.hs

@@ -22,6 +22,7 @@ import Servant.API
 import qualified Test.Tasty as T
 import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (===))
 import Type.Reflection (typeRep)
+import qualified Wire.API.Routes.Version
 import qualified Wire.API.User
 import qualified Wire.API.User.Search
 import qualified Wire.Arbitrary as Arbitrary ()
@@ -30,7 +31,9 @@ tests :: T.TestTree
 tests =
   T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "HttpApiData roundtrip tests" $
     [ testRoundTrip @Wire.API.User.InvitationCode,
-      testRoundTrip @Wire.API.User.Search.PagingState
+      testRoundTrip @Wire.API.User.Search.PagingState,
+      testRoundTrip @Wire.API.Routes.Version.Version,
+      testRoundTrip @Wire.API.Routes.Version.VersionNumber
     ]
 
 testRoundTrip ::