From 84f2affd66a0ff3947b91a30308cb8e6a8ff7594 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 19 May 2022 22:05:02 +0200
Subject: surtr: ...

---
 .../spm/server/Data/CaseInsensitive/Instances.hs   | 30 +++++++++++++++++++++
 .../surtr/email/spm/server/Data/UUID/Instances.hs  | 31 ++++++++++++++++++++++
 2 files changed, 61 insertions(+)
 create mode 100644 hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
 create mode 100644 hosts/surtr/email/spm/server/Data/UUID/Instances.hs

(limited to 'hosts/surtr/email/spm/server/Data')

diff --git a/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
new file mode 100644
index 00000000..1f3f7a11
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Data/CaseInsensitive/Instances.hs
@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.CaseInsensitive.Instances () where
+
+import Prelude
+import Database.Persist
+import Database.Persist.Sql
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+import Control.Exception
+
+
+instance PersistField (CI Text) where
+  toPersistValue = PersistLiteralEscaped . Text.encodeUtf8 . CI.original
+  fromPersistValue = \case
+    PersistText t -> Right $ CI.mk t
+    PersistLiteralEscaped bs -> case Text.decodeUtf8' bs of
+      Right t   -> Right $ CI.mk t
+      Left  err -> Left $ "Could not decode PersistLiteral as UTF-8: " <> Text.pack (displayException err)
+    o -> Left $ "Expected PersistText or PersistLiteral but got ‘" <> Text.pack (show o) <> "’"
+
+instance PersistFieldSql (CI Text) where
+  sqlType _ = SqlOther "citext"
diff --git a/hosts/surtr/email/spm/server/Data/UUID/Instances.hs b/hosts/surtr/email/spm/server/Data/UUID/Instances.hs
new file mode 100644
index 00000000..b2268c96
--- /dev/null
+++ b/hosts/surtr/email/spm/server/Data/UUID/Instances.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.UUID.Instances () where
+
+import Prelude
+import Database.Persist
+import Database.Persist.Sql
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import qualified Data.ByteString.Char8 as CBS
+import qualified Data.Text as Text
+
+import Web.PathPieces
+  
+
+instance PersistField UUID where
+  toPersistValue = PersistLiteralEscaped . CBS.pack . UUID.toString
+  fromPersistValue (PersistLiteralEscaped uuidB8) =
+    case UUID.fromString $ CBS.unpack uuidB8 of
+      Just uuid -> Right uuid
+      Nothing   -> Left "Invalid UUID"
+  fromPersistValue v = Left $ "Expected PersistLiteral but got ‘" <> Text.pack (show v) <> "’"
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
+instance PathPiece UUID where
+  toPathPiece = Text.pack . UUID.toString
+  fromPathPiece = UUID.fromString . Text.unpack
-- 
cgit v1.2.3