summaryrefslogtreecommitdiff
path: root/overlays/spm/server/Data
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/server/Data')
-rw-r--r--overlays/spm/server/Data/CaseInsensitive/Instances.hs30
-rw-r--r--overlays/spm/server/Data/UUID/Instances.hs31
2 files changed, 61 insertions, 0 deletions
diff --git a/overlays/spm/server/Data/CaseInsensitive/Instances.hs b/overlays/spm/server/Data/CaseInsensitive/Instances.hs
new file mode 100644
index 00000000..1f3f7a11
--- /dev/null
+++ b/overlays/spm/server/Data/CaseInsensitive/Instances.hs
@@ -0,0 +1,30 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Data.CaseInsensitive.Instances () where
5
6import Prelude
7import Database.Persist
8import Database.Persist.Sql
9
10import Data.CaseInsensitive (CI)
11import qualified Data.CaseInsensitive as CI
12
13import Data.Text (Text)
14import qualified Data.Text as Text
15import qualified Data.Text.Encoding as Text
16
17import Control.Exception
18
19
20instance PersistField (CI Text) where
21 toPersistValue = PersistLiteralEscaped . Text.encodeUtf8 . CI.original
22 fromPersistValue = \case
23 PersistText t -> Right $ CI.mk t
24 PersistLiteralEscaped bs -> case Text.decodeUtf8' bs of
25 Right t -> Right $ CI.mk t
26 Left err -> Left $ "Could not decode PersistLiteral as UTF-8: " <> Text.pack (displayException err)
27 o -> Left $ "Expected PersistText or PersistLiteral but got ‘" <> Text.pack (show o) <> "’"
28
29instance PersistFieldSql (CI Text) where
30 sqlType _ = SqlOther "citext"
diff --git a/overlays/spm/server/Data/UUID/Instances.hs b/overlays/spm/server/Data/UUID/Instances.hs
new file mode 100644
index 00000000..b2268c96
--- /dev/null
+++ b/overlays/spm/server/Data/UUID/Instances.hs
@@ -0,0 +1,31 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE OverloadedStrings #-}
3
4module Data.UUID.Instances () where
5
6import Prelude
7import Database.Persist
8import Database.Persist.Sql
9import Data.UUID (UUID)
10import qualified Data.UUID as UUID
11
12import qualified Data.ByteString.Char8 as CBS
13import qualified Data.Text as Text
14
15import Web.PathPieces
16
17
18instance PersistField UUID where
19 toPersistValue = PersistLiteralEscaped . CBS.pack . UUID.toString
20 fromPersistValue (PersistLiteralEscaped uuidB8) =
21 case UUID.fromString $ CBS.unpack uuidB8 of
22 Just uuid -> Right uuid
23 Nothing -> Left "Invalid UUID"
24 fromPersistValue v = Left $ "Expected PersistLiteral but got ‘" <> Text.pack (show v) <> "’"
25
26instance PersistFieldSql UUID where
27 sqlType _ = SqlOther "uuid"
28
29instance PathPiece UUID where
30 toPathPiece = Text.pack . UUID.toString
31 fromPathPiece = UUID.fromString . Text.unpack