Base64 cleanup

changelog.d/5-internal/base64-cleanup

@@ -0,0 +1 @@
+Clean up `Base64ByteString` implementation

libs/types-common/src/Data/Json/Util.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NumDecimals #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -38,10 +39,12 @@ module Data.Json.Util
 
     -- * Base64
     Base64ByteString (..),
+    base64Schema,
+    Base64ByteStringL (..),
+    base64SchemaL,
     fromBase64TextLenient,
     fromBase64Text,
     toBase64Text,
-    base64Schema,
   )
 where
 
@@ -52,12 +55,12 @@ import qualified Data.Aeson as A
 import qualified Data.Aeson.Types as A
 import qualified Data.Attoparsec.Text as Atto
 import qualified Data.Attoparsec.Time as Atto
+import Data.Bifunctor
 import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Base64.Lazy as B64L
+import qualified Data.ByteString.Base64.URL as B64U
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Conversion as BS
 import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.Char8 as L8
 import Data.Fixed
 import Data.Schema
 import Data.String.Conversions (cs)
@@ -70,6 +73,7 @@ import Data.Time.Format (formatTime, parseTimeM)
 import qualified Data.Time.Lens as TL
 import Data.Time.Locale.Compat (defaultTimeLocale)
 import Imports
+import Servant
 import Test.QuickCheck (Arbitrary (arbitrary))
 -- for UTCTime
 import Test.QuickCheck.Instances ()
@@ -174,39 +178,71 @@ toJSONFieldName = A.defaultOptions {A.fieldLabelModifier = A.camelTo2 '_' . drop
     dropPrefix = dropWhile (not . isUpper)
 
 --------------------------------------------------------------------------------
--- base64-encoded lazy bytestrings
 
--- | Lazy 'ByteString' with base64 json encoding.  Relevant discussion:
--- <https://github.com/bos/aeson/issues/126>.  See test suite for more details.
-newtype Base64ByteString = Base64ByteString {fromBase64ByteString :: L.ByteString}
+-- | Base64-encoded strict 'ByteString'.
+--
+-- For proper Swagger generation, avoid using this type directly in APIs. Instead,
+-- use a plain 'ByteString' (or a more specific newtype wrapper), and construct
+-- instances using @deriving via@.
+--
+-- For URLs or HTTP headers, the base64url encoding is used.
+--
+-- Some related discussion: <https://github.com/bos/aeson/issues/126>.
+newtype Base64ByteString = Base64ByteString {fromBase64ByteString :: ByteString}
+  deriving stock (Eq, Ord, Show)
+  deriving (FromJSON, ToJSON) via Schema Base64ByteString
+  deriving newtype (Arbitrary, IsString)
+
+instance ToSchema Base64ByteString where
+  schema = fromBase64ByteString .= fmap Base64ByteString base64SchemaN
+
+instance FromHttpApiData Base64ByteString where
+  parseUrlPiece = bimap Text.pack Base64ByteString . B64U.decode . Text.encodeUtf8
+
+instance ToHttpApiData Base64ByteString where
+  toUrlPiece = Text.decodeUtf8With Text.lenientDecode . B64U.encode . fromBase64ByteString
+
+instance S.ToParamSchema Base64ByteString where
+  toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString
+
+base64SchemaN :: ValueSchema NamedSwaggerDoc ByteString
+base64SchemaN = toBase64Text .= parsedText "Base64ByteString" fromBase64Text
+
+base64Schema :: ValueSchema SwaggerDoc ByteString
+base64Schema = unnamed base64SchemaN
+
+--------------------------------------------------------------------------------
+
+-- | Base64-encoded lazy 'ByteString'.
+-- Similar to 'Base64ByteString', but based on 'LByteString'.
+newtype Base64ByteStringL = Base64ByteStringL {fromBase64ByteStringL :: LByteString}
   deriving (Eq, Show, Generic)
+  deriving (FromJSON, ToJSON) via Schema Base64ByteStringL
+  deriving newtype (Arbitrary, IsString)
+
+base64FromStrict :: Base64ByteString -> Base64ByteStringL
+base64FromStrict = Base64ByteStringL . L.fromStrict . fromBase64ByteString
+
+base64ToStrict :: Base64ByteStringL -> Base64ByteString
+base64ToStrict = Base64ByteString . L.toStrict . fromBase64ByteStringL
+
+instance ToSchema Base64ByteStringL where
+  schema = fromBase64ByteStringL .= fmap Base64ByteStringL base64SchemaLN
+
+instance FromHttpApiData Base64ByteStringL where
+  parseUrlPiece = fmap base64FromStrict . parseUrlPiece
+
+instance ToHttpApiData Base64ByteStringL where
+  toUrlPiece = toUrlPiece . base64ToStrict
+
+instance S.ToParamSchema Base64ByteStringL where
+  toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString
+
+base64SchemaLN :: ValueSchema NamedSwaggerDoc LByteString
+base64SchemaLN = L.toStrict .= fmap L.fromStrict base64SchemaN
 
-instance FromJSON Base64ByteString where
-  parseJSON (A.String st) = handleError . B64L.decode . stToLbs $ st
-    where
-      stToLbs = L.fromChunks . pure . Text.encodeUtf8
-      handleError =
-        either
-          (const $ fail "parse Base64ByteString: invalid base64 encoding")
-          (pure . Base64ByteString)
-  parseJSON _ = fail "parse Base64ByteString: not a string"
-
-instance ToJSON Base64ByteString where
-  toJSON (Base64ByteString lbs) = A.String . lbsToSt . B64L.encode $ lbs
-    where
-      lbsToSt =
-        Text.decodeUtf8With Text.lenientDecode
-          . mconcat
-          . L.toChunks
-
-instance IsString Base64ByteString where
-  fromString = Base64ByteString . L8.pack
-
-instance Arbitrary Base64ByteString where
-  arbitrary = Base64ByteString <$> arbitrary
-
-base64Schema :: ValueSchema SwaggerDoc Base64ByteString
-base64Schema = mkSchema mempty A.parseJSON (pure . A.toJSON)
+base64SchemaL :: ValueSchema SwaggerDoc LByteString
+base64SchemaL = unnamed base64SchemaLN
 
 --------------------------------------------------------------------------------
 -- Utilities

libs/types-common/test/Test/Properties.hs

@@ -107,15 +107,15 @@ tests =
             \(c :: Char) -> Ascii.contains Ascii.Base64Url c ==> Ascii.contains Ascii.Standard c
         ],
       testGroup
-        "Base64ByteString"
+        "Base64ByteStringL"
         [ testProperty "validate (Aeson.decode . Aeson.encode) == pure . id" $
-            \(Util.Base64ByteString . L.pack -> s) ->
+            \(Util.Base64ByteStringL . L.pack -> s) ->
               (Aeson.eitherDecode . Aeson.encode) s == Right s,
           -- the property only considers valid 'String's, and it does not document the encoding very
           -- well, so here are some unit tests (see
           -- http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt for more).
           testCase "examples" $ do
-            let go :: Util.Base64ByteString -> L.ByteString -> Assertion
+            let go :: Util.Base64ByteStringL -> L.ByteString -> Assertion
                 go b uu = do
                   Aeson.encode b @=? uu
                   (Aeson.eitherDecode . Aeson.encode) b @=? Right b

libs/wire-api/src/Wire/API/MLS/KeyPackage.hs

@@ -93,7 +93,7 @@ instance ToSchema KeyPackageData where
   schema =
     (S.schema . S.example ?~ "a2V5IHBhY2thZ2UgZGF0YQo=")
       ( KeyPackageData <$> kpData
-          .= named "KeyPackage" (Base64ByteString .= fmap fromBase64ByteString base64Schema)
+          .= named "KeyPackage" base64SchemaL
       )
 
 data KeyPackageBundleEntry = KeyPackageBundleEntry

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

@@ -80,7 +80,7 @@ import qualified Data.ProtocolBuffers as Protobuf
 import Data.Qualified (Qualified (..))
 import Data.SOP (I (..), NS (..), unI, unZ)
 import Data.Schema
-import Data.Serialize (runGetLazy)
+import Data.Serialize (runGet)
 import qualified Data.Set as Set
 import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
@@ -157,7 +157,7 @@ instance ToSchema NewOtrMessage where
         <*> newOtrReportMissing .= maybe_ (optField "report_missing" (array schema))
 
 instance FromProto NewOtrMessage where
-  fromProto bs = protoToNewOtrMessage <$> runGetLazy Protobuf.decodeMessage bs
+  fromProto bs = protoToNewOtrMessage <$> runGet Protobuf.decodeMessage bs
 
 protoToNewOtrMessage :: Proto.NewOtrMessage -> NewOtrMessage
 protoToNewOtrMessage msg =
@@ -198,10 +198,10 @@ instance S.ToSchema QualifiedNewOtrMessage where
                \https://github.com/wireapp/generic-message-proto/blob/master/proto/otr.proto."
 
 instance FromProto QualifiedNewOtrMessage where
-  fromProto bs = protolensToQualifiedNewOtrMessage =<< ProtoLens.decodeMessage (LBS.toStrict bs)
+  fromProto bs = protolensToQualifiedNewOtrMessage =<< ProtoLens.decodeMessage bs
 
 instance ToProto QualifiedNewOtrMessage where
-  toProto = LBS.fromStrict . ProtoLens.encodeMessage . qualifiedNewOtrMessageToProto
+  toProto = ProtoLens.encodeMessage . qualifiedNewOtrMessageToProto
 
 protolensToQualifiedNewOtrMessage :: Proto.Otr.QualifiedNewOtrMessage -> Either String QualifiedNewOtrMessage
 protolensToQualifiedNewOtrMessage protoMsg = do

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

@@ -17,6 +17,7 @@
 
 module Wire.API.ServantProto where
 
+import qualified Data.ByteString.Lazy as LBS
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Swagger
 import Imports
@@ -34,22 +35,22 @@ data Proto
 -- it is fairly difficult to keep our custom data type, e.g. in
 -- Wire.API.Message.Proto in sync with the proto files.
 class FromProto a where
-  fromProto :: LByteString -> Either String a
+  fromProto :: ByteString -> Either String a
 
 class ToProto a where
-  toProto :: a -> LByteString
+  toProto :: a -> ByteString
 
 instance Accept Proto where
   contentTypes _ = ("application" // "x-protobuf") :| []
 
 instance FromProto a => MimeUnrender Proto a where
-  mimeUnrender _ bs = fromProto bs
+  mimeUnrender _ bs = fromProto (LBS.toStrict bs)
 
 -- | This wrapper can be used to get the raw protobuf representation of a type.
 -- It is used when the protobuf is supposed to be forwarded somewhere like a
 -- federated remote, this saves us from having to re-encode it.
 data RawProto a = RawProto
-  { rpRaw :: LByteString,
+  { rpRaw :: ByteString,
     rpValue :: a
   }
 

libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs

@@ -83,7 +83,7 @@ protoTestObject ::
   IO Bool
 protoTestObject obj path = do
   let actual = toProto obj
-  msg <- assertRight (decodeMessage @m (LBS.toStrict actual))
+  msg <- assertRight (decodeMessage @m actual)
   let pretty = render (pprintMessage msg)
       dir = "test/golden"
       fullPath = dir <> "/" <> path
@@ -100,7 +100,7 @@ protoTestObject obj path = do
   assertEqual
     (show (typeRep @a) <> ": FromProto of " <> path <> " should match object")
     (Right obj)
-    (fromProto (LBS.fromStrict (encodeMessage expected)))
+    (fromProto (encodeMessage expected))
 
   pure exists
 

services/galley/src/Galley/API/Message.hs

@@ -234,7 +234,7 @@ postRemoteOtrMessage ::
   Members '[FederatorAccess] r =>
   Qualified UserId ->
   Remote ConvId ->
-  LByteString ->
+  ByteString ->
   Sem r (PostOtrResponse MessageSendingStatus)
 postRemoteOtrMessage sender conv rawMsg = do
   let msr =

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

@@ -42,7 +42,6 @@ import Control.Lens hiding ((#))
 import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as A
 import Data.ByteString.Conversion (toByteString')
-import qualified Data.ByteString.Lazy as LBS
 import Data.Domain
 import Data.Id (ConvId, Id (..), UserId, newClientId, randomId)
 import Data.Json.Util (Base64ByteString (..), toBase64Text)
@@ -884,9 +883,7 @@ sendMessage = do
         FedGalley.MessageSendRequest
           { FedGalley.msrConvId = convId,
             FedGalley.msrSender = bobId,
-            FedGalley.msrRawMessage =
-              Base64ByteString
-                (LBS.fromStrict (Protolens.encodeMessage msg))
+            FedGalley.msrRawMessage = Base64ByteString (Protolens.encodeMessage msg)
           }
   let responses2 req
         | frComponent req == Brig =