Merge pull request #4 from haskell-works/newhoggy/add-ulid-support

Add `ulid` support

rds-data-codecs.cabal

@@ -56,6 +56,7 @@ common tasty-hedgehog             { build-depends: tasty-hedgehog             >=
 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 @@ library
                       , text
                       , time
                       , transformers
+                      , ulid
                       , uuid
   exposed-modules:      Data.RdsData
                         Data.RdsData.Decode.Array
@@ -122,6 +124,7 @@ executable rds-data-codecs
                       , optparse-applicative
                       , text
                       , time
+                      , ulid
                       , uuid
   main-is:              Main.hs
   other-modules:        App.AWS.Env
@@ -154,6 +157,7 @@ test-suite rds-data-codecs-test
                       , tasty-hedgehog
                       , text
                       , time
+                      , ulid
                       , uuid
   type:                 exitcode-stdio-1.0
   main-is:              Spec.hs

src/Data/RdsData/Decode/Array.hs

@@ -17,23 +17,24 @@ module Data.RdsData.Decode.Array
   , 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.Internal.Aeson
 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
@@ -195,6 +198,16 @@ days = do
     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
   ts <- texts

src/Data/RdsData/Decode/Row.hs

@@ -25,6 +25,7 @@ module Data.RdsData.Decode.Row
   , lazyBytestring
   , timeOfDay
   , day
+  , ulid
   , utcTime
   , uuid
   , ignore
@@ -45,16 +46,18 @@ 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
-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
@@ -179,6 +182,13 @@ timeOfDay = do
     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
   t <- text

src/Data/RdsData/Encode/Array.hs

@@ -11,21 +11,23 @@ module Data.RdsData.Encode.Array
   , 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.Internal.Convert
 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)
 
@@ -136,6 +140,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 =
   fmap utcTimeToText >$< texts

src/Data/RdsData/Encode/Param.hs

@@ -25,21 +25,22 @@ module Data.RdsData.Encode.Param
   , 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.Value
 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)
@@ -189,6 +191,10 @@ json :: EncodeParam J.Value
 json =
   CONV.jsonToText >$< text & typed AWS.TypeHint_JSON
 
+ulid :: EncodeParam ULID
+ulid =
+  CONV.ulidToText >$< text
+
 utcTime :: EncodeParam UTCTime
 utcTime =
   CONV.utcTimeToText >$< text & typed AWS.TypeHint_TIMESTAMP

src/Data/RdsData/Encode/Params.hs

@@ -28,6 +28,7 @@ module Data.RdsData.Encode.Params
   , lazyBytestring
   , lazyText
   , timeOfDay
+  , ulid
   , utcTime
   , uuid
   , word
@@ -47,6 +48,7 @@ import Data.RdsData.Types.Param
 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)
@@ -197,6 +199,10 @@ json :: EncodeParams J.Value
 json =
   column EP.json
 
+ulid :: EncodeParams ULID
+ulid =
+  column EP.ulid
+
 utcTime :: EncodeParams UTCTime
 utcTime =
   column EP.utcTime

src/Data/RdsData/Encode/Row.hs

@@ -28,6 +28,7 @@ module Data.RdsData.Encode.Row
   , lazyBytestring
   , lazyText
   , timeOfDay
+  , ulid
   , utcTime
   , uuid
   , word
@@ -46,6 +47,7 @@ import Data.RdsData.Encode.Value (EncodeValue(..))
 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
@@ -197,6 +199,10 @@ json :: EncodeRow J.Value
 json =
   column EV.json
 
+ulid :: EncodeRow ULID
+ulid =
+  column EV.ulid
+
 utcTime :: EncodeRow UTCTime
 utcTime =
   column EV.utcTime

src/Data/RdsData/Encode/Value.hs

@@ -27,6 +27,7 @@ module Data.RdsData.Encode.Value
   , lazyText
   , timeOfDay
   , utcTime
+  , ulid
   , uuid
   , word
   , word8
@@ -42,6 +43,7 @@ import Data.RdsData.Encode.Array
 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)
@@ -174,6 +176,10 @@ utcTime :: EncodeValue UTCTime
 utcTime =
   CONV.utcTimeToText >$< text
 
+ulid :: EncodeValue ULID
+ulid =
+  CONV.ulidToText >$< text
+
 uuid :: EncodeValue UUID
 uuid =
   CONV.uuidToText >$< text

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
@@ -36,6 +45,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 = 
   T.pack . UUID.toString