• 作成:

serversessionのアップデートで新しいpersistentに対応した時の格闘記録2

serversessionのアップデートで新しいpersistentに対応した時の格闘記録 - ncaq の続き。

この形式はZennとかでよく見るスクラップだなと気がついたので、次からはタイトルはスクラップとかにしたいですね。ここはZennではありませんが。

相も変わらず、 yesodweb/serversession: Secure, modular server-side sessions. の新しいLTS対応を行っていて、そこで障害になるpersistentのアップデートと戦っています。

今回のステータスは、土曜日16時間、日曜日12時間ぐらい寝たので、寝過ぎでは…? 何故かちょっと眠いけどメチャクチャ頭冴えて思いつかなかった正しい方法がわかるぞと思って、数時間バリバリと頭が動いてたんですが、頭が動きすぎて嫌な記憶が沸々と湧いてきたので頓服薬を飲んで対処したのと、ログ見返してみたら今日は4時間しか寝てなかったことが分かって結局ダメです。

前回の後日談

前回PRを出して「メンテナ誰ですか?」って聞いたり、現状のテストがTravis-CI(終わっているorgの方)だったりでちゃんと動いてるのかよく分からなすぎて、実際テストの一部をpendingしてたりしたのでGitHub Actionsに移行してたら、「メンテナ興味ない?やらない?」と言われたのでメンテナをやることになった。前回「無責任かもしれませんがPRを出します」とか書いてたら全ての責任を負うことになってしまった。いやMITライセンスなので無責任無保証ではあるのですが。

QuasiQuoteで自然キー指定するタイプの定義を書いてTHを展開してもらえば新しい構造がわかるのでは

しばらく置いてたらなんで思いつかなかったのかも分からない良いアイデアが浮かんできた。

ざっと見ると普通にpersistentでもPrimaryで自然キーを指定して人工キーを作らない方法はあるらしい。記法のリファレンスは3ステップ飛ばされたけど、今はGitHub WikiでもなくHaddockに全部書きだしてるんですね。 Database.Persist.Quasi

新しいpersistentでPrimaryを設定してもらった。古いLTSの方で行ったら古い形式が出てきた。 git initしないとHLSが動かないから展開できないのを忘れていた。

このTemplate Haskellを展開したら少しは分かってきそうですね。

展開前。

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
module Lib
    ( someFunc
    ) where

import Database.Persist.Quasi
import Database.Persist.TH

someFunc :: IO ()
someFunc = putStrLn "someFunc"

share [mkPersist sqlSettings, mkMigrate "migrateAll"]
  [persistLowerCase|
PersistentSession
  key String
  authId String Maybe
  Primary key
|]

展開後。

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
module Lib
    ( someFunc
    ) where

import Database.Persist.Quasi
import Database.Persist.TH

someFunc :: IO ()
someFunc = putStrLn "someFunc"

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [(((UnboundEntityDef [])
     (NaturalKey ((UnboundCompositeDef [FieldNameHS (pack "key")]) [])))
    (((((((((((EntityDef (EntityNameHS (pack "PersistentSession")))
                (EntityNameDB (pack "persistent_session")))
               (EntityIdField
                  (((((((((((FieldDef (FieldNameHS (pack "Id")))
                              (FieldNameDB (pack "id")))
                             ((FTTypeCon Nothing) (pack "PersistentSessionId")))
                            (SqlOther (pack "Primary Key")))
                           [])
                          True)
                         NoReference)
                        ((FieldCascade Nothing) Nothing))
                       Nothing)
                      Nothing)
                     True)))
              [])
             [])
            [])
           [])
          [])
         (fromList []))
        False)
       Nothing))
   [(((((((UnboundFieldDef (FieldNameHS (pack "key")))
            (FieldNameDB (pack "key")))
           [])
          True)
         ((FTTypeCon Nothing) (pack "String")))
        ((FieldCascade Nothing) Nothing))
       Nothing)
      Nothing,
    (((((((UnboundFieldDef (FieldNameHS (pack "authId")))
            (FieldNameDB (pack "auth_id")))
           [FieldAttrMaybe])
          True)
         ((FTTypeCon Nothing) (pack "String")))
        ((FieldCascade Nothing) Nothing))
       Nothing)
      Nothing]]

これLTS-19なので2.14.0.1では無いが大丈夫か? 最新版でも、 ReferenceDefのCompositeRefのバリエーションが消されただけなのでこれは気にしなくても大丈夫。

直接UnboundEntityDefに書き込むのも手の一つだと思いますが、綺麗な方式ではない。 unbindEntityDefの内部を見るとNaturalかどうかを判断して切り替えているのでヒントを与えてやればうまく生成されるはず。 https://github.com/yesodweb/persistent/blob/c3f057757c8406026b2134b0db3d1ec4a668c874/persistent/Database/Persist/Quasi/Internal.hs#L668

なんかテキスト処理とか行ってるみたいで大変面倒そう。中間形式を吐き出してもらえばわかりやすい? そのような関数は見つかりませんでした。

EntityConstraintDefsとかいうのがあるらしい。いやこれは作業を行うための中間データだからこちらから参照することはない。

よく分からない。 EntityIdNaturalKeyを生成する方法探しに戻ろう。

https://github.com/yesodweb/persistent/blob/c3f057757c8406026b2134b0db3d1ec4a668c874/persistent/Database/Persist/Types/Base.hs#L188 は既に生成されてるやつから取り出すだけですね。自前でガチャガチャ書いて良いのかなあこれ。

テキトーにガチャガチャ書いたらテスト通ってしまった。警告残ってるけど本当に良いのかこれは。

後は警告消すために、 PersistentSessionIdを消していくわけだけれど、そうなると、 persistIdField = PersistentSessionId の書き換えが分からない。素直に、 persistIdField = PersistentSessionKey とかすると型をKeyで包めと怒られるし、 persistIdField = Key PersistentSessionKey とするとそんなコンストラクタは無いと怒られる。よく考えてみるとKeyは型名でコンストラクタでは無いのだからそれはそうだ。しかしPersistentSessionKey'の方は生成が難しい。

しばらく色々と試して考えたけど、これも最終的にはTHの展開で定義されるのだからサンプルコードを展開していけば出現するのでは。

メチャクチャなimportの連打を喰らえ。余計な要素は消しました。

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
module Lib
    ( someFunc
    ) where

import Data.Map
import Data.Text
import Database.Persist.EntityDef.Internal
import Database.Persist.FieldDef.Internal
import Database.Persist.Names
import Database.Persist.Quasi
import Database.Persist.Quasi.Internal
import Database.Persist.TH
import Database.Persist.Types

someFunc :: IO ()
someFunc = putStrLn "someFunc"

instance PersistField PersistentSession where
  toPersistValue = entityToPersistValueHelper
  fromPersistValue = entityFromPersistValueHelper ["key"]
instance PersistFieldSql PersistentSession where
  sqlType _ = SqlString
data PersistentSession
  = PersistentSession {persistentSessionKey :: !String}
type PersistentSessionId = Key PersistentSession
instance PersistEntity PersistentSession where
  type PersistEntityBackend PersistentSession = SqlBackend
  data Unique PersistentSession
  newtype Key PersistentSession
    = PersistentSessionKey' {unPersistentSessionKey :: String}
    deriving stock Show
    deriving stock Read
    deriving newtype Eq
    deriving newtype Ord
    deriving newtype PathPiece
    deriving newtype ToHttpApiData
    deriving newtype FromHttpApiData
    deriving newtype PersistField
    deriving newtype PersistFieldSql
    deriving newtype ToJSON
    deriving newtype FromJSON
  data EntityField PersistentSession typ
    = (typ ~ PersistentSessionId) => PersistentSessionId |
      (typ ~ String) => PersistentSessionKey
  keyToValues record_atUg
    = [toPersistValue (unPersistentSessionKey record_atUg)]
  keyFromValues [x1_atUi]
    = PersistentSessionKey'
        <$>
          (mapLeft ((fieldError (pack "persistent_session")) (pack "key"))
             . fromPersistValue)
            x1_atUi
  keyFromValues x_atUh
    = (Left
         $ (mappend (pack "PersistentSession: keyFromValues failed on: "))
             (pack $ show x_atUh))
  keyFromRecordM
    = Just
        (\ record_atUo
           -> PersistentSessionKey' (persistentSessionKey record_atUo))
  entityDef _
    = ((((((((((EntityDef (EntityNameHS (pack "PersistentSession")))
                 (EntityNameDB (pack "persistent_session")))
                (EntityIdField
                   (((((((((((FieldDef (FieldNameHS (pack "Id")))
                               (FieldNameDB (pack "id")))
                              ((FTTypeCon Nothing) (pack "PersistentSessionId")))
                             (SqlOther (pack "Primary Key")))
                            [])
                           True)
                          NoReference)
                         ((FieldCascade Nothing) Nothing))
                        Nothing)
                       Nothing)
                      True)))
               [])
              [])
             [])
            [])
           [])
          (fromList []))
         False)
        Nothing
        {entityFields = [FieldDef
                           {fieldHaskell = FieldNameHS (pack "key"),
                            fieldDB = FieldNameDB (pack "key"),
                            fieldType = (FTTypeCon Nothing) (pack "String"),
                            fieldSqlType = sqlType (Proxy :: Proxy String), fieldAttrs = [],
                            fieldStrict = True, fieldReference = NoReference,
                            fieldCascade = (FieldCascade Nothing) Nothing,
                            fieldComments = Nothing, fieldGenerated = Nothing,
                            fieldIsImplicitIdColumn = False}],
         entityId = EntityIdNaturalKey
                      CompositeDef
                        {compositeFields = fromList
                                             [(lookupEntityField (Proxy :: Proxy PersistentSession))
                                                (FieldNameHS (pack "key"))],
                         compositeAttrs = []},
         entityForeigns = []}
  toPersistFields (PersistentSession x_atUc)
    = [SomePersistField x_atUc]
  fromPersistValues [x1_atUe]
    = PersistentSession
        <$>
          (mapLeft ((fieldError (pack "persistent_session")) (pack "key"))
             . fromPersistValue)
            x1_atUe
  fromPersistValues x_atUd
    = (Left
         $ (mappend
              (pack "PersistentSession: fromPersistValues failed on: "))
             (pack $ show x_atUd))
  persistUniqueToFieldNames _
    = error "Degenerate case, should never happen"
  persistUniqueToValues _
    = error "Degenerate case, should never happen"
  persistUniqueKeys (PersistentSession _key_atUf) = []
  persistFieldDef PersistentSessionId
    = stripIdFieldImpl
        (EntityIdNaturalKey
           CompositeDef
             {compositeFields = fromList
                                  [(lookupEntityField (Proxy :: Proxy PersistentSession))
                                     (FieldNameHS (pack "key"))],
              compositeAttrs = []})
  persistFieldDef PersistentSessionKey
    = (lookupEntityField (Proxy :: Proxy PersistentSession))
        (FieldNameHS (pack "key"))
  persistIdField = PersistentSessionId
  fieldLens PersistentSessionId
    = (lensPTH entityKey)
        (\ (Entity _ value_atUj) key_atUk -> (Entity key_atUk) value_atUj)
  fieldLens PersistentSessionKey
    = (lensPTH
         ((\ PersistentSession {persistentSessionKey = x} -> x)
            . entityVal))
        (\ (Entity key_atUl value_atUm) x_atUn
           -> (Entity key_atUl)
                (case value_atUm of {
                   PersistentSession {}
                     -> PersistentSession {persistentSessionKey = x_atUn} }))
instance TypeError (NoUniqueKeysError PersistentSession) =>
         OnlyOneUniqueKey PersistentSession where
  onlyUniqueP _ = error "impossible"
instance TypeError (MultipleUniqueKeysError PersistentSession) =>
         AtLeastOneUniqueKey PersistentSession where
  requireUniquesP _ = error "impossible"
instance SymbolToField "key" PersistentSession String where
  symbolToField = PersistentSessionKey
entityDefListFormigrateAll :: [EntityDef]
entityDefListFormigrateAll
  = [entityDef (Proxy :: Proxy PersistentSession)]
migrateAll :: Migration
migrateAll = migrateModels entityDefListFormigrateAll

なんか括弧の対応が合わない… HLSのTH展開能力のエミュレート不足なんですかね。

あれpersistIdField定義されなくない? と最初は思ったけど内部のQuasiQuoteを先に展開すると無くなってしまい、トップレベルから展開すれば出現するらしい。どういうことかはよく分かりません。

でもPersistentSessionIdを復活させたらpersistFieldDefの定義が必要になってカラムが増えるのではと思ったけどstripIdFieldImplを使えば良いらしい。 https://github.com/yesodweb/persistent/blob/c3f057757c8406026b2134b0db3d1ec4a668c874/persistent/Database/Persist/TH.hs#L2018 非公開関数だから使えないらしい。 THの内部では使えるということですね。まあ内部的には自然キーを探して最初のをセット、 (これ複合キーが自然キーだったらどうするんだ?) 無かったら適当なダミーを返す。

@persistent@ used to assume that an Id was always a single field.

This method preserves as much backwards compatibility as possible.

https://github.com/yesodweb/persistent/blob/c3f057757c8406026b2134b0db3d1ec4a668c874/persistent/Database/Persist/TH.hs#L2015

と書かれていますね。互換性のためかあ、なので実装埋めて無くても一応動いたんですね。 persistIdFieldは将来的に非推奨になるのだろうか。

今回は自然キーが単一のキーなのでそれを使いましょう。

非公開関数を読み解く限り要するにこうすれば良い。

persistFieldDef PersistentSessionId = P.persistFieldDef PersistentSessionKey

はずだった。何故か型が合わない。型引数がそれぞれ別のものと見做されているのか呼び出せなくなってるんですね。 ScopedTypeVariablesは関係ないらしい。

まあカンを働かせて別関数にそれぞれの実装を逃したら通りました。型族周り難しすぎてよく分からない。

とりあえずコンポーネントのテストは通るものが実装できた

とりあえずこれで警告も消せたし実装できた?

とりあえず動く実装は出来ましたが、これなら公開インターフェイスのシグネチャを変えなくてもうまく行きそうです。

後これをどうにかしてもサンプルの方が通りませんね。参照先が違うとか?

サンプルは後に回すことにしましょう。

一回は諦めたシグネチャの維持を再度行ってみましょう。とは言ってもpersistent自体の変更で完全に残すのは難しいかもしれませんが。

シグネチャ維持は無理ですね! これまでProxy名前が何故かうまく渡ってましたが、それはうまく行かない。

完全に維持するのは諦めることにして、上級ユーザ向けに名前指定出来るAPIを追加しておいて、これまでサンプル通り使ってきたユーザはちょっと書き換えるだけで済むような感じに変えましょう。

そのまま雑に実装してしまうと型シノニムが呼び出し側で閲覧できないから関数一つ呼び出すだけで実装できないのか。普通の関数呼び出しじゃなくてTemplate Haskellだからこその問題ですね。

ハックをやっていくことで解決できるかもしれませんが… まあこれぐらいの手間は許容範囲として諦めて貰おうと思います。 typeシノニムはコピペしてもらいます。

いや流石にコピペはしなくても良かった。 importしてもらえば問題ない。

exampleの修正

何故かビルドに失敗し続けているexampleを修正します。

参照先がHackageになっていてローカルを見ていないのでは説。

exampleを実際に見てコードに書いてるexampleに色々と無理があるなと気がついてきた。

entityDefsは[EntityDef]、しかしmkMigrateが受け取るのは[UnboundEntityDef]、これをどうするべきか。

In persistent-2.13.0.0, this was changed to ignore the input entity def list, and instead defer to mkEntityDefList to get the correct entities. This avoids problems where the QuasiQuoter is unable to know what the right reference types are. This sets mkPersist to be the "single source of truth" for entity definitions.

みたいに入力を無視するって書いているけれどどういうことだろう? 引数を無視するわけでは無いだろうし。一応実際に引数を空にして見たら普通にマイグレーションなしでテスト失敗します。

まあunbindEntityDefで変換すればそりゃ動くんでしょうけど、本当にそれをやって良いのか確信が持てない。何か間違っているのではという気がして仕方がない。

unbindEntityDefがInternalというのも気になる所。どうせInternalならembedEntityDefsを使ってしまうか。

まあ当然qualifiedでimportすると名前見つからないエラーになりますよね。コピペしてもらうか少し悩みましたが、修飾付けないでimportしてもらうことにします。

ううむ、文字列でやり取りしてるとこういうところに弱いですね。

なんかあっさりとビルドに成功してしまったな。この前のexampleだけ通らないという悩みは一体何だったんだ。

connEscapeNameの処理前にやらなかったっけ。あーexampleプロジェクト作って試して問題ないことを確認しただけか。 trashかsnapperにデータ残ってるかな。うーん見つからないな。どこで処理方法を知ったのだっけ… まあ良いか、もう一度やろうか…

Git Stashに残ってた。 connEscapeRawNameで代用。それにしても、これもInternalなので後で公開してくれって送る必要があるなあ。

一応exampleも通るようになったがテストを復活させると通らない

exampleの今残ってたテストは実行して成功するように出来たが、 HomeSpecのテストを復活させて実行するとSQLiteがエラーを返してくるので、本当に問題が起きているのかがよく分からない。

Handler.Home
30/May/2022:17:59:25 +0900 [Error] Error closing database connection in pool: SQLite3 returned ErrorBusy while attempting to perform close: unable to close due to unfinalized statements or unfinished backups @(persistent-2.13.3.5-HvMqaF4atKUIVOnaPK1YB9:Database.Persist.Sql.Run ./Database/Persist/Sql/Run.hs:248:16)
  loads the index and checks it looks right FAILED [1]

とりあえず最新版のSQLiteつきのYesodの初期プロジェクトはどうなっているだろうか。あんまりexample信用できないですが…

stack new sqlite-project yesodweb/sqlite

初期exampleだとテスト成功するじゃん。

差分を眺めていく必要がありそうですね。データベーススキーマに関しての一部の事情は異なりますが、ほとんど不要な差分では。初期に戻してみましょう。

うーん一応ビルドと起動は通るんだけど、あまりにもかけ離れている対象をサンプルに取っている気がする…

これのテストは諦めましょう。

Internalのクリーンアップ

今回実装するのにあたってInternalモジュールを使わざるを得ないところがたくさんありました。なるべく使うべきではないと分かってはいたのですが、使わないと実装が不可能だとしか思えなかったので、仕方がありません。

Internalを一つずつ明示的になるようにしましょう。

embedEntityDefsもモジュールは分かれていませんがInternalですね。

必要になったInternal要素。

  • EntityDef
  • UnboundEntityDef, unbindEntityDef
  • embedEntityDefs
  • connEscapeRawName

一つの構造体がそのまま入っていることを除けば、意外とそこまでInternalなものは使っていませんね。

これはpersistentにAPIの公開要望としてissueで送っておきましょう。

Please export EntityDef, UnboundEntityDef, unbindEntityDef, embedEntityDefs, connEscapeRawName because serversession new version use it. · Issue #1403 · yesodweb/persistent

今日はここまで

今日はここまでにします。疲れた。次はプロダクトの開発環境でこのバージョンを使っても問題ないか試して、問題なければリリースしたりします。

後一応メンテナなのでメンテナ欄にメールアドレス載せておいた方が良いか。