HRRで主キー、外部キーごとに新しく型を割り当ててみた(雑)

by Daishi Nakajima

HRRで型安全なクエリをかけるので大満足生活だが、主キー・外部キーがすべて同じ型(Int64等)になってしまっている状況では注意力が必要だと感じた。

どのカラムも型割り当ててもよいのだが、特に次の理由で、

  • query作成時に指定することが多いはずなため
  • 関連していないidは比較できないと考えて良かったため

前置き

雑なコード生成で殴ってます。

コード生成良くないが、hrr使ってる関連では既にTableごとのモジュールのコード生成を行ってたので、考えることをやめた。

実装内容

shell scriptでpostgresのinformation_schemaへの問い合わせを使い次のようなコードを生成した。

  • PKごとにnewtypeを定義を生成
  • カラムごとに型を割り当てるため、getFieldsWithMapの挙動の一部を上書きする関数を生成

pkごとにnewtype生成する例.sh

query=$(cat << EOS  
SELECT  
    tc.table_name,
    kcu.column_name
FROM  
    information_schema.table_constraints AS tc
    JOIN information_schema.key_column_usage AS kcu
      ON tc.constraint_name = kcu.constraint_name
      AND tc.table_schema = kcu.table_schema
WHERE tc.constraint_type = 'PRIMARY KEY' AND tc.table_name <> 'schema_migrations';  
EOS  
)
IFS='|'  
psql -h localhost -d ${DB} -U api -Atc "$query" \  
    | while read tbl clm; do
        entity=`echo $tbl | perl -pe "s/_(.)/\u\1/g; s/^(.)/\u\1/g"`
        cat >> $entityId << EOS
newtype ${entity}Id = ${entity}Id { un${entity}Id :: Int64 }  
  deriving (Generic, Eq, Show, ToJSON, FromJSON, Default, Arbitrary, PersistableWidth
           , LiteralSQL, FromSql SqlValue, ToSql SqlValue, FromHttpApiData, Num)

EOS

done

PK,FKに上記の型を割り当てるgetFieldsWithMapを生成する例.sh

echo "getField' :: String -> (String, TypeQ) -> (String, TypeQ)" >> $entityId  
psql -h localhost -d ${DB} -U api -Atc "$query" \  
    | while read tbl clm; do
        entity=`echo $tbl | perl -pe "s/_(.)/\u\1/g; s/^(.)/\u\1/g"`
        echo "getField' \"${tbl}\" (c@\"${clm}\", _) = (c, [t|${entity}Id|])" >> $entityId
    done

### FK
query=$(cat << EOS  
SELECT  
    tc.table_name,
    kcu.column_name,
    ccu.table_name AS foreign_table_name,
    ccu.column_name AS foreign_column_name
FROM  
    information_schema.table_constraints AS tc
    JOIN information_schema.key_column_usage AS kcu
      ON tc.constraint_name = kcu.constraint_name
      AND tc.table_schema = kcu.table_schema
    JOIN information_schema.constraint_column_usage AS ccu
      ON ccu.constraint_name = tc.constraint_name
      AND ccu.table_schema = tc.table_schema
WHERE tc.constraint_type = 'FOREIGN KEY';  
EOS  
     )
psql -h localhost -d ${DB} -U api -Atc "$query" \  
    | while read tbl clm ftbl fclm; do
    fentity=`echo $ftbl | perl -pe "s/_(.)/\u\1/g; s/^(.)/\u\1/g"`
    echo "getField' \"${tbl}\" (c@\"${clm}\", _) = (c, [t|${fentity}Id|])" >> $entityId
done  
echo "getField' _ x = x" >> $entityId

こんなのが生成されました.hs

newtype UserId = UserId { unUserId :: Int64 }  
  deriving (Generic, Eq, Show, ToJSON, FromJSON, Default, Arbitrary, PersistableWidth
           , LiteralSQL, FromSql SqlValue, ToSql SqlValue, FromHttpApiData, Num)
newtype TaskId = TaskId { unTaskId :: Int64 }  
  deriving (Generic, Eq, Show, ToJSON, FromJSON, Default, Arbitrary, PersistableWidth
           , LiteralSQL, FromSql SqlValue, ToSql SqlValue, FromHttpApiData, Num)

getField' :: String -> (String, TypeQ) -> (String, TypeQ)  
getField' "user" (c@"id", _) = (c, [t|UserId|])  
getField' "task" (c@"id", _) = (c, [t|TaskId|])  
getField' "task" (c@"user_id", _) = (c, [t|UserId|])  
getField' _ x = x

使用感

placeholderにid渡すときに型残せるし、query内のオペレータでId使うときも安全。

selectTasks :: Query UserId Task  
selectTasks = relation' . placeholder $ \ph -> do  
  t <- query task
  -- x <- query ...
  -- on $ x ! #taskId .=. t ! #id
  wheres $ t ! #userId .=. ph
  pure p

因みに、servant使ってるので、routingから一貫してId使える。

"users" :> Capture "id" UserId :> "tasks"

感想

  • この実装についてhrr作者の日比野さんに伺った所、「型は自分で書いて、それを名前のルールに従って対応付けられるようにgetFieldsWithMapを生成する」という使い方をしてた、と仰っていた。
    • 確かにPK,FKとか関係なく、どこまで型分けたいかは設計次第なので、汎用性のある方法考えたい。しかし考えていくと、テーブル定義する時点でHaskell側に型が欲しくなる気がしている。
  • 今と同じことやるにしても、THやGenericsでなんとかしたい