case-insensitive uniqueness constraints in Persistent?

Question

This is probably a stupid question and I'm somehow overlooking existing content with sub-par Google-fu skills, but is there a way to create a new Text field using Persistent, with a uniqueness constraint on that field, whereby uniqueness is case-insensitive? For example, say I want to create a Username field that is unique with no duplicates so that four different users cannot create the Satan, SATAN, satan, and SaTaN username records?

Or would I have to lean on Postgres-specific features and use raw SQL to achieve this? Or is it perhaps accomplished in esqueleto without using raw SQL?

Update 1: I tried addiing @MaxGabriel's revision as src/ModelTypes.hs in a newly scaffolded Yesod site & importing it in src/Model.hs. To this I seemed to have to add import Database.Persist.Sql to get rid of one compiler error, now I get this error 3 times while running yesod devel:

Not in scope: type constructor or class ‘Text’
Perhaps you meant ‘T.Text’ (imported from Data.Text)

Haven't yet updated the scaffodled User model (used by the dummy authentication) in config/models.persistentmodelsto use the new Username type ...

User
    ident Text
    password Text Maybe
    UniqueUser ident
    deriving Typeable

... but on previous attempts to simply change ident to use citext, it would work for inserting a new record into the db, but then seemed to balk at retrieving and converting the type of that record when trying to authenticate a user.

Update 2: Output after adding import Data.Text (Text) to ModelTypes.hs

>>> stack exec -- yesod devel                                                                                            
Yesod devel server. Enter 'quit' or hit Ctrl-C to quit.
Application can be accessed at:

http://localhost:3000
https://localhost:3443
If you wish to test https capabilities, you should set the following variable:
  export APPROOT=https://localhost:3443

uniqueci> configure (lib)
Configuring uniqueci-0.0.0...
uniqueci> build (lib)
Preprocessing library for uniqueci-0.0.0..
Building library for uniqueci-0.0.0..
[ 4 of 13] Compiling ModelTypes

/zd/pj/yesod/uniqueci/src/ModelTypes.hs:16:10: error:
    • Illegal instance declaration for ‘PersistField (CI Text)’
        (All instance types must be of the form (T a1 ... an)
         where a1 ... an are *distinct type variables*,
         and each type variable appears at most once in the instance head.
         Use FlexibleInstances if you want to disable this.)
    • In the instance declaration for ‘PersistField (CI Text)’
   |
16 | instance PersistField (CI Text) where
   |          ^^^^^^^^^^^^^^^^^^^^^^

/zd/pj/yesod/uniqueci/src/ModelTypes.hs:21:10: error:
    • Illegal instance declaration for ‘PersistFieldSql (CI Text)’
        (All instance types must be of the form (T a1 ... an)
         where a1 ... an are *distinct type variables*,
         and each type variable appears at most once in the instance head.
         Use FlexibleInstances if you want to disable this.)
    • In the instance declaration for ‘PersistFieldSql (CI Text)’
   |
21 | instance PersistFieldSql (CI Text) where
   |          ^^^^^^^^^^^^^^^^^^^^^^^^^

--  While building package uniqueci-0.0.0 using:
      /zd/hngnr/.stack_sym_ngnr/setup-exe-cache/x86_64-linux-tinfo6/Cabal-simple_mPHDZzAJ_3.0.1.0_ghc-8.8.4 --builddir=.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.0.1.0 build lib:uniqueci --ghc-options ""
    Process exited with code: ExitFailure 1
Type help for available commands. Press enter to force a rebuild.

Update 3:

After adding {-# LANGUAGE FlexibleInstances #-} to ModelType.hs, the above error goes away. Upon trying to use the new Username type in the scaffolded User model like so

-- config/models.persistentmodels

User
    ident Username        -- default is ident Text
    password Text Maybe
    UniqueUser ident
    deriving Typeable
Email
    email Text
    userId UserId Maybe
    verkey Text Maybe
    UniqueEmail email
Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
    message Text
    userId UserId Maybe
    deriving Eq
    deriving Show

a new error occurred:

[ 2 of 13] Compiling Model [config/models.persistentmodels changed]
[ 7 of 13] Compiling Foundation

/zd/pj/yesod/uniqueci/src/Foundation.hs:251:35: error:
    • Couldn't match expected type ‘ModelTypes.Username’
                  with actual type ‘Text’
    • In the second argument of ‘($)’, namely ‘credsIdent creds’
      In the second argument of ‘($)’, namely
        ‘UniqueUser $ credsIdent creds’
      In a stmt of a 'do' block:
        x <- getBy $ UniqueUser $ credsIdent creds
    |
251 |         x <- getBy $ UniqueUser $ credsIdent creds
    |                                   ^^^^^^^^^^^^^^^^

/zd/pj/yesod/uniqueci/src/Foundation.hs:255:31: error:
    • Couldn't match expected type ‘ModelTypes.Username’
                  with actual type ‘Text’
    • In the ‘userIdent’ field of a record
      In the first argument of ‘insert’, namely
        ‘User {userIdent = credsIdent creds, userPassword = Nothing}’
      In the second argument of ‘(<$>)’, namely
        ‘insert
           User {userIdent = credsIdent creds, userPassword = Nothing}’
    |
255 |                 { userIdent = credsIdent creds
    |                               ^^^^^^^^^^^^^^^^

Answer 1

Yes, that's possible. Taking Carl's comment from above of using the citext column type for case-insensitive character string type, you can use something like this.

First, add PersistField and PersistFieldSql instances for CI Text, which is case-insensitive Text. This must be done in a separate file from where you declare your Persistent models with Template Haskell. In this file, you can add a newtype for Username, or you can use CI Text directly in your Persistent models. I recommend the newtype approach for readability.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}

module ModelTypes where

import Database.Persist
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
-- Add the case-insensitive package for this:
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

instance PersistField (CI Text) where
  toPersistValue ciText = PersistDbSpecific $ TE.encodeUtf8 (CI.original ciText)
  fromPersistValue (PersistDbSpecific bs) = Right $ CI.mk (TE.decodeUtf8 bs)
  fromPersistValue x = Left . T.pack $ "When Expected PersistDbSpecific, received: " ++ show x

instance PersistFieldSql (CI Text) where
  sqlType _ = SqlOther "citext"

newtype Username = Username {unUsername :: CI Text}
  deriving stock (Show)
  deriving newtype (Eq, Ord, PersistField, PersistFieldSql)

Then, import that file into the file that loads your Persistent models with Template Haskell:

#!/usr/bin/env stack
{- stack
     --resolver lts-15
     --install-ghc
     runghc
     --package persistent
     --package persistent-postgresql
     --package persistent-template
     --package network
     --package mtl
-}


{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runStderrLoggingT)
import Database.Persist
import Database.Persist.Postgresql
import Database.Persist.TH
import ModelTypes

share
  [mkPersist sqlSettings, mkMigrate "migrateAll"]
  [persistLowerCase|
Person
    name Username
    UniqueName name
    deriving Show
|]

connStr = "host=localhost dbname=test user=postgres password=postgres port=5433"

main :: IO ()
main =
  runStderrLoggingT $
  withPostgresqlPool connStr 10 $
  \pool ->
     liftIO $
     do flip runSqlPersistMPool pool $
          do runMigration migrateAll
             johnId <- insert $ Person (Username "John Doe")
             liftIO $ print johnId
             return ()

But note that before executing the code, you need to create the extension for the database:

test=# \c test
test=# CREATE EXTENSION citext;
CREATE EXTENSION

And then you can execute the code:

$ stack postgres.hs
Migrating: CREATe TABLE "person"("id" SERIAL8  PRIMARY KEY UNIQUE,"name" citext NOT NULL)
[Debug#SQL] CREATe TABLE "person"("id" SERIAL8  PRIMARY KEY UNIQUE,"name" citext NOT NULL); []
Migrating: ALTER TABLE "person" ADD CONSTRAINT "unique_name" UNIQUE("name")
[Debug#SQL] ALTER TABLE "person" ADD CONSTRAINT "unique_name" UNIQUE("name"); []
[Debug#SQL] INSERT INTO "person"("name") VALUES(?) RETURNING "id"; [PersistText "John Doe"]
SqlBackendKey {unSqlBackendKey = 1}

And you can then go and actually inspect the database to confirm that citext column is indeed created:

test=# \d person;
                            Table "public.person"
 Column |  Type  | Collation | Nullable |              Default
--------+--------+-----------+----------+------------------------------------
 id     | bigint |           | not null | nextval('person_id_seq'::regclass)
 name   | citext |           | not null |
Indexes:
    "person_pkey" PRIMARY KEY, btree (id)
    "unique_name" UNIQUE CONSTRAINT, btree (name)