From 077910f9c0560328949ca7f2e2ab639236f3c523 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 15 Jun 2022 02:34:11 +0200
Subject: add some persist stuff

this doesn't yet actually use the database, but it's getting close to
3am and I should probably go to bed or something
---
 lib/PersistOrphans.hs | 34 ++++++++++++++++++++++++++++++++++
 1 file changed, 34 insertions(+)
 create mode 100644 lib/PersistOrphans.hs

(limited to 'lib/PersistOrphans.hs')

diff --git a/lib/PersistOrphans.hs b/lib/PersistOrphans.hs
new file mode 100644
index 0000000..68e9738
--- /dev/null
+++ b/lib/PersistOrphans.hs
@@ -0,0 +1,34 @@
+-- | This module contains instances for the Data.UUID UUID type
+-- to be mapped to postgresql's custom builtin uuid type.
+--
+-- Unfortunately, this breaks compatability with other SQL databases
+-- (though uuids aren't really supported by most anyways)
+module PersistOrphans where
+
+
+import           Data.Either.Combinators (maybeToRight)
+import qualified Data.Text               as T
+import           Data.UUID               (UUID)
+import           Data.UUID               as UUID
+import           Data.UUID.V4
+import           Database.Persist        (PersistField (..),
+                                          PersistValue (PersistLiteralEscaped),
+                                          SqlType (SqlOther))
+import           Database.Persist.Sql    (PersistFieldSql (..), SqlBackend,
+                                          migrate, runMigration)
+import           Web.PathPieces          (PathPiece (..))
+
+
+instance PersistField UUID where
+  toPersistValue = PersistLiteralEscaped . UUID.toASCIIBytes
+  fromPersistValue (PersistLiteralEscaped buf) =
+    maybeToRight "not a uuid (cannot decode)" $ UUID.fromASCIIBytes buf
+  fromPersistValue v = Left $ "not a uuid (wrong type in database): " <> T.pack (show v)
+  -- postgres is type-safe, so this should /hopefully/ never happen
+instance PersistFieldSql UUID where
+  sqlType = const $ SqlOther "uuid"
+instance PathPiece UUID where
+  fromPathPiece = UUID.fromText
+  toPathPiece = UUID.toText
+
+
-- 
cgit v1.2.3