Merge pull request #20 from haskell-works/newhoggy/support-for-decodi…

…ng-base64-text Support for encoding/decoding base64 text
haskell-works · Sep 29, 2024 · 58a47c4 · 58a47c4
2 parents d6ab23d + 889d902
commit 58a47c4
Show file tree

Hide file tree

Showing 6 changed files with 139 additions and 83 deletions.
diff --git a/rds-data.cabal b/rds-data.cabal
@@ -39,10 +39,10 @@ common generic-lens                             { build-depends: generic-lens
 common hedgehog                                 { build-depends: hedgehog                                 >= 1.4        && < 2      }
 common hedgehog-extras                          { build-depends: hedgehog-extras                          >= 0.6.0.2    && < 0.7    }
 common http-client                              { build-depends: http-client                              >= 0.5.14     && < 0.8    }
-common hw-polysemy-amazonka                     { build-depends: hw-polysemy:amazonka                     >= 0.2.14.6   && < 0.3    }
-common hw-polysemy-core                         { build-depends: hw-polysemy:core                         >= 0.2.14.6   && < 0.3    }
-common hw-polysemy-hedgehog                     { build-depends: hw-polysemy:hedgehog                     >= 0.2.14.6   && < 0.3    }
-common hw-polysemy-testcontainers-localstack    { build-depends: hw-polysemy:testcontainers-localstack    >= 0.2.14.6   && < 0.3    }
+common hw-polysemy-amazonka                     { build-depends: hw-polysemy:amazonka                     >= 0.2.14.7   && < 0.3    }
+common hw-polysemy-core                         { build-depends: hw-polysemy:core                         >= 0.2.14.7   && < 0.3    }
+common hw-polysemy-hedgehog                     { build-depends: hw-polysemy:hedgehog                     >= 0.2.14.7   && < 0.3    }
+common hw-polysemy-testcontainers-localstack    { build-depends: hw-polysemy:testcontainers-localstack    >= 0.2.14.7   && < 0.3    }
 common microlens                                { build-depends: microlens                                >= 0.4.13     && < 0.5    }
 common mtl                                      { build-depends: mtl                                      >= 2          && < 3      }
 common optparse-applicative                     { build-depends: optparse-applicative                     >= 0.18.1.0   && < 0.19   }
@@ -87,6 +87,7 @@ library codecs
                       , amazonka-rds
                       , amazonka-rds-data
                       , amazonka-secretsmanager
+                      , base64-bytestring
                       , bytestring
                       , contravariant
                       , generic-lens

diff --git a/src/Data/RdsData/Decode/Row.hs b/src/Data/RdsData/Decode/Row.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings          #-}
 
 module Data.RdsData.Decode.Row
   ( DecodeRow(..)
@@ -23,6 +23,8 @@ module Data.RdsData.Decode.Row
   , word64
   , bytestring
   , lazyBytestring
+  , base64Text
+  , lazyBase64Text
   , timeOfDay
   , day
   , ulid
@@ -36,20 +38,20 @@ module Data.RdsData.Decode.Row
   , decodeRows
   ) where
 
-import Control.Monad.Except
-import Control.Monad.State
-import Data.ByteString (ByteString)
-import Control.Monad
-import Data.Functor.Identity ( Identity )
-import Data.Int
-import Data.RdsData.Decode.Value (DecodeValue)
-import Data.RdsData.Types.Value
-import Data.Text
-import Data.Time
-import Data.ULID (ULID)
-import Data.UUID (UUID)
-import Data.Word
-import Prelude hiding (maybe)
+import           Control.Monad
+import           Control.Monad.Except
+import           Control.Monad.State
+import           Data.ByteString               (ByteString)
+import           Data.Functor.Identity         (Identity)
+import           Data.Int
+import           Data.RdsData.Decode.Value     (DecodeValue)
+import           Data.RdsData.Types.Value
+import           Data.Text
+import           Data.Time
+import           Data.ULID                     (ULID)
+import           Data.UUID                     (UUID)
+import           Data.Word
+import           Prelude                       hiding (maybe)
 
 import qualified Data.Aeson                    as J
 import qualified Data.ByteString.Lazy          as LBS
@@ -84,7 +86,7 @@ decodeRowValue :: ()
 decodeRowValue decoder v =
   case DV.decodeValue decoder v of
     Right a -> pure a
-    Left e -> throwError $ "Failed to decode Value: " <> e
+    Left e  -> throwError $ "Failed to decode Value: " <> e
 
 column :: ()
   => DecodeValue a
@@ -167,6 +169,14 @@ lazyBytestring :: DecodeRow LBS.ByteString
 lazyBytestring =
   column DV.lazyBytestring
 
+base64Text :: DecodeRow ByteString
+base64Text =
+  column DV.base64Text
+
+lazyBase64Text :: DecodeRow LBS.ByteString
+lazyBase64Text =
+  column DV.lazyBase64Text
+
 string :: DecodeRow String
 string =
   column DV.string
@@ -179,35 +189,35 @@ timeOfDay :: DecodeRow TimeOfDay
 timeOfDay = do
   t <- text
   case parseTimeM True defaultTimeLocale "%H:%M:%S%Q" (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> throwError $ "Failed to parse TimeOfDay: " <> T.pack (show t)
 
 ulid :: DecodeRow ULID
 ulid = do
   t <- text
   case CONV.textToUlid t of
-    Right a -> pure a
+    Right a  -> pure a
     Left msg -> throwError $ "Failed to parse ULID: " <> msg
 
 utcTime :: DecodeRow UTCTime
 utcTime = do
   t <- text
   case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> throwError $ "Failed to parse UTCTime: " <> T.pack (show t)
 
 uuid :: DecodeRow UUID
 uuid = do
   t <- text
   case UUID.fromString (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> throwError $ "Failed to parse UUID: " <> T.pack (show t)
 
 day :: DecodeRow Day
 day = do
   t <- text
   case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> throwError $ "Failed to parse Day: " <> T.pack (show t)
 
 ignore :: DecodeRow ()

diff --git a/src/Data/RdsData/Decode/Value.hs b/src/Data/RdsData/Decode/Value.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 {- HLINT ignore "Use <&>" -}
@@ -32,6 +32,8 @@ module Data.RdsData.Decode.Value
   , bytestring
   , lazyText
   , lazyBytestring
+  , base64Text
+  , lazyBase64Text
   , string
   , json
   , timeOfDay
@@ -41,28 +43,31 @@ module Data.RdsData.Decode.Value
 
   ) where
 
-import Amazonka.Data.Base64
-import Control.Applicative
-import Data.ByteString (ByteString)
-import Data.Int
-import Data.RdsData.Decode.Array (DecodeArray(..))
-import Data.RdsData.Internal.Aeson
-import Data.RdsData.Types.Value
-import Data.Text (Text)
-import Data.Time
-import Data.UUID (UUID)
-import Data.Word
-import Prelude hiding (maybe, null)
-
-import qualified Amazonka.Data.ByteString       as AWS
-import qualified Data.Aeson                     as J
-import qualified Data.ByteString.Lazy           as LBS
-import qualified Data.RdsData.Internal.Convert  as CONV
-import qualified Data.Text                      as T
-import qualified Data.Text.Encoding             as T
-import qualified Data.Text.Lazy                 as LT
-import qualified Data.UUID                      as UUID
-import qualified Prelude                        as P
+import           Amazonka.Data.Base64
+import           Control.Applicative
+import           Data.ByteString               (ByteString)
+import           Data.Int
+import           Data.RdsData.Decode.Array     (DecodeArray (..))
+import           Data.RdsData.Internal.Aeson
+import           Data.RdsData.Types.Value
+import           Data.Text                     (Text)
+import           Data.Time
+import           Data.UUID                     (UUID)
+import           Data.Word
+import           Prelude                       hiding (maybe, null)
+
+import qualified Amazonka.Data.ByteString      as AWS
+import qualified Data.Aeson                    as J
+import qualified Data.ByteString.Base64        as B64
+import qualified Data.ByteString.Base64.Lazy   as LB64
+import qualified Data.ByteString.Lazy          as LBS
+import qualified Data.RdsData.Internal.Convert as CONV
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as T
+import qualified Data.Text.Lazy                as LT
+import qualified Data.Text.Lazy.Encoding       as LT
+import qualified Data.UUID                     as UUID
+import qualified Prelude                       as P
 
 newtype DecodeValue a = DecodeValue
   { decodeValue :: Value -> Either Text a
@@ -106,7 +111,7 @@ maybe (DecodeValue f) =
   DecodeValue \v ->
     case v of
       ValueOfNull -> Right Nothing
-      _ -> Just <$> f v  
+      _           -> Just <$> f v
 
 --------------------------------------------------------------------------------
 
@@ -129,7 +134,7 @@ bool =
   DecodeValue \v ->
     case v of
       ValueOfBool b -> Right b
-      _ -> Left $ decodeValueFailedMessage "bool" "Bool" Nothing v
+      _             -> Left $ decodeValueFailedMessage "bool" "Bool" Nothing v
 
 double :: DecodeValue Double
 double =
@@ -147,7 +152,7 @@ text =
   DecodeValue \v ->
     case v of
       ValueOfText s -> Right s
-      _ -> Left $ decodeValueFailedMessage "text" "Text" Nothing v
+      _             -> Left $ decodeValueFailedMessage "text" "Text" Nothing v
 
 integer :: DecodeValue Integer
 integer =
@@ -161,7 +166,7 @@ null =
   DecodeValue \v ->
     case v of
       ValueOfNull -> Right ()
-      _ -> Left $ decodeValueFailedMessage "null" "()" Nothing v
+      _           -> Left $ decodeValueFailedMessage "null" "()" Nothing v
 
 --------------------------------------------------------------------------------
 
@@ -243,6 +248,22 @@ lazyText :: DecodeValue LT.Text
 lazyText =
   LT.fromStrict <$> text
 
+base64Text :: DecodeValue ByteString
+base64Text = do
+  t <- text
+  let b64 = T.encodeUtf8 t
+  case B64.decode b64 of
+    Right a -> pure a
+    Left e  -> decodeValueFailed "base64-text" "Text" (Just (T.pack e))
+
+lazyBase64Text :: DecodeValue LBS.ByteString
+lazyBase64Text = do
+  t <- lazyText
+  let b64 = LT.encodeUtf8 t
+  case LB64.decode b64 of
+    Right a -> pure a
+    Left e  -> decodeValueFailed "base64-text" "Text" (Just (T.pack e))
+
 lazyBytestring :: DecodeValue LBS.ByteString
 lazyBytestring =
   LBS.fromStrict <$> bytestring
@@ -256,7 +277,7 @@ json = do
   t <- text
   case J.eitherDecode (LBS.fromStrict (T.encodeUtf8 t)) of
     Right v -> pure v
-    Left e -> decodeValueFailed "json" "Value" (Just (T.pack e))
+    Left e  -> decodeValueFailed "json" "Value" (Just (T.pack e))
 
 timeOfDay :: DecodeValue TimeOfDay
 timeOfDay = do
@@ -269,19 +290,19 @@ utcTime :: DecodeValue UTCTime
 utcTime = do
   t <- text
   case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> decodeValueFailed "utcTime" "UTCTime" Nothing
 
 uuid :: DecodeValue UUID
 uuid = do
   t <- text
   case UUID.fromString (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> decodeValueFailed "uuid" "UUID" Nothing
 
 day :: DecodeValue Day
 day = do
   t <- text
   case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack t) of
-    Just a -> pure a
+    Just a  -> pure a
     Nothing -> decodeValueFailed "day" "Day" Nothing
diff --git a/src/Data/RdsData/Default.hs b/src/Data/RdsData/Default.hs
@@ -7,4 +7,4 @@ module Data.RdsData.Default
 import           Data.Text
 
 projectDefaultLocalStack :: Text
-projectDefaultLocalStack = "localstack/localstack-pro:3.7.2"
+projectDefaultLocalStack = "localstack/localstack-pro:latest"
diff --git a/src/Data/RdsData/Encode/Param.hs b/src/Data/RdsData/Encode/Param.hs
@@ -31,6 +31,8 @@ module Data.RdsData.Encode.Param
   , int8
   , json
   , lazyBytestring
+  , base64Text
+  , lazyBase64Text
   , lazyText
   , timeOfDay
   , ulid
@@ -62,9 +64,13 @@ import qualified Amazonka.Bytes                as AWS
 import qualified Amazonka.Data.Base64          as AWS
 import qualified Amazonka.RDSData              as AWS
 import qualified Data.Aeson                    as J
+import qualified Data.ByteString.Base64        as B64
+import qualified Data.ByteString.Base64.Lazy   as LB64
 import qualified Data.ByteString.Lazy          as LBS
 import qualified Data.RdsData.Internal.Convert as CONV
+import qualified Data.Text.Encoding            as T
 import qualified Data.Text.Lazy                as LT
+import qualified Data.Text.Lazy.Encoding       as LT
 import qualified Prelude                       as P
 
 newtype EncodeParam a = EncodeParam
@@ -179,6 +185,14 @@ lazyBytestring :: EncodeParam LBS.ByteString
 lazyBytestring =
   LBS.toStrict >$< bytestring
 
+base64Text :: EncodeParam ByteString
+base64Text =
+  (T.decodeUtf8 . B64.encode) >$< text
+
+lazyBase64Text :: EncodeParam LBS.ByteString
+lazyBase64Text =
+  (LT.decodeUtf8 . LB64.encode) >$< lazyText
+
 timeOfDay :: EncodeParam TimeOfDay
 timeOfDay =
   CONV.timeOfDayToText >$< text & typed AWS.TypeHint_TIME