Add FromField and ToField instance for Data.UUID

The implementation is based on `postgresql-simple`[1][2]. `uuid-types`[3] is used because it contains fewer transitive dependencies, but `uuid`[4] is used as a dependency for the test case. This fixes nurpax#62. [1]: https://hackage.haskell.org/package/postgresql-simple-0.5.3.0/docs/Database-PostgreSQL-Simple-FromField.html#t:FromField [2]: https://hackage.haskell.org/package/postgresql-simple-0.6.2/docs/Database-PostgreSQL-Simple-ToField.html#t:ToField [3]: https://hackage.haskell.org/package/uuid-types-1.0.3 [4]: https://hackage.haskell.org/package/uuid
mkoppmann · Oct 25, 2020 · 37c9136 · 37c9136
1 parent 4939058
commit 37c9136
Show file tree

Hide file tree

Showing 5 changed files with 33 additions and 0 deletions.
diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs
@@ -43,6 +43,8 @@ import           Data.Time (UTCTime, Day)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
 import           Data.Typeable (Typeable, typeOf)
+import           Data.UUID.Types (UUID)
+import qualified Data.UUID.Types as UUID
 import           Data.Word (Word8, Word16, Word32, Word64)
 import           GHC.Float (double2Float)
 
@@ -185,6 +187,13 @@ instance FromField UTCTime where
 
   fromField f = returnError ConversionFailed f "expecting SQLText column type"
 
+instance FromField UUID where
+  fromField f@(Field (SQLText t) _) =
+    case UUID.fromText t of
+      Just uuid -> Ok uuid
+      Nothing -> returnError ConversionFailed f "couldn't parse UUID field"
+
+  fromField f = returnError ConversionFailed f "expecting SQLText column type"
 
 instance FromField Day where
   fromField f@(Field (SQLText t) _) =

diff --git a/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs
@@ -26,6 +26,8 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Encoding as T
 import           Data.Time (Day, UTCTime)
+import           Data.UUID.Types (UUID)
+import qualified Data.UUID.Types as UUID
 import           Data.Word (Word8, Word16, Word32, Word64)
 import           GHC.Float
 
@@ -132,6 +134,10 @@ instance ToField UTCTime where
     toField = SQLText . T.decodeUtf8 . toByteString . utcTimeToBuilder
     {-# INLINE toField #-}
 
+instance ToField UUID where
+    toField = SQLText . UUID.toText
+    {-# INLINE toField #-}
+
 instance ToField Day where
     toField = SQLText . T.decodeUtf8 . toByteString . dayToBuilder
     {-# INLINE toField #-}

diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal
@@ -56,6 +56,7 @@ Library
     text >= 0.11,
     time,
     transformers,
+    uuid-types >= 1.0.0,
     Only >= 0.1 && < 0.1.1
 
   default-extensions:
@@ -108,3 +109,4 @@ test-suite test
                , direct-sqlite
                , text
                , time
+               , uuid
diff --git a/test/Main.hs b/test/Main.hs
@@ -33,6 +33,7 @@ tests =
     , TestLabel "Simple"    . testSimpleQueryCov
     , TestLabel "Simple"    . testSimpleStrings
     , TestLabel "Simple"    . testSimpleChanges
+    , TestLabel "Simple"    . testSimpleUUID
     , TestLabel "ParamConv" . testParamConvNull
     , TestLabel "ParamConv" . testParamConvInt
     , TestLabel "ParamConv" . testParamConvIntWidths

diff --git a/test/Simple.hs b/test/Simple.hs
@@ -15,6 +15,7 @@ module Simple (
   , testSimpleQueryCov
   , testSimpleStrings
   , testSimpleChanges
+  , testSimpleUUID
   ) where
 
 import qualified Data.ByteString as BS
@@ -24,6 +25,8 @@ import           Data.ByteString.Lazy.Char8 ()
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
 import           Data.Time (UTCTime, Day)
+import           Data.UUID (UUID)
+import qualified Data.UUID.V4 as UUID
 
 import           Common
 
@@ -154,6 +157,18 @@ testSimpleMultiInsert TestEnv{..} = TestCase $ do
   rows <- query_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)]
   [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows
 
+testSimpleUUID :: TestEnv -> Test
+testSimpleUUID TestEnv{..} = TestCase $ do
+  uuids <- sequenceA $ replicate 5 UUID.nextRandom
+  execute_ conn "CREATE TABLE uuids (id UUID)"
+  mapM_ (execute conn "INSERT INTO uuids (id) VALUES (?)" . Only) uuids
+  ids <- query_ conn "SELECT id from uuids" :: IO [Only UUID]
+  mapM_ matchIds (zip uuids ids)
+  where
+    matchIds (uuid, Only uid) = do
+      uuid @=? uid
+
+
 testSimpleUTCTime :: TestEnv -> Test
 testSimpleUTCTime TestEnv{..} = TestCase $ do
   -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html