UUID as Primary Key in Persistent

Example.hs

{-# 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