Introduce VersionNumber newtype.

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/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,18 +29,17 @@ 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
@@ -57,44 +57,78 @@ 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.
+-- | 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.
 data Version = V0 | V1 | V2 | V3
-  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 strings.
+--
+-- If you want to implement this using `{to,from}Enum`, continue reading the haddocs for
+-- 'versionInt' below.  :-)
+versionString :: IsString a => Version -> a
+versionString V0 = "v0"
+versionString V1 = "v1"
+versionString V2 = "v2"
+versionString V3 = "v3"
+
+-- | Manual enumeration of version integrals.
+--
+-- We don't do anything fancy with `{to,from}Enum`
+-- because we'll eventually break the invariant that there is a `V<n>` for every `<n>` once we
+-- start to deprecate old versions (we may even find a reason to discontinue `V13` but keep
+-- supporting `V12`).
+versionInt :: Integral i => Version -> i
+versionInt V0 = 0
+versionInt V1 = 1
+versionInt V2 = 2
+versionInt V3 = 3
 
 instance ToSchema Version where
-  schema =
-    enum @Integer "Version" . mconcat $
-      [ element 0 V0,
-        element 1 V1,
-        element 2 V2,
-        element 3 V3
-      ]
-
-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 (versionString v) v) <$> [minBound ..]
 
 instance FromHttpApiData Version where
+  parseQueryParam v = note ("Unknown version: " <> v) $
+    getAlt $
+      flip foldMap [minBound ..] $ \s ->
+        guard (versionString s == v) $> s
+
+instance ToHttpApiData Version where
+  toHeader = versionString
+  toUrlPiece = versionString
+
+instance ToByteString Version where
+  builder = versionString
+
+-- | 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 ..]
+
+instance FromHttpApiData VersionNumber where
   parseHeader = first Text.pack . Aeson.eitherDecode . LBS.fromStrict
   parseUrlPiece = parseHeader . Text.encodeUtf8
 
-instance ToHttpApiData Version where
+instance ToHttpApiData VersionNumber where
   toHeader = LBS.toStrict . Aeson.encode
   toUrlPiece = Text.decodeUtf8 . toHeader
 
-instance ToByteString Version where
+instance ToByteString VersionNumber where
   builder = toEncodedUrlPiece
 
--- | `Version` as it appears in an URL path
---
--- >>> toPathComponent V1
--- "v1"
-toPathComponent :: Version -> ByteString
-toPathComponent v = "v" <> toHeader v
-
 supportedVersions :: [Version]
 supportedVersions = [minBound .. maxBound]
 
@@ -108,8 +142,8 @@ developmentVersions = [V3]
 -- 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
   }
@@ -127,7 +161,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,34 +17,45 @@
 
 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"
+  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"
 
-parseVersion :: Request -> Maybe (Request, Integer)
+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 ("v" `T.isPrefixOf` version) $
+    throwError (BadVersion version)
+  n <- fmapL (const NoVersion) $ parseUrlPiece version
   pure (rewriteRequestPure (\(_, q) _ -> (pinfo, q)) req, n)
 
 removeVersionHeader :: Request -> Request

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/Test/Wire/API/Roundtrip/Aeson.hs

@@ -46,6 +46,7 @@ import qualified Wire.API.Provider.External as Provider.External
 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.Version as Routes.Version
 import qualified Wire.API.Team as Team
 import qualified Wire.API.Team.Conversation as Team.Conversation
 import qualified Wire.API.Team.Feature as Team.Feature
@@ -310,7 +311,9 @@ tests =
       testRoundTrip @User.Search.PagingState,
       testRoundTrip @User.Search.TeamContact,
       testRoundTrip @(Wrapped.Wrapped "some_int" Int),
-      testRoundTrip @Conversation.Action.SomeConversationAction
+      testRoundTrip @Conversation.Action.SomeConversationAction,
+      testRoundTrip @Routes.Version.Version,
+      testRoundTrip @Routes.Version.VersionNumber
     ]
 
 testRoundTrip ::

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 ::

libs/wire-api/test/unit/Test/Wire/API/Routes/Version.hs

@@ -1,21 +1,45 @@
 module Test.Wire.API.Routes.Version where
 
+import Data.Aeson as Aeson
+import Data.Binary.Builder
+import Data.ByteString.Conversion
+import Data.String.Conversions (cs)
 import Imports
-import qualified Test.Tasty as T
+import Servant.API
+import Test.Tasty
 import Test.Tasty.HUnit
 import Wire.API.Routes.Version
 
-tests :: T.TestTree
+{-# ANN tests ("HLint: ignore Functor law" :: String) #-}
+tests :: TestTree
 tests =
-  T.testGroup "Version" $
-    [ T.testGroup
-        "toPathComponent"
-        [testCase "serialise different versions" testToPathComponent]
+  testGroup
+    "Version always has the shape V<int>; serializations of Version and VersionNumber are `v<int>`, `<int>`, resp.  <int> is non-negative."
+    [ testCase "Version, show, 'v' prefix" $ do
+        nub (toLower . head . show <$> allVersions) @=? ['v'],
+      testCase "Version, show, int suffix" $ do
+        let expected = show $ (read @Int) . tail . show <$> allVersions
+        assertBool expected (isJust (Aeson.decode @[Int] (cs expected))),
+      testGroup "Version: all serializations are the same as `show`, up to string type" $ do
+        [ testCase "toByteString'" $ fmap toLower . show <$> allVersions @=? cs . toByteString' <$> allVersions,
+          testCase "encode" $ fmap toLower (show (show <$> allVersions)) @=? cs (encode allVersions), -- (`encode @Version` has extra double-quotes)
+          testCase "toUrlPiece" $ fmap toLower . show <$> allVersions @=? cs . toUrlPiece <$> allVersions,
+          testCase "toEncodedUrlPiece" $ fmap toLower . show <$> allVersions @=? cs . toLazyByteString . toEncodedUrlPiece <$> allVersions,
+          testCase "toHeader" $ fmap toLower . show <$> allVersions @=? cs . toHeader <$> allVersions,
+          testCase "toQueryParam" $ fmap toLower . show <$> allVersions @=? cs . toQueryParam <$> allVersions
+          ],
+      testGroup "VersionNumber: all serializations are the same as `tail . show . fromVersionNumber`, up to string type" $
+        [ testCase "toByteString'" $ tail . show . fromVersionNumber <$> allVersionNumbers @=? cs . toByteString' <$> allVersionNumbers,
+          testCase "encode" $ tail . show . fromVersionNumber <$> allVersionNumbers @=? cs . encode <$> allVersionNumbers,
+          testCase "toUrlPiece" $ tail . show . fromVersionNumber <$> allVersionNumbers @=? cs . toUrlPiece <$> allVersionNumbers,
+          testCase "toEncodedUrlPiece" $ tail . show . fromVersionNumber <$> allVersionNumbers @=? cs . toLazyByteString . toEncodedUrlPiece <$> allVersionNumbers,
+          testCase "toHeader" $ tail . show . fromVersionNumber <$> allVersionNumbers @=? cs . toHeader <$> allVersionNumbers,
+          testCase "toQueryParam" $ tail . show . fromVersionNumber <$> allVersionNumbers @=? cs . toQueryParam <$> allVersionNumbers
+        ]
     ]
 
-testToPathComponent :: Assertion
-testToPathComponent = do
-  "v0" @=? toPathComponent V0
-  "v1" @=? toPathComponent V1
-  "v2" @=? toPathComponent V2
-  "v3" @=? toPathComponent V3
+allVersions :: [Version]
+allVersions = [minBound ..]
+
+allVersionNumbers :: [VersionNumber]
+allVersionNumbers = [minBound ..]

services/brig/src/Brig/API/Public/Swagger.hs

@@ -37,7 +37,7 @@ pregenSwagger :: Version -> Q Exp
 pregenSwagger v =
   embedLazyByteString
     =<< makeRelativeToProject
-      ("docs/swagger-v" <> T.unpack (toUrlPiece v) <> ".json")
+      ("docs/swagger-v" <> T.unpack (toUrlPiece (VersionNumber v)) <> ".json")
 
 swaggerPregenUIServer :: LByteString -> Server VersionedSwaggerDocsAPIBase
 swaggerPregenUIServer =

services/brig/src/Brig/Effects/GalleyProvider/RPC.hs

@@ -87,7 +87,7 @@ createSelfConv u = do
   void $ ServiceRPC.request @'Galley POST req
   where
     req =
-      paths ["v" <> toHeader (maxBound :: Version), "conversations", "self"]
+      paths [toHeader (maxBound :: Version), "conversations", "self"]
         . zUser u
         . expect2xx
 
@@ -115,7 +115,7 @@ getConv usr lcnv = do
   where
     req =
       paths
-        [ "v" <> toHeader (maxBound :: Version),
+        [ toHeader (maxBound :: Version),
           "conversations",
           toByteString' (tDomain lcnv),
           toByteString' (tUnqualified lcnv)
@@ -147,7 +147,7 @@ getTeamConv usr tid cnv = do
   where
     req =
       paths
-        [ "v" <> toHeader (maxBound :: Version),
+        [ toHeader (maxBound :: Version),
           "teams",
           toByteString' tid,
           "conversations",

services/brig/src/Brig/Version.hs

@@ -40,8 +40,8 @@ versionAPI = Named $ do
         | otherwise = Set.difference allVersions devVersions
   pure $
     VersionInfo
-      { vinfoSupported = toList supported,
-        vinfoDevelopment = toList devVersions,
+      { vinfoSupported = VersionNumber <$> toList supported,
+        vinfoDevelopment = VersionNumber <$> toList devVersions,
         vinfoFederation = isJust fed,
         vinfoDomain = dom
       }