Zenn
🐸

Type level mapを使ったpreload風関連リソースの取り回し。Indexed monad添え

2020/12/31に公開1件
Haskell
tech

この記事はHaskell Advent Calendar 202011日目の記事です(遅延)。

大晦日です。いかがお過ごしでしょうか。

Haskellでapi server等を作った際、rdbへの問い合わせでPreload的なことを行う箇所で、Type level mapを使った所、なかなかの使い勝手だったので、共有します。

さらにIndexed Monadを使い、明らかに残念だった箇所を改善します。

preload?

1+N問題を起こさぬよう、事前に関連リソースを問い合わせておくもの。prefetchとかとも。

posts = Post.find(...) # query Post
# view
for p in posts
  for t in p.tags # ここで問い合わせるとN回なので、事前に問い合わせていて欲しい
    render t

やること

  • viewが要求するpreloadを定義できるようにする
  • preloadを実行する関数を提供する

簡素な実装

  • type-level-setsを使う
  • 細かい関数など省略されていますm__m

Preload用のヘルパを用意

  • MonadService.queryMはDBへ問い合わせを行う既存の関数である
  • ここではHRRを使っているが、本題には関係ない
  • loadは1-1のリソース、loadListは1-nのリソースをpreloadする関数
  • (->>)はload,loadListを繋いで複数の関連リソースを読み込んだMapを作成する。(->>=)はネストされた関連を読み込む ←残念箇所1
PreLoader.hs
{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes       #-}
{-# LANGUAGE TypeOperators    #-}

module PreLoader where

import           App
import qualified Data.Map                           as M
import           Data.Type.Map
import           Database.Relational.Monad.BaseType (Relation)
import           Util

type TMap = M.Map
type MkLoader ek r e = forall m k v . MonadService m
  => Var k -> [ek] -> Map v -> m (r, Map ((k ':-> M.Map ek e) : v))
type Loader k a = MkLoader k [a] a
type ListLoader k a = MkLoader k [a] [a]

(->>) :: Monad m => m (a, t) -> (t -> m b) -> m b
(->>) f g = f >>= \(_, b) -> g b

(->>=) :: Monad m => m (a, b) -> (a -> b -> m b1) -> m b1
(->>=) f g = f >>= uncurry g

load ::
  (FromSql SqlValue k1, FromSql SqlValue a, MonadService m1,
   Ord k1) =>
  (t -> Relation () (k1, a))
  -> Var k2
  -> t
  -> Map m2
  -> m1 ([a], Map ((k2 ':-> M.Map k1 a) : m2))
load query key ids m = do
  rs <- queryM (relationalQuery' (query ids) []) ()
  pure (snd <$> rs, Ext key (M.fromList rs) m)

loadList ::
  (FromSql SqlValue a, FromSql SqlValue b, MonadService m1, Ord a) =>
  (t -> Relation () (a, b))
  -> Var k
  -> t
  -> Map m2
  -> m1 ([b], Map ((k ':-> M.Map a [b]) : m2))
loadList query key ids m = do
  rs <- queryM (relationalQuery' (query ids) []) ()
  return (snd <$> rs, Ext key (groupList rs) m)

Service等で関連リソースをpreload

  • 「タスク」が複数の「タグ」を持つ例
  • 上記同様HRRを使っているが、select hoge.fk, hoge.* from hoge where id in (...)を発行するのみ
Query.hs
makeInclude ::
  (PersistableWidth b, LiteralSQL a,
   Num a) =>
  Relation () b -> Pi b a -> [a] -> Relation () (a, b)
makeInclude t k ids = relation $ do
  u <- query t
  wheres $ u ! k `in'` values' ids
  return $ (u ! k) >< u

includeTags :: [TaskId] -> Relation () (TaskId, TaskTag)
includeTags = makeInclude taskTag #taskId
  • ここではTaskの関連リソースを全て読み込む関数を定義した
Service.hs
import           Data.Map    (Map)
import           PreLoader
import           Entity
import           Query
import           Type

type TagsMap = Map TagId [TaskTag]

loadTags :: ListLoader TagId TaskTag
loadTags = loadList includeTags

loadTaskRelation rs =
  loadTags (Var :: Var "tags") (view #id <$> rs)

Viewを記述

  • 各viewが要求するpreloadを定義できる
View.hs
renderTask :: ( IsMember "tags" TagsMap c
              ) =>
              Map c -> Task -> ViewM TaskResponse
renderTask rel t = do
  ts <- getList (t ^. #id) (Var :: Var "tags") rel
  vTags <- mapM renderTag ts
  pure $ TaskResponse
      { id = t ^. #id
      , name = t ^. #name
      , tags = vTags
      }

renderTag :: TaskTag -> ViewM String
renderTag = pure . view #name
  • 次のようなヘルパを用意した
View/Helper.hs
get :: (KnownSymbol v, Ord k, IsMember v (M.Map k a) m) => Var v -> Map m -> k -> ViewM a
get key m rid = maybe e pure $ M.lookup rid $ lookp key m
  where e = ...

getList :: (KnownSymbol v, Ord k, IsMember v (M.Map k [a]) m) => k -> Var v -> Map m -> ViewM [a]
getList rid key m = pure $ fromMaybe [] $  M.lookup rid $ lookp key m

Handler

後は使うだけ

Handler.hs
getTasksR :: AuthUser -> AppM [TaskResponse]
getTasksR au = do
  xs <- getTasks ...
  related <- snd <$> loadTaskRelation xs TM.Empty
  runViewM $ mapM (renderTask related) xs

利用例

必要なpreloadを行わずにviewを呼び出すとコンパイルエラーとなる

> renderTask Empty undefined

<interactive>:121:1: error:
    • No instance for (IsMember "tags" TagsMap '[])
        arising from a use of ‘renderTask’
    • In the expression: renderTask Empty undefined
      In an equation for ‘it’:
          it = renderTask Empty undefined

viewのネストでも適切な定義になる。

renderTask :: ( IsMember "tags" TagsMap c
              , IsMember "followers" UserMap c
              , IsMember "userImages" ImageMap c -- renderUserで要求されている
              ) =>
              Map c -> Task -> ViewM TaskResponse
renderTask rel t = do
  fs <- getList (t ^. #id) (Var :: Var "followers") rel
  vFollowers <- mapM (renderUser rel) fs
  ...
  
renderUser :: (IsMember "userImages" ImageMap c) =>
              Map c -> User -> ViewM String
renderUser = ...

Indexed Monad

さて、上の実装で複数のpreloadを行うコードは次のようになる。

loadTasksRelation rs =
  snd <$> loadTags (Var :: Var "tags") (view #id <$> (rs :: [Task])) TM.Empty
  ->> loadTaskFollowers (Var :: Var "followers") (view #id <$> rs)
  ->>= \xs -> loadUserImages (Var :: Var "userImages") (view #id <$> xs)

これは状態として取り回したいが、計算途中で型が変わるので普通(?)のモナドは使えない。

loadRel :: ??
loadRel = do
  loadHoge -- この時点の型:: State ("hoges" -> ...) a
  loadFuga -- この時点の型:: State ("hoges" -> ..., "fuga" -> ...) a

が、Indexed Monadを使えば実現できるらしい。

[参考]

実装(IxState)

  • 次のライブラリを使う
  • 以降のコードは実用したことなく、とりあえず動かしてみた所なので、ご注意くださいm__m

Preloader

  • IxStateTを使った実装に変更。もはや(->>)(->>=)は不要
PreLoader.hs
import           Control.Monad.Indexed
import           Control.Monad.Indexed.State
import           Control.Monad.Indexed.Trans        (ilift)
import           Language.Haskell.DoNotation
import           Prelude                            hiding (Monad (..), pure)

runLoader x = fmap snd $ runIxStateT x Empty

iloadList ::
  (FromSql SqlValue a, FromSql SqlValue b, Ord a) =>
  (t -> Relation () (a, b))
  -> Var k
  -> t
  -> IxStateT AppM (Map m) (Map ((k ':-> M.Map a [b]) : m)) [b]
iloadList q k ids = do
  rs <- ilift $ queryM (relationalQuery' (q ids) []) ()
  imodify (\x -> Ext k (groupList rs) x)
  return $ snd <$> rs -- not Applicative

Service

これでpreloadを実行するコードは次のようにできる。

Task.hs
iloadTasksRelation xs = runLoader $ do
  iloadTags (Var @ "tags") (Entity.Task.id <$> xs)
  us <- iloadTaskFollowers (Var @ "followers") (Entity.Task.id <$> xs)
  iloadUserImages (Var @ "userImages") (Entity.User.id <$> us)

良さそう。

後はServiceやViewのスタックとつなぎこめば、rails,djangoとかで見るような、ロジック内で不意にpreloadしだす記述もできそう（しかも型安全に）（するかは別として）（来年も良いお年を）。

Discussion

Daishi NakajimaDaishi Nakajima

groupListの実装


-- |
-- construct Data.Map from List.
-- the value of duplicated key is to be list.
-- >>> createMapWithListValue [(1, 2), (2, 3), (1, 4)]
-- fromList [(1,[2,4]),(2,[3])]
groupList :: Ord a => [(a, b)] -> M.Map a [b]
groupList = M.fromListWith (flip (++)) . map (mapSnd pure)