Created
June 11, 2014 04:00
-
-
Save jamesdabbs/ba0d798b4022cf4cb64b to your computer and use it in GitHub Desktop.
[WIP] Fixing Persistent n+1's with Haxl
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE TupleSections, OverloadedStrings, StandaloneDeriving, FlexibleInstances #-} | |
module Handler.Home where | |
import Import | |
import Data.Int (Int64) | |
import qualified Data.Text as T | |
-- Haxl imports | |
import Data.Hashable | |
import Data.Typeable | |
import Haxl.Core | |
import Control.Monad (unless) | |
import Data.List (intercalate) | |
import Data.Maybe (mapMaybe) | |
import Data.Traversable (for) | |
-- We don't want n=0 in our n+1 investigation | |
-- Run `curl -XPOST http://localhost:3000/populate` | |
createUser :: Int64 -> Handler () | |
createUser n = do | |
_id <- runDB . insert $ User email Nothing | |
_ <- runDB . insert $ Uname _id name | |
return () | |
where | |
email = "email" <> (thow n) <> "@example.com" | |
name = "User " <> (thow n) | |
thow = T.pack . show | |
postPopulateR :: Handler Value | |
postPopulateR = do | |
mapM_ createUser [1..10] | |
returnJson ("Okay!" :: Text) | |
-- An easy way to get yourself in to trouble: run queries in a widget | |
usernameWidget :: UserId -> Widget | |
usernameWidget _id = do | |
(Entity _ n) <- handlerToWidget . runDB . getBy404 . UniqueUname $ _id | |
[whamlet|#{unameName n}|] | |
getBadR :: Handler Html | |
getBadR = do | |
users <- runDB $ selectList [] [Asc UserId] | |
defaultLayout $(widgetFile "bad") | |
-- Now with haxl | |
-- This setup cribbed directly from the README: https://github.com/facebook/Haxl/blob/master/example/sql/readme.md | |
data UserReq a where | |
GetAllIds :: UserReq [Id] | |
GetNameById :: Id -> UserReq Name | |
deriving (Typeable) | |
type Id = Int64 | |
type Name = String | |
deriving instance Eq (UserReq a) | |
instance Hashable (UserReq a) where | |
hashWithSalt s GetAllIds = hashWithSalt s (0::Int) | |
hashWithSalt s (GetNameById a) = hashWithSalt s (1::Int, a) | |
instance StateKey UserReq where | |
data State UserReq = UserState | |
{ userStateHandler :: Handler [UserId] -> IO [UserId] | |
, userStateHandler2 :: Handler [Entity Uname] -> IO [Entity Uname] | |
} | |
instance DataSourceName UserReq where | |
dataSourceName _ = "UserDataSource" | |
deriving instance Show (UserReq a) | |
instance Show1 UserReq where show1 = show | |
type Haxl = GenHaxl () | |
dekey (Key (PersistInt64 n)) = n | |
dekey _ = error "Can't dekey" | |
rekey = Key . PersistInt64 | |
-- Here's where we veer off the beaten path a little | |
instance DataSource () UserReq where | |
fetch _state _flags _userEnv blockedFetches = SyncFetch $ do | |
unless (null allIdVars) $ do | |
-- Fetch all the IDs. | |
ids <- runHandler $ runDB $ selectKeysList ([] :: [Filter User]) [] | |
-- Store the results. | |
mapM_ (\m -> putResult m (Right . map dekey $ ids)) allIdVars | |
unless (null ids) $ do | |
-- Fetch all the names. | |
users <- runHandler2 $ runDB $ selectList [UnameUserId <-. (map rekey ids)] [] | |
let names = map (unameName . entityVal) users | |
-- Store the results. | |
mapM_ (\ (m, res) -> putResult m (Right res)) (zip vars (map show names)) | |
where | |
runHandler = userStateHandler _state | |
runHandler2 = userStateHandler2 _state | |
allIdVars :: [ResultVar [Id]] | |
allIdVars = mapMaybe | |
(\bf -> case bf of | |
BlockedFetch GetAllIds m -> Just m | |
_ -> Nothing) | |
blockedFetches | |
ids :: [Id] | |
vars :: [ResultVar Name] | |
(ids, vars) = unzip $ foldr go [] blockedFetches | |
go | |
:: BlockedFetch UserReq | |
-> [(Id, ResultVar Name)] | |
-> [(Id, ResultVar Name)] | |
go (BlockedFetch (GetNameById userId) m) acc = (userId, m) : acc | |
go _ acc = acc | |
-- And bring it on home | |
getAllUserIds :: Haxl [Id] | |
getAllUserIds = dataFetch GetAllIds | |
getUsernameById :: Id -> Haxl Name | |
getUsernameById userId = dataFetch (GetNameById userId) | |
getAllUsernames :: Haxl [Name] | |
getAllUsernames = do | |
userIds <- getAllUserIds -- Round 1 | |
for userIds $ \userId -> do -- Round 2 | |
getUsernameById userId | |
getGoodR :: Handler Value | |
getGoodR = do | |
runH <- handlerToIO | |
runH2 <- handlerToIO | |
liftIO $ do | |
let stateStore = stateSet UserState{ userStateHandler = runH, userStateHandler2 = runH2 } stateEmpty | |
env0 <- initEnv stateStore () | |
names <- runHaxl env0 getAllUsernames | |
return () | |
error "I hope that was what you wanted" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment