diff --git a/rds-data-codecs.cabal b/rds-data-codecs.cabal --- a/rds-data-codecs.cabal +++ b/rds-data-codecs.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: rds-data-codecs -version: 0.0.0.2 +version: 0.0.0.3 synopsis: Codecs for use with AWS rds-data description: Codecs for use with AWS rds-data. category: Data @@ -56,6 +56,7 @@ common text { build-depends: text >= 2.1 && < 3 } common time { build-depends: time >= 1.12.2 && < 2 } common transformers { build-depends: transformers >= 0.5 && < 0.7 } +common ulid { build-depends: ulid >= 0.3.2.0 && < 0.4 } common uuid { build-depends: uuid >= 1.3.15 && < 1.4 } common rds-data-codecs @@ -89,6 +90,7 @@ , text , time , transformers + , ulid , uuid exposed-modules: Data.RdsData Data.RdsData.Decode.Array @@ -122,6 +124,7 @@ , optparse-applicative , text , time + , ulid , uuid main-is: Main.hs other-modules: App.AWS.Env @@ -154,6 +157,7 @@ , tasty-hedgehog , text , time + , ulid , uuid type: exitcode-stdio-1.0 main-is: Spec.hs diff --git a/src/Data/RdsData/Decode/Array.hs b/src/Data/RdsData/Decode/Array.hs --- a/src/Data/RdsData/Decode/Array.hs +++ b/src/Data/RdsData/Decode/Array.hs @@ -17,23 +17,24 @@ , integers , texts - , ints - , int8s + , days , int16s , int32s , int64s - , words - , word8s - , word16s - , word32s - , word64s + , int8s + , ints + , jsons , lazyTexts , strings - , jsons , timesOfDay + , ulids , utcTimes - , days , uuids + , word16s + , word32s + , word64s + , word8s + , words ) where import Control.Applicative @@ -42,16 +43,18 @@ import Data.RdsData.Types.Array import Data.Text (Text) import Data.Time +import Data.ULID (ULID) import Data.UUID (UUID) import Data.Word import Prelude hiding (maybe, null, words) -import qualified Data.Aeson as J -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 qualified Data.Aeson as J +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 newtype DecodeArray a = DecodeArray { decodeArray :: Array -> Either Text a @@ -194,6 +197,16 @@ case traverse (parseTimeM True defaultTimeLocale "%Y-%m-%d" . T.unpack) ts of Just d -> pure d Nothing -> DecodeArray \_ -> Left "Failed to decode Day" + +-- | Decode an array of ULIDs +-- ULIDs are encoded as strings in the database and have have better database performance +-- than UUIDs stored as strings in the database. +ulids :: DecodeArray [ULID] +ulids = do + ts <- texts + case traverse CONV.textToUlid ts of + Right u -> pure u + Left msg -> DecodeArray \_ -> Left $ "Failed to decode UUID: " <> msg uuids :: DecodeArray [UUID] uuids = do diff --git a/src/Data/RdsData/Decode/Row.hs b/src/Data/RdsData/Decode/Row.hs --- a/src/Data/RdsData/Decode/Row.hs +++ b/src/Data/RdsData/Decode/Row.hs @@ -25,6 +25,7 @@ , lazyBytestring , timeOfDay , day + , ulid , utcTime , uuid , ignore @@ -45,16 +46,18 @@ 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 -import qualified Data.RdsData.Decode.Value as DV -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.UUID as UUID +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as LBS +import qualified Data.RdsData.Decode.Value as DV +import qualified Data.RdsData.Internal.Convert as CONV +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.UUID as UUID newtype DecodeRow a = DecodeRow { unDecodeRow :: ExceptT Text (StateT [Value] Identity) a @@ -178,6 +181,13 @@ case parseTimeM True defaultTimeLocale "%H:%M:%S%Q" (T.unpack t) of 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 + Left msg -> throwError $ "Failed to parse ULID: " <> msg utcTime :: DecodeRow UTCTime utcTime = do diff --git a/src/Data/RdsData/Encode/Array.hs b/src/Data/RdsData/Encode/Array.hs --- a/src/Data/RdsData/Encode/Array.hs +++ b/src/Data/RdsData/Encode/Array.hs @@ -11,21 +11,23 @@ , integers , texts - , ints - , int8s + , days , int16s , int32s , int64s - , words - , word8s - , word16s - , word32s - , word64s + , int8s + , ints + , jsons , lazyTexts , timesOfDay - , days - , jsons + , ulids + , uuids , utcTimes + , word16s + , word32s + , word64s + , word8s + , words ) where import Data.Functor.Contravariant @@ -34,6 +36,8 @@ import Data.RdsData.Types.Array (Array(..)) import Data.Text (Text) import Data.Time +import Data.ULID +import Data.UUID import Data.Word import Prelude hiding (words) @@ -135,6 +139,14 @@ jsons :: EncodeArray [J.Value] jsons = fmap jsonToText >$< texts + +ulids :: EncodeArray [ULID] +ulids = + fmap ulidToText >$< texts + +uuids :: EncodeArray [UUID] +uuids = + fmap uuidToText >$< texts utcTimes :: EncodeArray [UTCTime] utcTimes = diff --git a/src/Data/RdsData/Encode/Param.hs b/src/Data/RdsData/Encode/Param.hs --- a/src/Data/RdsData/Encode/Param.hs +++ b/src/Data/RdsData/Encode/Param.hs @@ -25,21 +25,22 @@ , base64 , day , int - , int8 , int16 , int32 , int64 + , int8 , json , lazyBytestring , lazyText , timeOfDay + , ulid , utcTime , uuid , word - , word8 , word16 , word32 , word64 + , word8 ) where import Control.Lens @@ -52,6 +53,7 @@ import Data.RdsData.Types.Param import Data.Text (Text) import Data.Time +import Data.ULID (ULID) import Data.UUID (UUID) import Data.Word import Prelude hiding (maybe, null) @@ -188,6 +190,10 @@ json :: EncodeParam J.Value json = CONV.jsonToText >$< text & typed AWS.TypeHint_JSON + +ulid :: EncodeParam ULID +ulid = + CONV.ulidToText >$< text utcTime :: EncodeParam UTCTime utcTime = diff --git a/src/Data/RdsData/Encode/Params.hs b/src/Data/RdsData/Encode/Params.hs --- a/src/Data/RdsData/Encode/Params.hs +++ b/src/Data/RdsData/Encode/Params.hs @@ -28,6 +28,7 @@ , lazyBytestring , lazyText , timeOfDay + , ulid , utcTime , uuid , word @@ -47,6 +48,7 @@ import Data.Text (Text) import Data.Time import Data.UUID (UUID) +import Data.ULID (ULID) import Data.Void import Data.Word import Prelude hiding (maybe, null) @@ -196,6 +198,10 @@ json :: EncodeParams J.Value json = column EP.json + +ulid :: EncodeParams ULID +ulid = + column EP.ulid utcTime :: EncodeParams UTCTime utcTime = diff --git a/src/Data/RdsData/Encode/Row.hs b/src/Data/RdsData/Encode/Row.hs --- a/src/Data/RdsData/Encode/Row.hs +++ b/src/Data/RdsData/Encode/Row.hs @@ -28,6 +28,7 @@ , lazyBytestring , lazyText , timeOfDay + , ulid , utcTime , uuid , word @@ -46,6 +47,7 @@ import Data.RdsData.Types.Value import Data.Text (Text) import Data.Time +import Data.ULID (ULID) import Data.UUID (UUID) import Data.Void import Data.Word @@ -196,6 +198,10 @@ json :: EncodeRow J.Value json = column EV.json + +ulid :: EncodeRow ULID +ulid = + column EV.ulid utcTime :: EncodeRow UTCTime utcTime = diff --git a/src/Data/RdsData/Encode/Value.hs b/src/Data/RdsData/Encode/Value.hs --- a/src/Data/RdsData/Encode/Value.hs +++ b/src/Data/RdsData/Encode/Value.hs @@ -27,6 +27,7 @@ , lazyText , timeOfDay , utcTime + , ulid , uuid , word , word8 @@ -42,6 +43,7 @@ import Data.RdsData.Types.Value import Data.Text (Text) import Data.Time +import Data.ULID (ULID) import Data.UUID (UUID) import Data.Word import Prelude hiding (maybe, null) @@ -173,6 +175,10 @@ utcTime :: EncodeValue UTCTime utcTime = CONV.utcTimeToText >$< text + +ulid :: EncodeValue ULID +ulid = + CONV.ulidToText >$< text uuid :: EncodeValue UUID uuid = diff --git a/src/Data/RdsData/Internal/Convert.hs b/src/Data/RdsData/Internal/Convert.hs --- a/src/Data/RdsData/Internal/Convert.hs +++ b/src/Data/RdsData/Internal/Convert.hs @@ -1,23 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Data.RdsData.Internal.Convert ( dayToText , jsonToText , timeOfDayToText + , ulidToText , uuidToText , utcTimeToText , textToDouble + , textToUlid ) where +import Data.Bifunctor +import Data.ULID (ULID) import Data.UUID (UUID) import Data.Text (Text) import Data.Time + ( formatTime, defaultTimeLocale, Day, UTCTime, TimeOfDay ) import Prelude hiding (maybe, null) +import Text.Read import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.ULID as ULID +import qualified Data.ULID.Base32 as ULID import qualified Data.UUID as UUID timeOfDayToText :: TimeOfDay -> Text @@ -35,6 +44,14 @@ utcTimeToText :: UTCTime -> Text utcTimeToText = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" + +ulidToText :: ULID -> Text +ulidToText = + ULID.encode 26 . ULID.ulidToInteger + +textToUlid :: Text -> Either Text ULID +textToUlid t = + bimap (const ("Unable to decode ULID: " <> t)) id (readEither @ULID (T.unpack t)) uuidToText :: UUID -> Text uuidToText = diff --git a/test/Data/RdsData/TestTypes.hs b/test/Data/RdsData/TestTypes.hs --- a/test/Data/RdsData/TestTypes.hs +++ b/test/Data/RdsData/TestTypes.hs @@ -13,6 +13,7 @@ import Data.RdsData.Internal.Aeson () import Data.Text (Text) import Data.Time (Day, TimeOfDay(..), UTCTime) +import Data.ULID (ULID) import Data.UUID (UUID) import GHC.Generics @@ -43,6 +44,7 @@ , times :: TimeOfDay , timestamp :: UTCTime , timestamps :: UTCTime + , ulid :: ULID , uuid :: UUID } deriving (Show, Eq, Generic) diff --git a/test/Data/RdsDataSpec.hs b/test/Data/RdsDataSpec.hs --- a/test/Data/RdsDataSpec.hs +++ b/test/Data/RdsDataSpec.hs @@ -69,6 +69,7 @@ <*> DEC.timeOfDay <*> DEC.utcTime <*> DEC.utcTime + <*> DEC.ulid <*> DEC.uuid values >>= either (\s -> H.noteShow_ s >> H.failure) pure @@ -99,6 +100,7 @@ , TT.times = TimeOfDay 12 34 56.78 , TT.timestamp = read "2024-02-04 12:34:56 UTC" , TT.timestamps = read "2024-02-04 12:34:56 UTC" + , TT.ulid = read "0123456789ABCDEFGHJKMNPQRS" , TT.uuid = read "550e8400-e29b-41d4-a716-446655440000" } ] @@ -132,6 +134,7 @@ , TT.times = TimeOfDay 12 34 56.78 , TT.timestamp = read "2024-02-04 12:34:56 UTC" , TT.timestamps = read "2024-02-04 12:34:56 UTC" + , TT.ulid = read "0123456789ABCDEFGHJKMNPQRS" , TT.uuid = read "550e8400-e29b-41d4-a716-446655440000" } diff --git a/test/files/rds-schema.sql b/test/files/rds-schema.sql --- a/test/files/rds-schema.sql +++ b/test/files/rds-schema.sql @@ -23,5 +23,6 @@ the_times time(2) not null, the_timestamp timestamp not null, the_timestamps timestamp(2) not null, - the_uuid uuid not null + the_uuid uuid not null, + the_ulid char(16) not null ) diff --git a/test/files/rds-value.sql b/test/files/rds-value.sql --- a/test/files/rds-value.sql +++ b/test/files/rds-value.sql @@ -49,5 +49,6 @@ '12:34:56.78', -- the_times '2024-02-04 12:34:56', -- the_timestamp '2024-02-04 12:34:56', -- the_timestamps + '0123456789ABCDEFGHJKMNPQRS', -- the_ulid '550e8400-e29b-41d4-a716-446655440000' -- the_uuid ); diff --git a/test/files/row.json b/test/files/row.json --- a/test/files/row.json +++ b/test/files/row.json @@ -76,6 +76,9 @@ "stringValue": "2024-02-04 12:34:56" }, { + "stringValue": "0123456789ABCDEFGHJKMNPQRS" + }, + { "stringValue": "550e8400-e29b-41d4-a716-446655440000" } ] diff --git a/test/files/schema.sql b/test/files/schema.sql --- a/test/files/schema.sql +++ b/test/files/schema.sql @@ -41,6 +41,7 @@ the_timestamps timestamp(2) not null, the_tsquery tsquery not null, the_tsvector tsvector not null, + the_ulid char(16) not null, the_uuid uuid not null, the_xml xml not null ) diff --git a/test/files/value.sql b/test/files/value.sql --- a/test/files/value.sql +++ b/test/files/value.sql @@ -86,6 +86,7 @@ '2024-02-04 12:34:56', -- the_timestamps to_tsquery('english', 'query'), -- the_tsquery to_tsvector('english', 'document'), -- the_tsvector + '0123456789ABCDEFGHJKMNPQRS', -- the_ulid '550e8400-e29b-41d4-a716-446655440000', -- the_uuid 'data' -- the_xml );