packages feed

haxl (empty) → 0.1.0.0

raw patch · 27 files changed

+2761/−0 lines, 27 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, bytestring, containers, directory, filepath, hashable, haxl, pretty, text, time, unordered-containers, vector

Files

+ Haxl/Core.hs view
@@ -0,0 +1,24 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++-- | Everything needed to define data sources and to invoke the+-- engine. This module should not be imported by user code.+module Haxl.Core+  ( module Haxl.Core.Env+  , module Haxl.Core.Monad+  , module Haxl.Core.Types+  , module Haxl.Core.Exception+  , module Haxl.Core.StateStore+  , module Haxl.Core.Show1+  ) where++import Haxl.Core.Env+import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -})+import Haxl.Core.Types+import Haxl.Core.Exception+import Haxl.Core.Show1 (Show1(..))+import Haxl.Core.StateStore
+ Haxl/Core/DataCache.hs view
@@ -0,0 +1,113 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | A cache mapping data requests to their results.+module Haxl.Core.DataCache+  ( DataCache+  , empty+  , insert+  , lookup+  , showCache+  ) where++import Data.HashMap.Strict (HashMap)+import Data.Hashable+import Prelude hiding (lookup)+import Unsafe.Coerce+import qualified Data.HashMap.Strict as HashMap+import Data.Typeable.Internal+import Data.Maybe+import Control.Applicative hiding (empty)+import Control.Exception++import Haxl.Core.Types++-- | The 'DataCache' maps things of type @f a@ to @'ResultVar' a@, for+-- any @f@ and @a@ provided @f a@ is an instance of 'Typeable'. In+-- practice @f a@ will be a request type parameterised by its result.+--+-- See the definition of 'ResultVar' for more details.++newtype DataCache = DataCache (HashMap TypeRep SubCache)++-- | The implementation is a two-level map: the outer level maps the+-- types of requests to 'SubCache', which maps actual requests to their+-- results.  So each 'SubCache' contains requests of the same type.+-- This works well because we only have to store the dictionaries for+-- 'Hashable' and 'Eq' once per request type.+data SubCache =+  forall req a . (Hashable (req a), Eq (req a), Show (req a), Show a) =>+       SubCache ! (HashMap (req a) (ResultVar a))+       -- NB. the inner HashMap is strict, to avoid building up+       -- a chain of thunks during repeated insertions.++-- | A new, empty 'DataCache'.+empty :: DataCache+empty = DataCache HashMap.empty++-- | Inserts a request-result pair into the 'DataCache'.+insert+  :: (Hashable (r a), Typeable (r a), Eq (r a), Show (r a), Show a)+  => r a+  -- ^ Request+  -> ResultVar a+  -- ^ Result+  -> DataCache+  -> DataCache++insert req result (DataCache m) =+      DataCache $+        HashMap.insertWith fn (typeOf req)+                              (SubCache (HashMap.singleton req result)) m+  where+    fn (SubCache new) (SubCache old) =+        SubCache (unsafeCoerce new `HashMap.union` old)++-- | Looks up the cached result of a request.+lookup+  :: Typeable (r a)+  => r a+  -- ^ Request+  -> DataCache+  -> Maybe (ResultVar a)++lookup req (DataCache m) =+      case HashMap.lookup (typeOf req) m of+        Nothing -> Nothing+        Just (SubCache sc) ->+           unsafeCoerce (HashMap.lookup (unsafeCoerce req) sc)++-- | Dumps the contents of the cache, with requests and responses+-- converted to 'String's using 'show'.  The entries are grouped by+-- 'TypeRep'.+--+showCache+  :: DataCache+  -> IO [(TypeRep, [(String, Either SomeException String)])]++showCache (DataCache cache) = mapM goSubCache (HashMap.toList cache)+ where+  goSubCache+    :: (TypeRep,SubCache)+    -> IO (TypeRep,[(String, Either SomeException String)])+  goSubCache (ty, SubCache hmap) = do+    elems <- catMaybes <$> mapM go (HashMap.toList hmap)+    return (ty, elems)++  go :: (Show (req a), Show a)+     => (req a, ResultVar a)+     -> IO (Maybe (String, Either SomeException String))+  go (req, rvar) = do+    maybe_r <- tryReadResult rvar+    case maybe_r of+      Nothing -> return Nothing+      Just (Left e) -> return (Just (show req, Left e))+      Just (Right result) -> return (Just (show req, Right (show result)))
+ Haxl/Core/Env.hs view
@@ -0,0 +1,65 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE OverloadedStrings #-}++-- | The Haxl monad environment.+module Haxl.Core.Env+  ( Env(..)+  , emptyEnv+  , initEnv+  , initEnvWithData+  , caches+  ) where++import Haxl.Core.DataCache as DataCache+import Haxl.Core.StateStore+import Haxl.Core.Types++import Data.IORef++-- | The data we carry around in the Haxl monad.+data Env u = Env+  { cacheRef     :: IORef DataCache     -- cached data fetches+  , memoRef      :: IORef DataCache     -- memoized computations+  , flags        :: Flags+  , userEnv      :: u+  , statsRef     :: IORef Stats+  , states       :: StateStore+  -- ^ Data sources and other components can store their state in+  -- here. Items in this store must be instances of 'StateKey'.+  }++type Caches = (IORef DataCache, IORef DataCache)++caches :: Env u -> Caches+caches env = (cacheRef env, memoRef env)++-- | Initialize an environment with a 'StateStore', an input map, a+-- preexisting 'DataCache', and a seed for the random number generator.+initEnvWithData :: StateStore -> u -> Caches -> IO (Env u)+initEnvWithData states e (cref, mref) = do+  sref <- newIORef emptyStats+  return Env+    { cacheRef = cref+    , memoRef = mref+    , flags = defaultFlags+    , userEnv = e+    , states = states+    , statsRef = sref+    }++-- | Initializes an environment with 'DataStates' and an input map.+initEnv :: StateStore -> u -> IO (Env u)+initEnv states e = do+  cref <- newIORef DataCache.empty+  mref <- newIORef DataCache.empty+  initEnvWithData states e (cref,mref)++-- | A new, empty environment.+emptyEnv :: u -> IO (Env u)+emptyEnv = initEnv stateEmpty
+ Haxl/Core/Exception.hs view
@@ -0,0 +1,260 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++-- | An exception hierarchy that can be used with the 'Haxl' monad.+--+-- The Haxl framework may throw exceptions from this hierarchy: for+-- example, a misbehaving data source causes 'dataFetch' to throw a+-- 'DataSourceError'.  The combinator 'withDefault' from+-- "Haxl.Core.Prelude" uses this hierarchy to provide default values+-- for expressions that raise 'TransientError' or 'LogicError'+-- exceptions.+--+-- You are under no obligations to use this hierarchy for your own+-- exceptions, but you might find it useful nonetheless; for+-- 'withDefault' to be useful, for example, you'll want your+-- exceptions to be children of 'LogicError' or 'TransientError' as+-- appropriate.++module Haxl.Core.Exception (++  HaxlException(..),++  -- * Exception categories+  InternalError(..),+  internalErrorToException,+  internalErrorFromException,++  LogicError(..),+  logicErrorToException,+  logicErrorFromException,++  TransientError(..),+  transientErrorToException,+  transientErrorFromException,++  -- ** Internal exceptions+  CriticalError(..),+  DataSourceError(..),++  -- ** Logic exceptions+  NotFound(..),+  UnexpectedType(..),+  EmptyList(..),+  JSONError(..),+  InvalidParameter(..),++  -- ** Transient exceptions+  FetchError(..),++  -- * Exception utilities+  asHaxlException,++  ) where++import Control.Exception+import Data.Aeson+import Data.Typeable+import Data.Text (Text)++import Haxl.Core.Util++-- | We have a 3-tiered hierarchy of exceptions, with 'HaxlException' at+-- the top, and all Haxl exceptions as children of this. Users should+-- never deal directly with 'HaxlException's.+--+-- The main types of exceptions are:+--+--   ['InternalError']  Something is wrong with Haxl core.+--+--   ['LogicError']     Something is wrong with Haxl client code.+--+--   ['TransientError'] Something is temporarily failing (usually in a fetch).+--+-- These are not meant to be thrown (but likely be caught). Thrown+-- exceptions should be a subclass of one of these. There are some+-- generic leaf exceptions defined below this, such as 'FetchError'+-- (generic transient failure) or 'CriticalError' (internal failure).+--+data HaxlException+  = forall e. (Exception e, MiddleException e) => HaxlException e+  deriving (Typeable)++instance Show HaxlException where+  show (HaxlException e) = show e++instance Exception HaxlException++-- | These need to be serializable to JSON to cross FFI boundaries.+instance ToJSON HaxlException where+  toJSON (HaxlException e) = object+    [ "type" .= show (typeOf e)+    , "name" .= eName e+    , "txt"  .= show e+    ]++haxlExceptionToException+  :: (Exception e, MiddleException e) => e -> SomeException+haxlExceptionToException = toException . HaxlException++haxlExceptionFromException+  :: (Exception e, MiddleException e) => SomeException -> Maybe e+haxlExceptionFromException x = do+  HaxlException a <- fromException x+  cast a++class (Exception a) => MiddleException a where+  eName :: a -> String++-- | For transient failures.+data TransientError = forall e . (Exception e) => TransientError e+  deriving (Typeable)++deriving instance Show TransientError++instance Exception TransientError where+ toException   = haxlExceptionToException+ fromException = haxlExceptionFromException++instance MiddleException TransientError where+  eName (TransientError e) = show $ typeOf e++transientErrorToException :: (Exception e) => e -> SomeException+transientErrorToException = toException . TransientError++transientErrorFromException+  :: (Exception e) => SomeException -> Maybe e+transientErrorFromException x = do+  TransientError a <- fromException x+  cast a++-- | For errors in Haxl core code.+data InternalError = forall e . (Exception e) => InternalError e+  deriving (Typeable)++deriving instance Show InternalError++instance Exception InternalError where+  toException   = haxlExceptionToException+  fromException = haxlExceptionFromException++instance MiddleException InternalError where+  eName (InternalError e) = show $ typeOf e++internalErrorToException :: (Exception e) => e -> SomeException+internalErrorToException = toException . InternalError++internalErrorFromException+  :: (Exception e) => SomeException -> Maybe e+internalErrorFromException x = do+  InternalError a <- fromException x+  cast a++-- | For errors in Haxl client code.+data LogicError = forall e . (Exception e) => LogicError e+  deriving (Typeable)++deriving instance Show LogicError++instance Exception LogicError where+ toException   = haxlExceptionToException+ fromException = haxlExceptionFromException++instance MiddleException LogicError where+  eName (LogicError e) = show $ typeOf e++logicErrorToException :: (Exception e) => e -> SomeException+logicErrorToException = toException . LogicError++logicErrorFromException+  :: (Exception e) => SomeException -> Maybe e+logicErrorFromException x = do+  LogicError a <- fromException x+  cast a++------------------------------------------------------------------------+-- Leaf exceptions. You should throw these. Or make your own.+------------------------------------------------------------------------++-- | Generic \"critical\" exception. Something internal is+-- borked. Panic.+data CriticalError = CriticalError Text+  deriving (Typeable, Show)++instance Exception CriticalError where+  toException   = internalErrorToException+  fromException = internalErrorFromException++-- | Generic \"something was not found\" exception.+data NotFound = NotFound Text+  deriving (Typeable, Show)++instance Exception NotFound where+  toException = logicErrorToException+  fromException = logicErrorFromException++-- | Generic \"something had the wrong type\" exception.+data UnexpectedType = UnexpectedType Text+  deriving (Typeable, Show)++instance Exception UnexpectedType where+  toException = logicErrorToException+  fromException = logicErrorFromException++-- | Generic \"input list was empty\" exception.+data EmptyList = EmptyList Text+  deriving (Typeable,Show)++instance Exception EmptyList where+  toException = logicErrorToException+  fromException = logicErrorFromException++-- | Generic \"Incorrect assumptions about JSON data\" exception.+data JSONError = JSONError Text+  deriving (Typeable, Show)++instance Exception JSONError where+  toException = logicErrorToException+  fromException = logicErrorFromException++-- | Generic \"passing some invalid parameter\" exception.+data InvalidParameter = InvalidParameter Text+  deriving (Typeable, Show)++instance Exception InvalidParameter where+  toException = logicErrorToException+  fromException = logicErrorFromException++-- | Generic transient fetching exceptions.+data FetchError = FetchError Text+  deriving (Typeable, Eq, Show)++instance Exception FetchError where+  toException   = transientErrorToException+  fromException = transientErrorFromException++-- | A data source did something wrong+data DataSourceError = DataSourceError Text+  deriving (Typeable, Eq, Show)++instance Exception DataSourceError where+  toException   = internalErrorToException+  fromException = internalErrorFromException++-- | Converts all exceptions that are not derived from 'HaxlException'+-- into 'CriticalError', using 'show'.+asHaxlException :: SomeException -> HaxlException+asHaxlException e+  | Just haxl_exception <- fromException e = -- it's a HaxlException+     haxl_exception+  | otherwise =+     HaxlException (InternalError (CriticalError (textShow e)))
+ Haxl/Core/Fetch.hs view
@@ -0,0 +1,172 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Generic fetching infrastructure, used by 'Haxl.Core.Monad'.+module Haxl.Core.Fetch+  ( CacheResult(..)+  , cached+  , memoized+  , performFetches+  ) where++import Haxl.Core.DataCache as DataCache+import Haxl.Core.Env+import Haxl.Core.Exception+import Haxl.Core.RequestStore+import Haxl.Core.Show1+import Haxl.Core.StateStore+import Haxl.Core.Types+import Haxl.Core.Util++import Control.Exception+import Control.Monad+import Data.IORef+import Data.List+import Data.Time+import Text.Printf+import Data.Monoid+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text++-- | Issues a batch of fetches in a 'RequestStore'. After+-- 'performFetches', all the requests in the 'RequestStore' are+-- complete, and all of the 'ResultVar's are full.+performFetches :: forall u. Env u -> RequestStore u -> IO ()+performFetches env reqs = do+  let f = flags env+      sref = statsRef env+      jobs = contents reqs++  t0 <- getCurrentTime++  let+    roundstats =+      [ (dataSourceName (getReq reqs), length reqs)+      | BlockedFetches reqs <- jobs ]+      where+      getReq :: [BlockedFetch r] -> r a+      getReq = undefined++  modifyIORef' sref $ \(Stats rounds) ->+     Stats (RoundStats (HashMap.fromList roundstats) : rounds)++  ifTrace f 1 $+    printf "Batch data fetch (%s)\n" $+       intercalate (", "::String) $+           map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats++  ifTrace f 3 $+    forM_ jobs $ \(BlockedFetches reqs) ->+      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (show1 r)++  let+    applyFetch (BlockedFetches (reqs :: [BlockedFetch r])) =+      case stateGet (states env) of+        Nothing ->+          return (SyncFetch (mapM_ (setError (const e)) reqs))+          where req :: r a; req = undefined+                e = DataSourceError $+                      "data source not initialized: " <> dataSourceName req+        Just state ->+          return $ wrapFetch reqs $ fetch state f (userEnv env) reqs++  fetches <- mapM applyFetch jobs++  scheduleFetches fetches++  ifTrace f 1 $ do+    t1 <- getCurrentTime+    printf "Batch data fetch done (%.2fs)\n"+      (realToFrac (diffUTCTime t1 t0) :: Double)++-- Catch exceptions arising from the data source and stuff them into+-- the appropriate requests.  We don't want any exceptions propagating+-- directly from the data sources, because we want the exception to be+-- thrown by dataFetch instead.+--+wrapFetch :: [BlockedFetch req] -> PerformFetch -> PerformFetch+wrapFetch reqs fetch =+  case fetch of+    SyncFetch io -> SyncFetch (io `catch` handler)+    AsyncFetch fio -> AsyncFetch (\io -> fio io `catch` handler)+  where+    handler :: SomeException -> IO ()+    handler e = mapM_ (forceError e) reqs++    -- Set the exception even if the request already had a result.+    -- Otherwise we could be discarding an exception.+    forceError e (BlockedFetch _ rvar) = do+      void $ tryTakeResult rvar+      putResult rvar (except e)++-- | Start all the async fetches first, then perform the sync fetches before+-- getting the results of the async fetches.+scheduleFetches :: [PerformFetch] -> IO()+scheduleFetches fetches = async_fetches sync_fetches+ where+  async_fetches :: IO () -> IO ()+  async_fetches = compose [f | AsyncFetch f <- fetches]++  sync_fetches :: IO ()+  sync_fetches = sequence_ [io | SyncFetch io <- fetches]++-- | Possible responses when checking the cache.+data CacheResult a+  -- | The request hadn't been seen until now.+  = Uncached (ResultVar a)++  -- | The request has been seen before, but its result has not yet been+  -- fetched.+  | CachedNotFetched (ResultVar a)++  -- | The request has been seen before, and its result has already been+  -- fetched.+  | Cached (Either SomeException a)+++-- | Checks the data cache for the result of a request.+cached :: (Request r a) => Env u -> r a -> IO (CacheResult a)+cached env = checkCache (flags env) (cacheRef env)++-- | Checks the memo cache for the result of a computation.+memoized :: (Request r a) => Env u -> r a -> IO (CacheResult a)+memoized env = checkCache (flags env) (memoRef env)++-- | Common guts of 'cached' and 'memoized'.+checkCache+  :: (Request r a)+  => Flags+  -> IORef DataCache+  -> r a+  -> IO (CacheResult a)++checkCache flags ref req = do+  cache <- readIORef ref+  let+    do_fetch = do+      rvar <- newEmptyResult+      writeIORef ref (DataCache.insert req rvar cache)+      return (Uncached rvar)+  case DataCache.lookup req cache of+    Nothing -> do_fetch+    Just rvar -> do+      mb <- tryReadResult rvar+      case mb of+        Nothing -> return (CachedNotFetched rvar)+        -- Use the cached result, even if it was an error.+        Just r -> do+          ifTrace flags 3 $ putStrLn $ case r of+            Left _ -> "Cached error: " ++ show req+            Right _ -> "Cached request: " ++ show req+          return (Cached r)
+ Haxl/Core/Monad.hs view
@@ -0,0 +1,351 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The implementation of the 'Haxl' monad.+module Haxl.Core.Monad (+    -- * The monad+    GenHaxl (..), runHaxl,+    env,++    -- * Exceptions+    throw, catch, try, tryToHaxlException,++    -- * Data fetching and caching+    dataFetch, uncachedRequest,+    cacheRequest, cacheResult, cachedComputation,+    dumpCacheAsHaskell,++    -- * Unsafe operations+    unsafeLiftIO, unsafeToHaxlException,+  ) where++import Haxl.Core.Types+import Haxl.Core.Fetch+import Haxl.Core.Env+import Haxl.Core.Exception+import Haxl.Core.RequestStore+import Haxl.Core.Util+import Haxl.Core.DataCache++import qualified Data.Text as Text+import Control.Exception (Exception(..), SomeException)+import qualified Control.Exception+import Control.Applicative hiding (Const)+import GHC.Exts (IsString(..))+#if __GLASGOW_HASKELL__ < 706+import Prelude hiding (catch)+#endif+import Data.IORef+import Data.Monoid+import Text.Printf+import Text.PrettyPrint hiding ((<>))+import Control.Arrow (left)++-- -----------------------------------------------------------------------------+-- | The Haxl monad, which does several things:+--+--  * It is a reader monad for 'Env' and 'IORef' 'RequestStore', The+--    latter is the current batch of unsubmitted data fetch requests.+--+--  * It is a concurrency, or resumption, monad. A computation may run+--    partially and return 'Blocked', in which case the framework should+--    perform the outstanding requests in the 'RequestStore', and then+--    resume the computation.+--+--  * The Applicative combinator '<*>' explores /both/ branches in the+--    event that the left branch is 'Blocked', so that we can collect+--    multiple requests and submit them as a batch.+--+--  * It contains IO, so that we can perform real data fetching.+--+newtype GenHaxl u a = GenHaxl+  { unHaxl :: Env u -> IORef (RequestStore u) -> IO (Result u a) }++-- | The result of a computation is either 'Done' with a value, 'Throw'+-- with an exception, or 'Blocked' on the result of a data fetch with+-- a continuation.+data Result u a+  = Done a+  | Throw SomeException+  | Blocked (GenHaxl u a)++instance (Show a) => Show (Result u a) where+  show (Done a) = printf "Done(%s)" $ show a+  show (Throw e) = printf "Throw(%s)" $ show e+  show Blocked{} = "Blocked"++instance Monad (GenHaxl u) where+  return a = GenHaxl $ \_env _ref -> return (Done a)+  GenHaxl m >>= k = GenHaxl $ \env ref -> do+    e <- m env ref+    case e of+      Done a       -> unHaxl (k a) env ref+      Throw e      -> return (Throw e)+      Blocked cont -> return (Blocked (cont >>= k))++instance Functor (GenHaxl u) where+  fmap f m = pure f <*> m++instance Applicative (GenHaxl u) where+  pure = return+  GenHaxl f <*> GenHaxl a = GenHaxl $ \env ref -> do+    r <- f env ref+    case r of+      Throw e -> return (Throw e)+      Done f' -> do+        ra <- a env ref+        case ra of+          Done a'    -> return (Done (f' a'))+          Throw e    -> return (Throw e)+          Blocked a' -> return (Blocked (f' <$> a'))+      Blocked f' -> do+        ra <- a env ref  -- left is blocked, explore the right+        case ra of+          Done a'    -> return (Blocked (f' <*> return a'))+          Throw e    -> return (Blocked (f' <*> throw e))+          Blocked a' -> return (Blocked (f' <*> a'))++-- | Runs a 'Haxl' computation in an 'Env'.+runHaxl :: Env u -> GenHaxl u a -> IO a+runHaxl env (GenHaxl haxl) = do+  ref <- newIORef noRequests+  e <- haxl env ref+  case e of+    Done a       -> return a+    Throw e      -> Control.Exception.throw e+    Blocked cont -> do+      bs <- readIORef ref+      performFetches env bs+      runHaxl env cont++-- | Extracts data from the 'Env'.+env :: (Env u -> a) -> GenHaxl u a+env f = GenHaxl $ \env _ref -> return (Done (f env))++-- -----------------------------------------------------------------------------+-- Exceptions++-- | Throw an exception in the Haxl monad+throw :: (Exception e) => e -> GenHaxl u a+throw e = GenHaxl $ \_env _ref -> raise e++raise :: (Exception e) => e -> IO (Result u a)+raise = return . Throw . toException++catch :: Exception e => GenHaxl u a -> (e -> GenHaxl u a) -> GenHaxl u a+catch (GenHaxl m) h = GenHaxl $ \env ref -> do+   r <- m env ref+   case r of+     Done a    -> return (Done a)+     Throw e | Just e' <- fromException e -> unHaxl (h e') env ref+             | otherwise -> return (Throw e)+     Blocked k -> return (Blocked (catch k h))++try :: Exception e => GenHaxl u a -> GenHaxl u (Either e a)+try haxl = (Right <$> haxl) `catch` (return . Left)++-- -----------------------------------------------------------------------------+-- Unsafe operations++-- | Under ordinary circumstances this is unnecessary; users of the Haxl+-- monad should generally /not/ perform arbitrary IO.+unsafeLiftIO :: IO a -> GenHaxl u a+unsafeLiftIO m = GenHaxl $ \_env _ref -> Done <$> m++-- | Convert exceptions in the underlying IO monad to exceptions in+-- the Haxl monad.  This is morally unsafe, because you could then+-- catch those exceptions in Haxl and observe the underlying execution+-- order.  Not to be exposed to user code.+unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a+unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env ref -> do+  r <- m env ref `Control.Exception.catch` \e -> return (Throw e)+  case r of+    Blocked c -> return (Blocked (unsafeToHaxlException c))+    other -> return other++-- | Like 'try', but lifts all exceptions into the 'HaxlException'+-- hierarchy.  Uses 'unsafeToHaxlException' internally.  Typically+-- this is used at the top level of a Haxl computation, to ensure that+-- all exceptions are caught.+tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a)+tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)++-- -----------------------------------------------------------------------------+-- Data fetching and caching++-- | Performs actual fetching of data for a 'Request' from a 'DataSource'.+dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a+dataFetch req = GenHaxl $ \env ref -> do+  -- First, check the cache+  res <- cached env req+  case res of+    -- Not seen before: add the request to the RequestStore, so it+    -- will be fetched in the next round.+    Uncached rvar -> do+      modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs+      return $ Blocked (continueFetch req rvar)++    -- Seen before but not fetched yet.  We're blocked, but we don't have+    -- to add the request to the RequestStore.+    CachedNotFetched rvar -> return+      $ Blocked (continueFetch req rvar)++    -- Cached: either a result, or an exception+    Cached (Left ex) -> return (Throw ex)+    Cached (Right a) -> return (Done a)++-- | A data request that is not cached.  This is not what you want for+-- normal read requests, because then multiple identical requests may+-- return different results, and this invalidates some of the+-- properties that we expect Haxl computations to respect: that data+-- fetches can be aribtrarily reordered, and identical requests can be+-- commoned up, for example.+--+-- 'uncachedRequest' is useful for performing writes, provided those+-- are done in a safe way - that is, not mixed with reads that might+-- conflict in the same Haxl computation.+--+uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u a+uncachedRequest req = GenHaxl $ \_env ref -> do+  rvar <- newEmptyResult+  modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs+  return $ Blocked (continueFetch req rvar)++continueFetch+  :: (DataSource u r, Request r a, Show a)+  => r a -> ResultVar a -> GenHaxl u a+continueFetch req rvar = GenHaxl $ \_env _ref -> do+  m <- tryReadResult rvar+  case m of+    Nothing -> raise . DataSourceError $+      textShow req <> " did not set contents of result var"+    Just (Left e) -> return (Throw e)+    Just (Right a) -> return (Done a)++-- | Transparently provides caching. Useful for datasources that can+-- return immediately, but also caches values.+cacheResult :: (Request r a)  => r a -> IO a -> GenHaxl u a+cacheResult req val = GenHaxl $ \env _ref -> do+  cachedResult <- cached env req+  case cachedResult of+    Uncached rvar -> do+      result <- Control.Exception.try val+      putResult rvar result+      done result+    Cached result -> done result+    CachedNotFetched _ -> corruptCache+  where+    corruptCache = raise . DataSourceError $ Text.concat+      [ textShow req+      , " has a corrupted cache value: these requests are meant to"+      , " return immediately without an intermediate value. Either"+      , " the cache was updated incorrectly, or you're calling"+      , " cacheResult on a query that involves a blocking fetch."+      ]++-- | Inserts a request/result pair into the cache. Throws an exception+-- if the request has already been issued, either via 'dataFetch' or+-- 'cacheRequest'.+--+-- This can be used to pre-populate the cache when running tests, to+-- avoid going to the actual data source and ensure that results are+-- deterministic.+--+cacheRequest+  :: (Request req a) => req a -> Either SomeException a -> GenHaxl u ()+cacheRequest request result = GenHaxl $ \env _ref -> do+  res <- cached env request+  case res of+    Uncached rvar -> do+      -- request was not in the cache: insert the result and continue+      putResult rvar result+      return $ Done ()++    -- It is an error if the request is already in the cache.  We can't test+    -- whether the cached result is the same without adding an Eq constraint,+    -- and we don't necessarily have Eq for all results.+    _other -> raise $+      DataSourceError "cacheRequest: request is already in the cache"++instance IsString a => IsString (GenHaxl u a) where+  fromString s = return (fromString s)++-- | 'cachedComputation' memoizes a Haxl computation.  The key is a+-- request.+--+-- /Note:/ These cached computations will /not/ be included in the output+-- of 'dumpCacheAsHaskell'.+--+cachedComputation+   :: forall req u a. (Request req a)+   => req a -> GenHaxl u a -> GenHaxl u a+cachedComputation req haxl = GenHaxl $ \env ref -> do+  res <- memoized env req+  case res of+    -- Uncached: we must compute the result and store it in the ResultVar.+    Uncached rvar -> do+      let+          with_result :: Either SomeException a -> GenHaxl u a+          with_result r = GenHaxl $ \_ _ -> do putResult rvar r; done r++      unHaxl (try haxl >>= with_result) env ref++    -- CachedNotFetched: this request is already being computed, we just+    -- have to block until the result is available.  Note that we might+    -- have to block repeatedly, because the Haxl computation might block+    -- multiple times before it has a result.+    CachedNotFetched rvar -> return $ Blocked (continueCached rvar)+    Cached r -> done r++continueCached :: ResultVar a -> GenHaxl u a+continueCached rvar = GenHaxl $ \_env _ref -> do+  m <- tryReadResult rvar+  case m of+    -- Unlike dataFetch, Nothing is not an error here: the computation+    -- is being worked on elsewhere and probably got blocked in a+    -- datafetch, we just have to keep waiting for the result.+    Nothing -> return $ Blocked (continueCached rvar)+    Just r -> done r++-- | Lifts an 'Either' into either 'Throw' or 'Done'.+done :: Either SomeException a -> IO (Result u a)+done = return . either Throw Done++-- | Dump the contents of the cache as Haskell code that, when+-- compiled and run, will recreate the same cache contents.  For+-- example, the generated code looks something like this:+--+-- > loadCache :: GenHaxl u ()+-- > loadCache = do+-- >   cacheRequest (ListWombats 3) (Right ([1,2,3]))+-- >   cacheRequest (CountAardvarks "abcabc") (Right (2))+--+dumpCacheAsHaskell :: GenHaxl u String+dumpCacheAsHaskell = do+  ref <- env cacheRef  -- NB. cacheRef, not memoRef.  We ignore memoized+                       -- results when dumping the cache.+  entries <- unsafeLiftIO $ readIORef ref >>= showCache+  let+    mk_cr (req, res) =+      text "cacheRequest" <+> parens (text req) <+> parens (result res)+    result (Left e) = text "except" <+> parens (text (show e))+    result (Right s) = text "Right" <+> parens (text s)++  return $ show $+    text "loadCache :: GenHaxl u ()" $$+    text "loadCache = do" $$+      nest 2 (vcat (map mk_cr (concatMap snd entries))) $$+    text "" -- final newline
+ Haxl/Core/RequestStore.hs view
@@ -0,0 +1,70 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Bucketing requests by 'DataSource'.+--+-- When a request is issued by the client via 'dataFetch', it is placed+-- in the 'RequestStore'. When we are ready to fetch the current batch+-- of requests, the 'contents' operation extracts the fetches, bucketed+-- by 'DataSource'.+--+module Haxl.Core.RequestStore (+    BlockedFetches(..), RequestStore,+    noRequests, addRequest, contents+  ) where++import Haxl.Core.Types+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Typeable+import Unsafe.Coerce++-- | A container for multiple 'BlockedFetch' objects.+newtype RequestStore u = RequestStore (Map TypeRep (BlockedFetches u))+  -- Since we don't know which data sources we will be using, the store+  -- is dynamically-typed.  It maps the TypeRep of the request to the+  -- 'BlockedFetches' for that 'DataSource'.++-- | A batch of 'BlockedFetch' objects for a single 'DataSource'+data BlockedFetches u =+  forall r. (DataSource u r) => BlockedFetches [BlockedFetch r]++-- | A new empty 'RequestStore'.+noRequests :: RequestStore u+noRequests = RequestStore Map.empty++-- | Adds a 'BlockedFetch' to a 'RequestStore'.+addRequest+  :: forall u r. (DataSource u r)+  => BlockedFetch r -> RequestStore u -> RequestStore u+addRequest bf (RequestStore m) =+  RequestStore $ Map.insertWith combine ty (BlockedFetches [bf]) m+ where+  combine :: BlockedFetches u -> BlockedFetches u -> BlockedFetches u+  combine _ (BlockedFetches bfs)+    | typeOf1 (getR bfs) == ty = BlockedFetches (unsafeCoerce bf:bfs)+    | otherwise                = error "RequestStore.insert"+         -- the dynamic type check here should be unnecessary, but if+         -- there are bugs in `Typeable` or `Map` then we'll get an+         -- error instead of a crash.  The overhead is negligible.++  -- a type conversion only, so we can get the type of the reqeusts from+  -- the list of BlockedFetch.+  getR :: [BlockedFetch r1] -> r1 a+  getR _ = undefined++  -- The TypeRep of requests for this data source+  ty :: TypeRep+  ty = typeOf1 (undefined :: r a)++-- | Retrieves the whole contents of the 'RequestStore'.+contents :: RequestStore u -> [BlockedFetches u]+contents (RequestStore m) = Map.elems m
+ Haxl/Core/Show1.hs view
@@ -0,0 +1,15 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++module Haxl.Core.Show1+  ( Show1(..)+  ) where++-- | A class of type constructors for which we can show all+-- parameterizations.+class Show1 f where+  show1 :: f a -> String
+ Haxl/Core/StateStore.hs view
@@ -0,0 +1,67 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}++module Haxl.Core.StateStore (+    StateKey(..), StateStore, stateGet, stateSet, stateEmpty+  ) where++import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Typeable+import Unsafe.Coerce++-- | 'StateKey' maps one type to another type. A type that is an+-- instance of 'StateKey' can store and retrieve information from a+-- 'StateStore'.+--+#if __GLASGOW_HASKELL__ >= 708+class Typeable f => StateKey (f :: * -> *) where+  data State f+#else+class Typeable1 f => StateKey (f :: * -> *) where+  data State f+#endif++-- | The 'StateStore' maps a 'StateKey' to the 'State' for that type.+newtype StateStore = StateStore (Map TypeRep StateStoreData)++-- | Encapsulates the type of 'StateStore' data so we can have a+-- heterogeneous collection.+data StateStoreData = forall f. StateKey f => StateStoreData (State f)++-- | A `StateStore` with no entries.+stateEmpty :: StateStore+stateEmpty = StateStore Map.empty++-- | Inserts a `State` in the `StateStore` container.+stateSet :: forall f . StateKey f => State f -> StateStore -> StateStore+stateSet st (StateStore m) =+  StateStore (Map.insert (getType st) (StateStoreData st) m)++-- | Retrieves a `State` from the `StateStore` container.+stateGet :: forall r . StateKey r => StateStore -> Maybe (State r)+stateGet (StateStore m) =+  case Map.lookup ty m of+     Nothing -> Nothing+     Just (StateStoreData st)+       | getType st == ty  -> Just (unsafeCoerce st)+       | otherwise         -> Nothing+          -- the dynamic type check here should be unnecessary, but if+          -- there are bugs in `Typeable` or `Map` then we'll get an+          -- error instead of a crash.  The overhead is a few percent.+ where+  ty = getType (undefined :: State r)++-- | Returns the 'TypeRep' associated with a particular 'State'.+getType :: forall f . StateKey f => State f -> TypeRep+getType _ = typeOf1 (undefined :: f a)
+ Haxl/Core/Types.hs view
@@ -0,0 +1,363 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Base types used by all of Haxl.+module Haxl.Core.Types (++  -- * Initialization strategies+  InitStrategy(..),++  -- * Tracing flags+  Flags(..),+  defaultFlags,+  ifTrace,++  -- * Statistics+  Stats(..),+  RoundStats(..),+  emptyStats,+  numRounds,+  numFetches,++  -- * Data fetching+  DataSource(..),+  DataSourceName(..),+  Request,+  BlockedFetch(..),+  PerformFetch(..),++  -- * Result variables+  ResultVar(..),+  newEmptyResult,+  newResult,+  putFailure,+  putResult,+  putSuccess,+  takeResult,+  tryReadResult,+  tryTakeResult,++  -- * Default fetch implementations+  asyncFetch, asyncFetchWithDispatch,+  stubFetch,+  syncFetch,++  -- * Utilities+  except,+  setError,++  ) where++import Control.Applicative+import Control.Exception+import Data.Typeable+import Data.Text (Text)+import Data.Aeson+import Data.Hashable+import Control.Concurrent.MVar+import Control.Monad+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)++#if __GLASGOW_HASKELL__ < 708+import Haxl.Core.Util (tryReadMVar)+#endif+import Haxl.Core.Show1+import Haxl.Core.StateStore++-- | Initialization strategy. 'FullInit' will do as much initialization as+-- possible. 'FastInit' will postpone part of initialization or omit part of+-- initialization by sharing more resources. Use 'FastInit' if you want+-- fast initialization but don't care much about performance, for example, in+-- interactive environment.+data InitStrategy+  = FullInit+  | FastInit+  deriving (Enum, Eq, Show)++-- | Flags that control the operation of the engine.+data Flags = Flags+  { trace :: Int+    -- ^ Tracing level (0 = quiet, 3 = very verbose).+  }++defaultFlags :: Flags+defaultFlags = Flags { trace = 0 }++-- | Runs an action if the tracing level is above the given threshold.+ifTrace :: (Functor m, Monad m) => Flags -> Int -> m a -> m ()+ifTrace flags i m+  | trace flags >= i = void m+  | otherwise        = return ()++-- | Stats that we collect along the way.+newtype Stats = Stats [RoundStats]+  deriving ToJSON++-- | Maps data source name to the number of requests made in that round.+-- The map only contains entries for sources that made requests in that+-- round.+newtype RoundStats = RoundStats (HashMap Text Int)+  deriving ToJSON++fetchesInRound :: RoundStats -> Int+fetchesInRound (RoundStats hm) = sum $ HashMap.elems hm++emptyStats :: Stats+emptyStats = Stats []++numRounds :: Stats -> Int+numRounds (Stats rs) = length rs++numFetches :: Stats -> Int+numFetches (Stats rs) = sum (map fetchesInRound rs)++-- | The class of data sources, parameterised over the request type for+-- that data source. Every data source must implement this class.+--+-- A data source keeps track of its state by creating an instance of+-- 'StateKey' to map the request type to its state. In this case, the+-- type of the state should probably be a reference type of some kind,+-- such as 'IORef'.+--+-- For a complete example data source, see+-- <https://phabricator.fb.com/diffusion/FBCODE/browse/master/sigma/haxl/core/tests/ExampleDataSource.hs ExampleDataSource>.+--+class (DataSourceName req, StateKey req, Show1 req) => DataSource u req where++  -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch'+  -- objects contain both the request and the 'MVar's into which to put+  -- the results.+  fetch+    :: State req+      -- ^ Current state.+    -> Flags+      -- ^ Tracing flags.+    -> u+      -- ^ User environment.+    -> [BlockedFetch req]+      -- ^ Requests to fetch.+    -> PerformFetch+      -- ^ Fetch the data; see 'PerformFetch'.++class DataSourceName req where+  -- | The name of this 'DataSource', used in tracing and stats. Must+  -- take a dummy request.+  dataSourceName :: req a -> Text++-- The 'Show1' class is a workaround for the fact that we can't write+-- @'Show' (req a)@ as a superclass of 'DataSource', without also+-- parameterizing 'DataSource' over @a@, which is a pain (I tried+-- it). 'Show1' seems fairly benign, though.++-- | A convenience only: package up 'Eq', 'Hashable', 'Typeable', and 'Show'+-- for requests into a single constraint.+type Request req a =+  ( Eq (req a)+  , Hashable (req a)+  , Typeable (req a)+  , Show (req a)+  , Show a+  )++-- | A data source can fetch data in one of two ways.+--+--   * Synchronously ('SyncFetch'): the fetching operation is an+--     @'IO' ()@ that fetches all the data and then returns.+--+--   * Asynchronously ('AsyncFetch'): we can do something else while the+--     data is being fetched. The fetching operation takes an @'IO' ()@ as+--     an argument, which is the operation to perform while the data is+--     being fetched.+--+-- See 'syncFetch' and 'asyncFetch' for example usage.+--+data PerformFetch+  = SyncFetch  (IO ())+  | AsyncFetch (IO () -> IO ())++-- | A 'BlockedFetch' is a pair of+--+--   * The request to fetch (with result type @a@)+--+--   * An 'MVar' to store either the result or an error+--+-- We often want to collect together multiple requests, but they return+-- different types, and the type system wouldn't let us put them+-- together in a list because all the elements of the list must have the+-- same type. So we wrap up these types inside the 'BlockedFetch' type,+-- so that they all look the same and we can put them in a list.+--+-- When we unpack the 'BlockedFetch' and get the request and the 'MVar'+-- out, the type system knows that the result type of the request+-- matches the type parameter of the 'MVar', so it will let us take the+-- result of the request and store it in the 'MVar'.+--+data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a)++-- | Function for easily setting a fetch to a particular exception+setError :: (Exception e) => (forall a. r a -> e) -> BlockedFetch r -> IO ()+setError e (BlockedFetch req m) = putFailure m (e req)++except :: (Exception e) => e -> Either SomeException a+except = Left . toException++-- | A sink for the result of a data fetch, used by 'BlockedFetch' and the+-- 'DataCache'. Why do we need an 'MVar' here?  The reason is that the cache+-- serves two purposes:+--+--  1. To cache the results of requests that were submitted in a previous round.+--+--  2. To remember requests that have been encountered in the current round but+--     are not yet submitted, so that if we see the request again we can make+--     sure that we only submit it once.+--+-- Storing the result as an 'MVar' gives two benefits:+--+--   * We can tell the difference between (1) and (2) by testing whether the+--     'MVar' is empty. See 'Haxl.Fetch.cached'.+--+--   * In the case of (2), we don't have to update the cache again after the+--     current round, and after the round we can read the result of each request+--     from its 'MVar'. All instances of identical requests will share the same+--     'MVar' to obtain the result.+--+newtype ResultVar a = ResultVar (MVar (Either SomeException a))++newResult :: a -> IO (ResultVar a)+newResult x = ResultVar <$> newMVar (Right x)++newEmptyResult :: IO (ResultVar a)+newEmptyResult = ResultVar <$> newEmptyMVar++putFailure :: (Exception e) => ResultVar a -> e -> IO ()+putFailure r = putResult r . except++putSuccess :: ResultVar a -> a -> IO ()+putSuccess r = putResult r . Right++putResult :: ResultVar a -> Either SomeException a -> IO ()+putResult (ResultVar var) = putMVar var++takeResult :: ResultVar a -> IO (Either SomeException a)+takeResult (ResultVar var) = takeMVar var++tryReadResult :: ResultVar a -> IO (Maybe (Either SomeException a))+tryReadResult (ResultVar var) = tryReadMVar var++tryTakeResult :: ResultVar a -> IO (Maybe (Either SomeException a))+tryTakeResult (ResultVar var) = tryTakeMVar var++-- Fetch templates++stubFetch+  :: (Exception e) => (forall a. r a -> e)+  -> State r -> Flags -> u -> [BlockedFetch r] -> PerformFetch+stubFetch e _state _flags _si bfs = SyncFetch $ mapM_ (setError e) bfs++-- | Common implementation templates for 'fetch' of 'DataSource'.+--+-- Example usage:+--+-- > fetch = syncFetch MyDS.withService MyDS.retrieve+-- >   $ \service request -> case request of+-- >     This x -> MyDS.fetchThis service x+-- >     That y -> MyDS.fetchThat service y+--+asyncFetchWithDispatch+  :: ((service -> IO ()) -> IO ())+  -- ^ Wrapper to perform an action in the context of a service.++  -> (service -> IO ())+  -- ^ Dispatch all the pending requests++  -> (service -> IO ())+  -- ^ Wait for the results++  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -- ^ Enqueue an individual request to the service.++  -> State request+  -- ^ Currently unused.++  -> Flags+  -- ^ Currently unused.++  -> u+  -- ^ Currently unused.++  -> [BlockedFetch request]+  -- ^ Requests to submit.++  -> PerformFetch++asyncFetch, syncFetch+  :: ((service -> IO ()) -> IO ())+  -- ^ Wrapper to perform an action in the context of a service.++  -> (service -> IO ())+  -- ^ Dispatch all the pending requests and wait for the results++  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -- ^ Submits an individual request to the service.++  -> State request+  -- ^ Currently unused.++  -> Flags+  -- ^ Currently unused.++  -> u+  -- ^ Currently unused.++  -> [BlockedFetch request]+  -- ^ Requests to submit.++  -> PerformFetch++asyncFetchWithDispatch+  withService dispatch wait enqueue _state _flags _si requests =+  AsyncFetch $ \inner -> withService $ \service -> do+    getResults <- mapM (submitFetch service enqueue) requests+    dispatch service+    inner+    wait service+    sequence_ getResults++asyncFetch withService wait enqueue _state _flags _si requests =+  AsyncFetch $ \inner -> withService $ \service -> do+    getResults <- mapM (submitFetch service enqueue) requests+    inner+    wait service+    sequence_ getResults++syncFetch withService dispatch enqueue _state _flags _si requests =+  SyncFetch . withService $ \service -> do+  getResults <- mapM (submitFetch service enqueue) requests+  dispatch service+  sequence_ getResults++-- | Used by 'asyncFetch' and 'syncFetch' to retrieve the results of+-- requests to a service.+submitFetch+  :: service+  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -> BlockedFetch request+  -> IO (IO ())+submitFetch service fetch (BlockedFetch request result)+  = (putResult result =<<) <$> fetch service request
+ Haxl/Core/Util.hs view
@@ -0,0 +1,40 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE CPP #-}++module Haxl.Core.Util+  ( compose+  , textShow+  , tryReadMVar+  ) where++#if __GLASGOW_HASKELL__ >= 708+import Control.Concurrent (tryReadMVar)+#else+import Control.Concurrent+#endif++import Data.Text (Text)++import qualified Data.Text as Text++-- | Composes a list of endofunctions.+compose :: [a -> a] -> a -> a+compose = foldr (.) id++#if __GLASGOW_HASKELL__ < 708+tryReadMVar :: MVar a -> IO (Maybe a)+tryReadMVar m = do+  mb <- tryTakeMVar m+  case mb of+    Nothing -> return Nothing+    Just a -> putMVar m a >> return (Just a)+#endif++textShow :: (Show a) => a -> Text+textShow = Text.pack . show
+ Haxl/Prelude.hs view
@@ -0,0 +1,210 @@+-- Copyright (c) 2014, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. An additional grant of patent rights can+-- be found in the PATENTS file.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Support for using Haxl as a DSL.  This module provides most of+-- the standard Prelude, plus a selection of stuff that makes it+-- Haxl client code cleaner and more concise.+--+-- We intend Haxl client code to:+--+--  * Import @Haxl.Prelude@+--+--  * Use @RebindableSyntax@.  This implies @NoImplicitPrelude@, and+--    allows @if@-@then@-@else@ to be used with a monadic condition.+--+--  * Use @OverloadedStrings@  (we use @Text@ a lot)+--+module Haxl.Prelude (+    -- * The Standard Haskell Prelude+    -- | Everything from "Prelude" except 'mapM', 'mapM_',+    -- 'sequence', and 'sequence'+    module Prelude,++    -- * Haxl and Fetching data+    GenHaxl, dataFetch, DataSource,++    -- * Extra Monad and Applicative things+    Applicative(..),+    mapM, mapM_, sequence, sequence_, (<$>), filterM, foldM,+    forM, forM_,+    foldl', sort,+    Monoid(..),+    join,++    -- * Lifted operations+    IfThenElse(..),+    (.>), (.<), (.>=), (.<=),+    (.==), (./=), (.&&), (.||),+    (.++),+    pair,++    -- * Text things+    Text,+    IsString(..),++    -- * Exceptions+    throw, catch, try, withDefault, catchAny,+    HaxlException(..), TransientError(..), LogicError(..),+    NotFound(..), UnexpectedType(..), FetchError(..),+    EmptyList(..), InvalidParameter(..)++  ) where++import Haxl.Core.Types+import Haxl.Core.Exception+import Haxl.Core.Monad++import Control.Applicative+import Control.Monad (foldM, join)+import Data.List (foldl', sort)+import Data.Text (Text)+import Data.Traversable hiding (forM, mapM, sequence)+import GHC.Exts (IsString(..))+import Prelude hiding (mapM, mapM_, sequence, sequence_)+import Data.Monoid+import Data.Maybe+import Control.Exception (fromException)++infixr 3 .&&+infixr 2 .||+infix  4 .>, .<, .>=, .<=, .==, ./=++-- -----------------------------------------------------------------------------+-- Haxl versions of Haskell Prelude stuff++-- Using overloading and RebindableSyntax to hide the monad as far as+-- possible.++class IfThenElse a b where+  ifThenElse :: a -> b -> b -> b++instance IfThenElse Bool a where+  ifThenElse b t e = case b of True -> t; False -> e++-- The equality constraint is necessary to convince the typechecker that+-- this is valid:+--+-- > if getCountry ip .== "us" then ... else ...+--+instance (u1 ~ u2) => IfThenElse (GenHaxl u1 Bool) (GenHaxl u2 a) where+  ifThenElse fb t e = do+    b <- fb+    if b then t else e++instance Num a => Num (GenHaxl u a) where+  (+)         = liftA2 (+)+  (-)         = liftA2 (-)+  (*)         = liftA2 (*)+  fromInteger = pure . fromInteger+  abs         = liftA abs+  signum      = liftA signum+  negate      = liftA negate++instance Fractional a => Fractional (GenHaxl u a) where+  (/) = liftA2 (/)+  recip = liftA recip+  fromRational = return . fromRational++-- -----------------------------------------------------------------------------+-- Convenience functions for avoiding do-notation boilerplate++-- convention is to prefix the name with a '.'.  We could change this,+-- or even just not provide these at all.++(.>) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.>) = liftA2 (Prelude.>)++(.<) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.<) = liftA2 (Prelude.<)++(.>=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.>=) = liftA2 (Prelude.>=)++(.<=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.<=) = liftA2 (Prelude.<=)++(.==) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.==) = liftA2 (Prelude.==)++(./=) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(./=) = liftA2 (Prelude./=)++(.++) :: GenHaxl u [a] -> GenHaxl u [a] -> GenHaxl u [a]+(.++) = liftA2 (Prelude.++)++-- short-circuiting Bool operations+(.&&):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool+fa .&& fb = do a <- fa; if a then fb else return False++(.||):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool+fa .|| fb = do a <- fa; if a then return True else fb++pair :: GenHaxl u a -> GenHaxl u b -> GenHaxl u (a, b)+pair = liftA2 (,)++-- -----------------------------------------------------------------------------+-- Applicative traversals++-- | We don't want the monadic 'mapM', because that doesn't do batching.+-- There doesn't seem to be a way to make 'Data.Traversable.mapM' have+-- the right behaviour when used with Haxl, so instead we define 'mapM'+-- to be 'traverse' in Haxl code.+mapM :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)+mapM = traverse++forM :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)+forM = flip mapM++-- | See 'mapM'.+mapM_ :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f ()+mapM_ f t = const () <$> traverse f t++forM_ :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f ()+forM_ = flip mapM_++-- | See 'mapM'.+sequence :: (Traversable t, Applicative f) => t (f a) -> f (t a)+sequence = sequenceA++-- | See 'mapM'.+sequence_ :: (Traversable t, Applicative f) => t (f a) -> f ()+sequence_ t = const () <$> sequenceA t++-- | See 'mapM'.+filterM :: (Applicative f, Monad f) => (a -> f Bool) -> [a] -> f [a]+filterM pred xs = do+  bools <- mapM pred xs+  return [ x | (x,True) <- zip xs bools ]++--------------------------------------------------------------------------------++-- | Runs the given 'GenHaxl' computation, and if it throws a+-- 'TransientError' or 'LogicError' exception (see+-- "Haxl.Core.Exception"), the exception is ignored and the supplied+-- default value is returned instead.+withDefault :: a -> GenHaxl u a -> GenHaxl u a+withDefault d a = catchAny a (return d)++-- | Catch 'LogicError's and 'TransientError's and perform an alternative action+catchAny+  :: GenHaxl u a   -- ^ run this first+  -> GenHaxl u a   -- ^ if it throws 'LogicError' or 'TransientError', run this+  -> GenHaxl u a+catchAny haxl handler =+  haxl `catch` \e ->+    if isJust (fromException e :: Maybe LogicError) ||+       isJust (fromException e :: Maybe TransientError)+      then+        handler+      else+        throw e
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Facebook, Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this+     list of conditions and the following disclaimer.++  2. Redistributions in binary form must reproduce the above copyright notice,+     this list of conditions and the following disclaimer in the documentation+     and/or other materials provided with the distribution.++  3. Neither the name of the copyright holder nor the names of its contributors+     may be used to endorse or promote products derived from this software+     without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ PATENTS view
@@ -0,0 +1,23 @@+Additional Grant of Patent Rights++"Software" means the Haxl software distributed by Facebook, Inc.++Facebook hereby grants you a perpetual, worldwide, royalty-free, non-exclusive,+irrevocable (subject to the termination provision below) license under any+rights in any patent claims owned by Facebook, to make, have made, use, sell,+offer to sell, import, and otherwise transfer the Software. For avoidance of+doubt, no license is granted under Facebook's rights in any patent claims that+are infringed by (i) modifications to the Software made by you or a third party,+or (ii) the Software in combination with any software or other technology+provided by you or a third party.++The license granted hereunder will terminate, automatically and without notice,+for anyone that makes any claim (including by filing any lawsuit, assertion or+other action) alleging (a) direct, indirect, or contributory infringement or+inducement to infringe any patent: (i) by Facebook or any of its subsidiaries or+affiliates, whether or not such claim is related to the Software, (ii) by any+party if such claim arises in whole or in part from any software, product or+service of Facebook or any of its subsidiaries or affiliates, whether or not+such claim is related to the Software, or (iii) by any party relating to the+Software; or (b) that any right in any patent claim of Facebook is invalid or+unenforceable.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haxl.cabal view
@@ -0,0 +1,101 @@+name:                haxl+version:             0.1.0.0+synopsis:            A Haskell library for efficient, concurrent,+                     and concise data access.+homepage:            https://github.com/facebook/Haxl+bug-reports:         https://github.com/facebook/Haxl/issues+license:             BSD3+license-file:        LICENSE+author:              Facebook, Inc.+maintainer:          The Haxl Team <haxl-team@fb.com>+copyright:           2014 (C) 2014 Facebook, Inc.+category:            Concurrency+build-type:          Simple+stability:           alpha+cabal-version:       >= 1.10++description:+  Haxl is a library and EDSL for efficient scheduling of concurrent data+  accesses with a concise applicative API.++extra-source-files:+  readme.md+  PATENTS+  tests/LoadCache.txt++library++  build-depends:+    HUnit == 1.2.*,+    aeson >= 0.6 && <0.8,+    base == 4.*,+    bytestring >= 0.9 && <0.11,+    containers == 0.5.*,+    directory >= 1.1 && <1.3,+    filepath == 1.3.*,+    hashable == 1.2.*,+    pretty == 1.1.*,+    text == 1.1.*,+    time == 1.4.*,+    unordered-containers == 0.2.*,+    vector == 0.10.*++  exposed-modules:+    Haxl.Core,+    Haxl.Core.DataCache,+    Haxl.Core.Exception,+    Haxl.Core.Env,+    Haxl.Core.Fetch,+    Haxl.Core.Monad,+    Haxl.Core.RequestStore,+    Haxl.Core.StateStore,+    Haxl.Core.Show1,+    Haxl.Core.Types,+    Haxl.Prelude++  other-modules:+    Haxl.Core.Util++  default-language: Haskell2010++  ghc-options:+    -Wall+    -fno-warn-name-shadowing+++test-suite test++  build-depends:+    HUnit,+    aeson,+    base == 4.*,+    bytestring,+    containers,+    hashable,+    haxl,+    text,+    unordered-containers++  ghc-options:+    -Wall+    -fno-warn-name-shadowing+    -fno-warn-missing-signatures++  hs-source-dirs:+    tests++  main-is:+    Main.hs++  other-modules:+    BatchTests+    CoreTests+    DataCacheTest+    ExampleDataSource+    LoadCache+    MockTAO+    TestExampleDataSource+    TestTypes++  type:+    exitcode-stdio-1.0
+ readme.md view
@@ -0,0 +1,49 @@+![Haxl Logo](http://github.com/facebook/Haxl/raw/master/logo.png)++# Haxl++Haxl is a Haskell library that simplifies access to remote data, such+as databases or web-based services. Haxl can automatically++ * batch multiple requests to the same data source,+ * request data from multiple data sources concurrently,+ * cache previous requests.++Having all this handled for you behind the scenes means that your+data-fetching code can be much cleaner and clearer than it would+otherwise be if it had to worry about optimizing data-fetching. We'll+give some examples of how this works in the pages linked below.++There are two Haskell packages here:++ * `haxl`: The core Haxl framework+ * `haxl-facebook` (in [example/facebook](example/facebook)): An (incomplete) example data source for accessing the Facebook Graph API++To use Haxl in your own application, you will likely need to build one or more+*data sources*: the thin layer between Haxl and the data that you want+to fetch, be it a database, a web API, a cloud service, or whatever.+The `haxl-facebook` package shows how we might build a Haxl data+source based on the existing `fb` package for talking to the Facebook+Graph API.++## Where to go next?++ * *The Story of Haxl* (a blog post to be published very soon!)+   explains how Haxl came about at Facebook, and discusses our+   particular use case.++ * [An example Facebook data source](example/facebook/readme.md) walks+   through building an example data source that queries the Facebook+   Graph API concurrently.++ * [The N+1 Selects Problem](example/sql/readme.md) explains how Haxl+   can address a common performance problem with SQL queries by+   automatically batching multiple queries into a single query,+   completely invisibly to the programmer.++ * [Haxl Documentation](http://hackage.haskell.org/package/haxl) on+   Hackage.++ * *There is no Fork: An Abstraction for Efficient, Concurrent, and+   Concise Data Access*, our paper on Haxl, accepted for publication+   at ICFP'14.  Online version coming soon (June 12).
+ tests/BatchTests.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+module BatchTests (tests) where++import TestTypes+import MockTAO++import Control.Applicative+import Data.IORef+import Data.Aeson+import Test.HUnit+import qualified Data.HashMap.Strict as HashMap++import Haxl.Core++import Prelude()+import Haxl.Prelude++-- -----------------------------------------------------------------------------++testinput :: Object+testinput = HashMap.fromList [+  "A" .= (1 :: Int),+  "B" .= (2 :: Int),+  "C" .= (3 :: Int),+  "D" .= (4 :: Int) ]++makeTestEnv :: IO (Env UserEnv)+makeTestEnv = do+  tao <- MockTAO.initGlobalState+  let st = stateSet tao stateEmpty+  initEnv st testinput++expectRoundsWithEnv+  :: (Eq a, Show a) => Int -> a -> Haxl a -> Env UserEnv -> Assertion+expectRoundsWithEnv n result haxl env = do+  a <- runHaxl env haxl+  assertEqual "result" result a+  stats <- readIORef (statsRef env)+  assertEqual "rounds" n (numRounds stats)++expectRounds :: (Eq a, Show a) => Int -> a -> Haxl a -> Assertion+expectRounds n result haxl = do+  env <- makeTestEnv+  expectRoundsWithEnv n result haxl env++expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Assertion+expectFetches n haxl = do+  env <- makeTestEnv+  _ <- runHaxl env haxl+  stats <- readIORef (statsRef env)+  assertEqual "fetches" n (numFetches stats)++friendsOf :: Id -> Haxl [Id]+friendsOf = assocRangeId2s friendsAssoc++id1 :: Haxl Id+id1 = lookupInput "A"++id2 :: Haxl Id+id2 = lookupInput "B"++id3 :: Haxl Id+id3 = lookupInput "C"++--+-- Test batching over multiple arguments in liftA2+--+batching1 = expectRounds 1 12 batching1_++batching1_ = do+  a <- id1+  b <- id2+  length <$> liftA2 (++) (friendsOf a) (friendsOf b)++--+-- Test batching in mapM (which is really traverse)+--+batching2 = expectRounds 1 12 batching2_++batching2_ = do+  a <- id1+  b <- id2+  fs <- mapM friendsOf [a,b]+  return (sum (map length fs))++--+-- Test batching when we have a monadic bind in each branch+--+batching3 = expectRounds 1 12 batching3_++batching3_ = do+  let a = id1 >>= friendsOf+      b = id2 >>= friendsOf+  length <$> a .++ b++--+-- Test batching over both arguments of (+)+--+batching4 = expectRounds 1 12 batching4_++batching4_ = do+  let a = length <$> (id1 >>= friendsOf)+      b = length <$> (id2 >>= friendsOf)+  a + b++--+-- Test batching over both arguments of (+)+--+batching5 = expectRounds 1 2 batching5_++batching5_ :: Haxl Int+batching5_ = if a .> b then 1 else 2+ where+  a = length <$> (id1 >>= friendsOf)+  b = length <$> (id2 >>= friendsOf)++--+-- Test batching when we perform all batching tests together with sequence+--+batching6 = expectRounds 1 [12,12,12,12,2] batching6_++batching6_ = sequence [batching1_,batching2_,batching3_,batching4_,batching5_]++--+-- Ensure if/then/else and bool operators break batching+--+batching7 = expectRounds 2 12 batching7_++batching7_ :: Haxl Int+batching7_ = if a .> 0 then a+b else 0+ where+  a = length <$> (id1 >>= friendsOf)+  b = length <$> (id2 >>= friendsOf)++-- We expect 3 rounds here due to boolean operators+batching8 = expectRounds 3 12 batching8_++batching8_ :: Haxl Int+batching8_ = if (c .== 0) .|| (a .> 0 .&& b .> 0) then a+b else 0+ where+  a = length <$> (id1 >>= friendsOf)+  b = length <$> (id2 >>= friendsOf)+  c = length <$> (id3 >>= friendsOf)++--+-- Test data caching, numFetches+--++-- simple (one cache hit)+caching1 = expectFetches 3 caching1_+caching1_ = nf id1 + nf id2 + nf id3 + nf id3+ where+  nf id = length <$> (id >>= friendsOf)++-- simple, in rounds (no cache hits)+caching2 = expectFetches 3 caching2_+caching2_ = if nf id1 .> 0 then nf id2 + nf id3 else 0+ where+  nf id = length <$> (id >>= friendsOf)++-- rounds (one cache hit)+caching3 = expectFetches 3 caching3_+caching3_ = if nf id1 .> 0 then nf id1 + nf id2 + nf id3 else 0+ where+  nf id = length <$> (id >>= friendsOf)++--+-- Basic sanity check on data-cache re-use+--+cacheReuse = do+  env <- makeTestEnv+  expectRoundsWithEnv 2 12 batching7_ env++  -- make a new env+  tao <- MockTAO.initGlobalState+  let st = stateSet tao stateEmpty+  env2 <- initEnvWithData st testinput (caches env)++  -- ensure no more data fetching rounds needed+  expectRoundsWithEnv 0 12 batching7_ env2++tests = TestList+  [ TestLabel "batching1" $ TestCase batching1+  , TestLabel "batching2" $ TestCase batching2+  , TestLabel "batching3" $ TestCase batching3+  , TestLabel "batching4" $ TestCase batching4+  , TestLabel "batching5" $ TestCase batching5+  , TestLabel "batching6" $ TestCase batching6+  , TestLabel "batching7" $ TestCase batching7+  , TestLabel "batching8" $ TestCase batching8+  , TestLabel "caching1" $ TestCase caching1+  , TestLabel "caching2" $ TestCase caching2+  , TestLabel "caching3" $ TestCase caching3+  , TestLabel "CacheReuse" $ TestCase cacheReuse+  , TestLabel "exceptionTest1" $ TestCase exceptionTest1+  , TestLabel "exceptionTest2" $ TestCase exceptionTest2+  , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions+  ]++exceptionTest1 = expectRounds 1 []+  $ withDefault [] $ friendsOf 101++exceptionTest2 = expectRounds 1 [7..12] $ liftA2 (++)+  (withDefault [] (friendsOf 101))+  (withDefault [] (friendsOf 2))++deterministicExceptions = do+  env <- makeTestEnv+  let haxl =+        sequence [ do _ <- friendsOf =<< id1; throw (NotFound "xxx")+                 , throw (NotFound "yyy")+                 ]+  -- the first time, friendsOf should block, but we should still get the+  -- "xxx" exception.+  r <- runHaxl env $ try haxl+  assertBool "exceptionTest3" $+    case r of+     Left (NotFound "xxx") -> True+     _ -> False+  -- the second time, friendsOf will be cached, and we should get the "xxx"+  -- exception as before.+  r <- runHaxl env $ try haxl+  assertBool "exceptionTest3" $+    case r of+     Left (NotFound "xxx") -> True+     _ -> False
+ tests/CoreTests.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+module CoreTests where++import Haxl.Prelude+import Prelude ()++import Haxl.Core++import Test.HUnit++import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BS++import Control.Exception (Exception(..))++useless :: String -> GenHaxl u Bool+useless _ = throw (NotFound "ha ha")++en = error "no env"++exceptions :: Assertion+exceptions =+  do+    a <- runHaxl en $ try (useless "input")+    assertBool "NotFound -> HaxlException" $+      isLeft (a :: Either HaxlException Bool)++    b <- runHaxl en $ try (useless "input")+    assertBool "NotFound -> Logic Error" $+      isLeft (b :: Either LogicError Bool)++    c <- runHaxl en $ try (useless "input")+    assertBool "NotFound -> NotFound" $+      isLeft (c :: Either NotFound Bool)++    -- Make sure TransientError -doesn't- catch our NotFound+    d <- runHaxl en $+             (useless "input"+              `catch` \TransientError{} -> return False)+             `catch` \LogicError{} -> return True+    assertBool "Transient != NotFound" d++    -- test catch+    e <- runHaxl en $+         throw (NotFound "haha") `catch` \NotFound{} -> return True+    assertBool "catch1" e++    f <- runHaxl en $+         throw (NotFound "haha") `catch` \LogicError{} -> return True+    assertBool "catch2" f+  where+  isLeft Left{} = True+  isLeft _ = False++-- This is mostly a compile test, to make sure all the plumbing+-- makes the compiler happy.+base :: (Exception a) => a -> IO HaxlException+base e = runHaxl en $ throw e `catch` \x -> return x++printing :: Assertion+printing = do+  a <- base $ NotFound "notfound!"+  print a++  b <- base $ CriticalError "ohthehumanity!"+  print b++  c <- base $ FetchError "timeout!"+  print c++  BS.putStrLn $ encode a+  BS.putStrLn $ encode b+  BS.putStrLn $ encode c+++tests = TestList+  [ TestLabel "exceptions" $ TestCase exceptions,+    TestLabel "print_stuff" $ TestCase printing+  ]
+ tests/DataCacheTest.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-}+module DataCacheTest (tests) where++import Haxl.Core.DataCache as DataCache+import Haxl.Core.Types++import Control.Exception+import Data.Hashable+import Data.Traversable+import Data.Typeable+import Prelude hiding (mapM)+import Test.HUnit++data TestReq a where+   Req :: Int -> TestReq a -- polymorphic result+  deriving Typeable++deriving instance Eq (TestReq a)+deriving instance Show (TestReq a)++instance Hashable (TestReq a) where+  hashWithSalt salt (Req i) = hashWithSalt salt i+++dcSoundnessTest :: Test+dcSoundnessTest = TestLabel "DataCache soundness" $ TestCase $ do+  m1 <- newResult 1+  m2 <- newResult "hello"+  let cache =+          DataCache.insert (Req 1 :: TestReq Int) m1 $+          DataCache.insert (Req 2 :: TestReq String) m2 $+          DataCache.empty++  -- "Req 1" has a result of type Int, so if we try to look it up+  -- with a result of type String, we should get Nothing, not a crash.+  r <- mapM takeResult $ DataCache.lookup (Req 1) cache+  assertBool "dcSoundness1" $+    case r :: Maybe (Either SomeException String) of+     Nothing -> True+     _something_else -> False++  r <- mapM takeResult $ DataCache.lookup (Req 1) cache+  assertBool "dcSoundness2" $+    case r :: Maybe (Either SomeException Int) of+     Just (Right 1) -> True+     _something_else -> False++  r <- mapM takeResult $ DataCache.lookup (Req 2) cache+  assertBool "dcSoundness3" $+    case r :: Maybe (Either SomeException String) of+      Just (Right "hello") -> True+      _something_else -> False++  r <- mapM takeResult $ DataCache.lookup (Req 2) cache+  assertBool "dcSoundness4" $+    case r :: Maybe (Either SomeException Int) of+      Nothing -> True+      _something_else -> False+++-- tests :: Assertion+tests = TestList [dcSoundnessTest]
+ tests/ExampleDataSource.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}++module ExampleDataSource (+    -- * initialise the state+    initGlobalState,++    -- * requests for this data source+    ExampleReq(..),+    countAardvarks,+    listWombats,+  ) where++import Haxl.Prelude+import Prelude ()++import Haxl.Core++import Data.Typeable+import Data.Hashable++-- Here is an example minimal data source.  Our data source will have+-- two requests:+--+--   countAardvarks :: String -> Haxl Int+--   listWombats    :: Id     -> Haxl [Id]+--+-- First, the data source defines a request type, with one constructor+-- for each request:++newtype Id = Id Int+  deriving (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable)++instance Show Id where+  show (Id i) = show i++data ExampleReq a where+  CountAardvarks :: String -> ExampleReq Int+  ListWombats    :: Id     -> ExampleReq [Id]+  deriving Typeable -- requests must be Typeable++-- The request type (ExampleReq) is parameterized by the result type of+-- each request.  Each request might have a different result, so we use a+-- GADT - a data type in which each constructor may have different type+-- parameters. Here CountAardvarks is a request that takes a String+-- argument and its result is Int, whereas ListWombats takes an Id+-- argument and returns a [Id].++-- The request type needs instances for 'Eq1' and 'Hashable1'.  These+-- are like 'Eq' and 'Hashable', but for types with one parameter+-- where the parameter is irrelevant for hashing and equality.+-- These two instances are used to support caching of requests.++-- We need Eq, but we have to derive it with a standalone declaration+-- like this, because plain deriving doesn't work with GADTs.+deriving instance Eq (ExampleReq a)++deriving instance Show (ExampleReq a)++instance Show1 ExampleReq where show1 = show++instance Hashable (ExampleReq a) where+   hashWithSalt s (CountAardvarks a) = hashWithSalt s (0::Int,a)+   hashWithSalt s (ListWombats a)    = hashWithSalt s (1::Int,a)++instance StateKey ExampleReq where+  data State ExampleReq = ExampleState {+        -- in here you can put any state that the+        -- data source needs to maintain throughout the+        -- run.+        }++-- Next we need to define an instance of DataSourceName:++instance DataSourceName ExampleReq where+  dataSourceName _ = "ExampleDataSource"++-- Next we need to define an instance of DataSource:++instance DataSource u ExampleReq where+  -- I'll define exampleFetch below+  fetch = exampleFetch+++-- Every data source should define a function 'initGlobalState' that+-- initialises the state for that data source.  The arguments to this+-- function might vary depending on the data source - we might need to+-- pass in resources from the environment, or parameters to set up the+-- data source.+initGlobalState :: IO (State ExampleReq)+initGlobalState = do+  -- initialize the state here.+  return ExampleState { }+++-- The most important bit: fetching the data.  The fetching function+-- takes a list of BlockedFetch, which is defined as+--+-- data BlockedFetch r+--   = forall a . BlockedFetch (r a) (ResultVar a)+--+-- That is, each BlockedFetch is a pair of+--+--   - the request to fetch (with result type a)+--   - a ResultVar to store either the result or an error+--+-- The job of fetch is to fetch the data and fill in all the ResultVars.+--+exampleFetch :: State ExampleReq             -- current state+             -> Flags                        -- tracing verbosity, etc.+             -> u                            -- user environment+             -> [BlockedFetch ExampleReq]    -- requests to fetch+             -> PerformFetch                 -- tells the framework how to fetch++exampleFetch _state _flags _user bfs = SyncFetch $ mapM_ fetch1 bfs++  -- There are two ways a data source can fetch data: synchronously or+  -- asynchronously.  See the type 'PerformFetch' in "Haxl.Core.Types" for+  -- details.++fetch1 :: BlockedFetch ExampleReq -> IO ()+fetch1 (BlockedFetch (CountAardvarks "BANG") _) =+  error "BANG"  -- data sources should not throw exceptions, but in+                -- the event that one does, the framework will+                -- propagate the exception to the call site of+                -- dataFetch.+fetch1 (BlockedFetch (CountAardvarks "BANG2") m) = do+  putSuccess m 1+  error "BANG2" -- the exception is propagated even if we have already+                -- put the result with putSuccess+fetch1 (BlockedFetch (CountAardvarks str) m) =+  putSuccess m (length (filter (== 'a') str))+fetch1 (BlockedFetch (ListWombats a) r) =+  if a > 99 then putFailure r $ FetchError "too large"+            else putSuccess r $ take (fromIntegral a) [1..]+++-- Normally a data source will provide some convenient wrappers for+-- its requests:++countAardvarks :: String -> GenHaxl () Int+countAardvarks str = dataFetch (CountAardvarks str)++listWombats :: Id -> GenHaxl () [Id]+listWombats id = dataFetch (ListWombats id)
+ tests/LoadCache.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+module LoadCache where++import Haxl.Core+import ExampleDataSource++#include "LoadCache.txt"
+ tests/LoadCache.txt view
@@ -0,0 +1,5 @@+loadCache :: GenHaxl u ()+loadCache = do+  cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy")))+  cacheRequest (CountAardvarks "xxx") (Right (3))+  cacheRequest (ListWombats 100) (Right ([1,2,3]))
+ tests/Main.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+module Main where++import TestExampleDataSource+import BatchTests+import CoreTests+import DataCacheTest++import Data.String+import Test.HUnit++import Haxl.Prelude++main :: IO Counts+main = runTestTT $ TestList+  [ TestLabel "ExampleDataSource" TestExampleDataSource.tests+  , TestLabel "BatchTests" BatchTests.tests+  , TestLabel "CoreTests" CoreTests.tests+  , TestLabel "DataCacheTests" DataCacheTest.tests+  ]
+ tests/MockTAO.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module MockTAO (+    Id(..),+    initGlobalState,+    assocRangeId2s,+    friendsAssoc,+  ) where++import Data.Hashable+import Data.Map (Map)+import Data.Typeable+import Prelude ()+import qualified Data.Map as Map+import qualified Data.Text as Text++import Haxl.Prelude+import Haxl.Core++import TestTypes++-- -----------------------------------------------------------------------------+-- Minimal mock TAO++data TAOReq a where+  AssocRangeId2s :: Id -> Id -> TAOReq [Id]+  deriving Typeable++deriving instance Show (TAOReq a)+deriving instance Eq (TAOReq a)++instance Show1 TAOReq where show1 = show++instance Hashable (TAOReq a) where+  hashWithSalt s (AssocRangeId2s a b) = hashWithSalt s (a,b)++instance StateKey TAOReq where+  data State TAOReq = TAOState {}++instance DataSourceName TAOReq where+  dataSourceName _ = "MockTAO"++instance DataSource UserEnv TAOReq where+  fetch _state _flags _user bfs = SyncFetch $ mapM_ doFetch bfs++initGlobalState :: IO (State TAOReq)+initGlobalState = return TAOState {}++doFetch :: BlockedFetch TAOReq -> IO ()+doFetch (BlockedFetch req@(AssocRangeId2s a b) r) =+  case Map.lookup (a, b) assocs of+    Nothing -> putFailure r . NotFound . Text.pack $ show req+    Just result -> putSuccess r result++assocs :: Map (Id,Id) [Id]+assocs = Map.fromList [+  ((friendsAssoc, 1), [5..10]),+  ((friendsAssoc, 2), [7..12]),+  ((friendsAssoc, 3), [10..15]),+  ((friendsAssoc, 4), [15..19])+ ]++friendsAssoc :: Id+friendsAssoc = 167367433327742++assocRangeId2s :: Id -> Id -> Haxl [Id]+assocRangeId2s a b = dataFetch (AssocRangeId2s a b)
+ tests/TestExampleDataSource.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+module TestExampleDataSource (tests) where++import Haxl.Prelude as Haxl+import Prelude()++import Haxl.Core.Monad (unsafeLiftIO)+import Haxl.Core++import qualified Data.HashMap.Strict as HashMap+import Test.HUnit+import Data.IORef+import Control.Exception++import ExampleDataSource+import LoadCache++testEnv = do+  -- To use a data source, we need to initialize its state:+  exstate <- ExampleDataSource.initGlobalState++  -- And create a StateStore object containing the states we need:+  let st = stateSet exstate stateEmpty++  -- Create the Env:+  initEnv st ()+++tests = TestList [+  TestLabel "exampleTest" exampleTest,+  TestLabel "orderTest" orderTest,+  TestLabel "preCacheTest" preCacheTest,+  TestLabel "cachedComputationTest" cachedComputationTest,+  TestLabel "dataSourceExceptionTest" dataSourceExceptionTest,+  TestLabel "dumpCacheAsHaskell" dumpCacheTest]++-- Let's test ExampleDataSource.++exampleTest :: Test+exampleTest = TestCase $ do+  env <- testEnv++  -- Run an example expression with two fetches:+  x <- runHaxl env $+     countAardvarks "abcabc" + (length <$> listWombats 3)++  assertEqual "runTests" x (2 + 3)++  -- Should be just one fetching round:+  Stats s <- readIORef (statsRef env)+  assertEqual "rounds" 1 (length s)++  -- With two fetches:+  let reqs = case head s of RoundStats m -> HashMap.lookup "ExampleDataSource" m+  assertEqual "reqs" (Just 2) reqs++-- Test side-effect ordering++orderTest = TestCase $ do+  env <- testEnv++  ref <- newIORef ([] :: [Int])++  let tick n = unsafeLiftIO (modifyIORef ref (n:))++  let left = do tick 1+                r <- countAardvarks "abcabc"+                tick 2+                return r++  let right = do tick 3+                 r <- length <$> listWombats 3+                 tick 4+                 return r++  x <- runHaxl env $ left + right+  assertEqual "TestExampleDataSource2" x (2 + 3)++  -- The order of the side effects is 1,3,2,4.  First we see 1, then+  -- left gets blocked, then we explore right, we see 3, then right+  -- gets blocked.  The data fetches are performed, then we see 2 and+  -- then 4.++  ys <- readIORef ref+  assertEqual "TestExampleDataSource: ordering" (reverse ys) [1,3,2,4]+++preCacheTest = TestCase $ do+  env <- testEnv++  x <- runHaxl env $ do+    cacheRequest (CountAardvarks "xxx") (Right 3)+    cacheRequest (ListWombats 100) (Right [1,2,3])+    countAardvarks "xxx" + (length <$> listWombats 100)+  assertEqual "preCacheTest1" x (3 + 3)++  y <- Control.Exception.try $ runHaxl env $ do+    cacheRequest (CountAardvarks "yyy") $ except (NotFound "yyy")+    countAardvarks "yyy"+  assertBool "preCacheTest2" $+     case y of+       Left (NotFound "yyy") -> True+       _other -> False++-- Pretend CountAardvarks is a request computed by some Haxl code+cachedComputationTest = TestCase $ do+  env <- testEnv+  let env' = env { flags = (flags env){trace = 3} }++  let x = cachedComputation (CountAardvarks "ababa") $ do+        a <- length <$> listWombats 10+        b <- length <$> listWombats 20+        return (a + b)++  r <- runHaxl env' $ x + x + countAardvarks "baba"++  assertEqual "cachedComputationTest1" 62 r++  stats <- readIORef (statsRef env)+  assertEqual "fetches" 3 (numFetches stats)++dataSourceExceptionTest = TestCase $ do+  env <- testEnv+  r <- runHaxl env $ Haxl.try $ countAardvarks "BANG"+  assertBool "exception" $+    case r of+      Left (ErrorCall "BANG") -> True+      _ -> False+  r <- runHaxl env $ Haxl.try $ countAardvarks "BANG2"+  assertBool "exception" $+    case r of+      Left (ErrorCall "BANG2") -> True+      _ -> False++-- Test that we can load the cache from a dumped copy of it, and then dump it+-- again to get the same result.+dumpCacheTest = TestCase $ do+  env <- testEnv+  runHaxl env loadCache+  str <- runHaxl env dumpCacheAsHaskell+  loadcache <- readFile "sigma/haxl/core/tests/LoadCache.txt"+  assertEqual "dumpCacheAsHaskell" str loadcache
+ tests/TestTypes.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++module TestTypes+   ( UserEnv+   , Haxl+   , lookupInput+   , Id(..)+   ) where++import Data.Aeson+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable+import Data.Typeable++import Haxl.Core++type UserEnv = Object+type Haxl a = GenHaxl UserEnv a++lookupInput :: FromJSON a => Text -> Haxl a+lookupInput field = do+  mb_val <- env (HashMap.lookup field . userEnv)+  case mb_val of+    Nothing ->+      throw (NotFound (Text.concat ["field ", field, " was not found."]))+    Just val ->+      case fromJSON val of+        Error str ->+          throw (UnexpectedType (Text.concat+            ["field ", field, ": ", Text.pack str]))+        Success a -> return a+++newtype Id = Id Int+  deriving (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable,+            ToJSON, FromJSON)++instance Show Id where+  show (Id i) = show i