Haxl/example/sql/Main.hs
2014-06-10 02:47:59 -07:00

119 lines
2.9 KiB
Haskell

-- Necessary:
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- Incidental:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Main where
import Control.Applicative
import Control.Monad
import Data.Hashable
import Data.List
import Data.Text (Text)
import Data.Traversable (for)
import Data.Typeable
import Haxl.Core
import System.Random
import qualified Data.Text as Text
main :: IO ()
main = do
let stateStore = stateSet UserState{} stateEmpty
env0 <- initEnv stateStore ()
names <- runHaxl env0 getAllUsernames
print names
-- Data source API.
getAllUsernames :: Haxl [Name]
getAllUsernames = do
userIds <- getAllUserIds
for userIds $ \userId -> do
getUsernameById userId
getAllUserIds :: Haxl [Id]
getAllUserIds = dataFetch GetAllIds
getUsernameById :: Id -> Haxl Name
getUsernameById userId = dataFetch (GetNameById userId)
-- Aliases.
type Haxl = GenHaxl ()
type Id = Int
type Name = Text
-- Data source implementation.
data UserReq a where
GetAllIds :: UserReq [Id]
GetNameById :: Id -> UserReq Name
deriving (Typeable)
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)
deriving instance Show (UserReq a)
instance Show1 UserReq where show1 = show
instance StateKey UserReq where
data State UserReq = UserState {}
instance DataSourceName UserReq where
dataSourceName _ = "UserDataSource"
instance DataSource u UserReq where
fetch _state _flags _userEnv blockedFetches = SyncFetch $ do
unless (null allIdVars) $ do
allIds <- sql "select id from ids"
mapM_ (\r -> putSuccess r allIds) allIdVars
unless (null ids) $ do
names <- sql $ unwords
[ "select name from names where"
, intercalate " or " $ map ("id = " ++) idStrings
, "order by find_in_set(id, '" ++ intercalate "," idStrings ++ "')"
]
mapM_ (uncurry putSuccess) (zip vars names)
where
allIdVars :: [ResultVar [Id]]
allIdVars = [r | BlockedFetch GetAllIds r <- blockedFetches]
idStrings :: [String]
idStrings = map show ids
ids :: [Id]
vars :: [ResultVar Name]
(ids, vars) = unzip
[(userId, r) | BlockedFetch (GetNameById userId) r <- blockedFetches]
-- Mock SQL API.
class SQLResult a where
mockResult :: IO a
instance SQLResult a => SQLResult [a] where
mockResult = replicateM 10 mockResult
instance SQLResult Name where
-- An infinite number of employees, all named Jim.
mockResult = ("Jim" `Text.append`) . Text.pack . show <$> randomRIO (1::Int, 100)
instance SQLResult Id where
mockResult = randomRIO (1, 100)
sql :: SQLResult a => String -> IO a
sql query = print query >> mockResult