Type level map을 사용하여 preload 바람 관련 리소스를 처리합니다.색인 추가

preload?

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

할 일

간단한 실현

Proeload용 지원 준비

{-# 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 수행

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

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

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

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

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

이용 예

> 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

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

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

설치(IxState)

Preloader

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

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)