Persistent 中不区分大小写的唯一性约束？

Question

这可能是一个愚蠢的问题，我以某种方式忽略了具有低于标准 Google-fu 技能的现有内容，但是有没有办法使用 Persistent 创建一个新的文本字段，对该字段有唯一性约束，从而唯一性不区分大小写？例如，假设我想创建一个唯一且没有重复的用户名字段，这样四个不同的用户就无法创建撒旦、SATAN、satan 和 SaTaN 用户名记录？

或者我是否必须依靠 Postgres 特定的功能并使用原始 SQL 来实现这一点？或者它可能在不使用原始 SQL 的情况下在 esqueleto 中完成？

更新 1： 我尝试将@MaxGabriel 的修订版添加为src/ModelTypes.hs 在新的脚手架 Yesod 站点中并将其导入src/Model.hs。为此，我似乎必须添加 import Database.Persist.Sql 以消除一个编译器错误，现在我在运行 yesod devel 时遇到此错误 3 次：

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

尚未更新 config/models.persistentmodels 中的脚手架用户模型（由虚拟身份验证使用）以使用新的 Username 类型...

User
    ident Text
    password Text Maybe
    UniqueUser ident
    deriving Typeable

...但是在之前尝试简单地将ident 更改为使用citext 时，它可以将新记录插入数据库，但在尝试检索和转换该记录的类型时似乎犹豫不决对用户进行身份验证。

更新 2： 将import Data.Text (Text)添加到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.

更新 3：

将{-# LANGUAGE FlexibleInstances #-} 添加到ModelType.hs 后，上述错误消失。在尝试像这样在脚手架 User 模型中使用新的 Username 类型时

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

发生了一个新错误：

[ 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

是的，这是可能的。从上面卡尔的评论中使用citext 列类型作为不区分大小写的字符串类型，你可以使用这样的东西。

首先，为CI Text添加PersistField和PersistFieldSql实例，Text不区分大小写。这必须在您使用 Template Haskell 声明持久模型的单独文件中完成。在这个文件中，您可以为Username 添加一个新类型，或者您可以直接在您的持久模型中使用CI Text。为了可读性，我推荐使用 newtype 方法。

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

然后，将该文件导入到使用 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 ()

但请注意，在执行代码之前，您需要为数据库创建扩展：

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

然后就可以执行代码了：

$ 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}

然后您可以去实际检查数据库以确认确实创建了 citext 列：

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)