Skip to content

Instantly share code, notes, and snippets.

@jkachmar
Last active October 5, 2023 21:11
Show Gist options
  • Save jkachmar/12737c17aa2cf04d66a2af14782fc7f3 to your computer and use it in GitHub Desktop.
Save jkachmar/12737c17aa2cf04d66a2af14782fc7f3 to your computer and use it in GitHub Desktop.
UUID as Primary Key in Persistent
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Example where
import ClassyPrelude
import Data.Aeson
import qualified Data.ByteString.Char8 as B8
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import Database.Persist.Postgresql
import Database.Persist.TH
import GHC.Generics
import Web.PathPieces
--------------------------------------------------------------------------------
-- | Persistent instances for @UUID@.
instance PersistField UUID where
toPersistValue uuid = PersistDbSpecific . B8.pack . UUID.toString $ uuid
fromPersistValue (PersistDbSpecific uuidB8) =
case UUID.fromString $ B8.unpack uuidB8 of
Just uuid -> Right uuid
Nothing -> Left "Invalid UUID"
fromPersistValue _ = Left "Not PersistDBSpecific"
instance PersistFieldSql UUID where
sqlType _ = SqlOther "uuid"
instance PathPiece UUID where
toPathPiece = tshow
fromPathPiece = readMay
--------------------------------------------------------------------------------
-- | Aeson @FromJSON@ and @ToJSON@ instances for @UUID@.
instance FromJSON UUID where
parseJSON = withText "UUID" $ \uuidStr ->
case UUID.fromText uuidStr of
Just uuid -> pure uuid
Nothing -> fail "Failed to parse UUID"
instance ToJSON UUID where
toJSON = String . UUID.toText
--------------------------------------------------------------------------------
-- | Persistent model definition.
share
[mkPersist sqlSettings
, mkMigrate "migrateAll"
] [persistLowerCase|
SomeThing sql=some_things
Id UUID sqltype=uuid
stuff Text sqltype=Text
things Text sqltype=Text
deriving Eq Generic Show
|]
main :: IO ()
main = mockMigration migrateAll
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment