demo for getting haxl to get some data from redis using mget for batched results for you

haxl-redis-mget.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Control.Exception
import Control.Monad
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Hashable
import Data.Typeable
import Database.Redis
import Haxl.Core
import Text.Printf

type Haxl a = GenHaxl () a

type EntryId = String
type Entry = String

data EntryRequest a where
  FetchEntry :: EntryId -> EntryRequest Entry

deriving instance Show (EntryRequest a)
deriving instance Typeable EntryRequest
deriving instance Eq (EntryRequest a)
instance Show1 EntryRequest where show1 = show
instance Hashable (EntryRequest a) where
  hashWithSalt salt (FetchEntry x) =
    salt `hashWithSalt` (0 :: Int) `hashWithSalt` x

getEntry :: EntryId -> Haxl Entry
getEntry = dataFetch . FetchEntry

instance StateKey EntryRequest where
  data State EntryRequest = EntryDataState Connection

initDataSource :: ConnectInfo -> IO (State EntryRequest)
initDataSource ci = EntryDataState <$> connect ci

instance DataSourceName EntryRequest where
  dataSourceName _ = "EntryDataSource"

instance DataSource a EntryRequest where
  fetch (EntryDataState conn) _flags _userEnv blockedFetches =
    SyncFetch $ batchFetch conn blockedFetches

type Batches = [(EntryId, ResultVar Entry)]

data EntryNotFound = EntryNotFound EntryId
  deriving (Show, Typeable)
instance Exception EntryNotFound where
  toException = transientErrorToException
  fromException = transientErrorFromException

data EntryDbException = EntryDbException String
  deriving (Show, Typeable)
instance Exception EntryDbException where
  toException = transientErrorToException
  fromException = transientErrorFromException

batchFetch :: Connection -> [BlockedFetch EntryRequest] -> IO ()
batchFetch conn xs = do
  results <- runRedis conn $ mget myKeys
  case results of
    Right x ->
      forM_ (zip ys x) handleResult
    _ ->
      forM_ (snd <$> ys) $ \x -> putFailure x (EntryDbException "error in getting entries")
  where
    myKeys :: [ByteString]
    myKeys = pack . fst <$> ys

    extract :: BlockedFetch EntryRequest -> (EntryId, ResultVar Entry)
    extract (BlockedFetch (FetchEntry x) y) = (x, y)
    ys = extract <$> xs

    handleResult ((x, y), result) =
      case result of
        Just a -> putSuccess y $ unpack a
        _ -> putFailure y $ EntryNotFound x

main :: IO ()
main = do
  conn <- initDataSource defaultConnectInfo
  myEnv <- initEnv (stateSet conn stateEmpty) ()
  (x, y) <- runHaxl myEnv $ (,) <$> getEntry "test" <*> getEntry "test2"

  putStrLn $ printf "we got: %s and %s " x y

  z <- runHaxl myEnv $ getEntry "sdfsdfsdf"

  putStrLn $ printf "we got: %s" z

If you bring in ApplicativeDo from GHC 8.0.2 you can write the action in line 92 in do-notation rather than manual applicatives