packages feed

haxl 0.1.0.0 → 2.5.1.1

raw patch · 58 files changed

Files

Haxl/Core.hs view
@@ -1,24 +1,138 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ -- | 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+-- engine.+--+{-# LANGUAGE CPP #-}+module Haxl.Core (+    -- * The monad and operations+    GenHaxl (..), runHaxl, runHaxlWithWrites++    -- ** Env+  , Env(..), Caches, caches+    -- *** Operations in the monad+  , env, withEnv, withLabel+    -- *** Building the Env+  , initEnvWithData, initEnv, emptyEnv, sanitizeEnv+    -- *** Building the StateStore+  , StateStore, stateGet, stateSet, stateEmpty++    -- ** Writes inside the monad+  , tellWrite, tellWriteNoMemo++    -- ** Exceptions+  , throw, catch, catchIf, try, tryToHaxlException++    -- ** Data fetching and caching+  , dataFetch, uncachedRequest+  , cacheRequest, dupableCacheRequest, cacheResult, cacheResultWithShow+  , cachedComputation, preCacheComputation+  , dumpCacheAsHaskell++    -- ** Memoization+  , newMemo, newMemoWith, prepareMemo, runMemo+  , memo, memoUnique, memoize, memoize1, memoize2+  , memoFingerprint, MemoFingerprintKey(..)++    -- ** Conditionals+  , pAnd, pOr, unsafeChooseFirst++    -- ** Statistics+  , Stats(..)+  , FetchStats(..)+  , CallId+  , Microseconds+  , Timestamp+  , emptyStats+  , numFetches+  , ppStats+  , ppFetchStats+  , aggregateFetchBatches+  , Profile(..)+  , ProfileMemo(..)+  , ProfileFetch(..)+  , emptyProfile+  , ProfileLabel+  , ProfileKey+  , ProfileData(..)+  , emptyProfileData+  , AllocCount+  , LabelHitCount++    -- * Report flags+  , ReportFlag(..)+  , ReportFlags+  , defaultReportFlags+  , profilingReportFlags+  , setReportFlag+  , clearReportFlag+  , testReportFlag++    -- ** Flags+  , Flags(..)+  , defaultFlags+  , ifTrace+  , ifReport+  , ifProfiling++    -- * Building data sources+  , DataSource(..)+  , ShowP(..)+  , DataSourceName(..)+  , Request+  , BlockedFetch(..)+  , PerformFetch(..)+  , StateKey(..)+  , SchedulerHint(..)+  , FailureClassification(..)++    -- ** Result variables+  , ResultVar(..)+  , mkResultVar+  , putFailure+  , putResult+  , putSuccess+  , putResultFromChildThread+  , putResultWithStats+  , putResultWithStatsFromChildThread+  , DataSourceStats(..)++    -- ** Default fetch implementations+  , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease+  , backgroundFetchSeq, backgroundFetchPar+  , backgroundFetchAcquireRelease, backgroundFetchAcquireReleaseMVar+  , stubFetch+  , syncFetch++    -- ** Utilities+  , except+  , setError+  , getMapFromRCMap++    -- * Exceptions   , module Haxl.Core.Exception-  , module Haxl.Core.StateStore-  , module Haxl.Core.Show1++    -- * Recording the function callgraph+  , module Haxl.Core.CallGraph   ) where -import Haxl.Core.Env+import Haxl.Core.CallGraph+import Haxl.Core.DataSource+import Haxl.Core.Flags+import Haxl.Core.Memo import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -})-import Haxl.Core.Types+import Haxl.Core.Fetch+import Haxl.Core.Parallel+import Haxl.Core.Profile+import Haxl.Core.Run+import Haxl.Core.Stats import Haxl.Core.Exception-import Haxl.Core.Show1 (Show1(..))+import Haxl.Core.RequestStore (getMapFromRCMap)+import Haxl.Core.ShowP (ShowP(..)) import Haxl.Core.StateStore
+ Haxl/Core/CallGraph.hs view
@@ -0,0 +1,45 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Haxl.Core.CallGraph where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif+import Data.Text (Text)+import qualified Data.Text as Text++type ModuleName = Text++-- | An unqualified function+type Function = Text++-- | A qualified function+data QualFunction = QualFunction ModuleName Function deriving (Eq, Ord)++instance Show QualFunction where+  show (QualFunction mn nm) = Text.unpack $ mn <> Text.pack "." <> nm++-- | Represents an edge between a parent function which calls a child function+-- in the call graph+type FunctionCall = (QualFunction, QualFunction)++-- | An edge list which represents the dependencies between function calls+type CallGraph = ([FunctionCall], Map QualFunction Text)++-- | Used as the root of all function calls+mainFunction :: QualFunction+mainFunction = QualFunction "MAIN" "main"++emptyCallGraph :: CallGraph+emptyCallGraph = ([], Map.empty)
Haxl/Core/DataCache.hs view
@@ -1,113 +1,214 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} --- | A cache mapping data requests to their results.+-- |+-- A cache mapping data requests to their results.  This module is+-- provided for access to Haxl internals only; most users should not+-- need to import it.+-- module Haxl.Core.DataCache-  ( DataCache-  , empty+  ( DataCache(..)+  , SubCache(..)+  , emptyDataCache+  , filter   , insert+  , insertNotShowable+  , insertWithShow   , lookup   , showCache+  , readCache   ) 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 Prelude hiding (lookup, filter) import Control.Exception+import Unsafe.Coerce+import Data.Typeable+import Data.Hashable+import qualified Data.HashTable.IO as H -import Haxl.Core.Types+-- ---------------------------------------------------------------------------+-- DataCache --- | 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.+-- | A @'DataCache' res@ maps things of type @req a@ to @res a@, for+-- any @req@ and @a@ provided @req a@ is an instance of 'Typeable'. In+-- practice @req a@ will be a request type parameterised by its result. ----- See the definition of 'ResultVar' for more details.--newtype DataCache = DataCache (HashMap TypeRep SubCache)+newtype DataCache res = DataCache (HashTable TypeRep (SubCache res))  -- | 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))+--+data SubCache res =+  forall req a . (Hashable (req a), Eq (req a)) =>+       SubCache (req a -> String) (a -> String) !(HashTable (req a) (res a))        -- NB. the inner HashMap is strict, to avoid building up        -- a chain of thunks during repeated insertions. +type HashTable k v = H.BasicHashTable k v+ -- | A new, empty 'DataCache'.-empty :: DataCache-empty = DataCache HashMap.empty+emptyDataCache :: IO (DataCache res)+emptyDataCache = DataCache <$> H.new  -- | 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+  :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a)+  => req a   -- ^ Request-  -> ResultVar a+  -> res a   -- ^ Result-  -> DataCache-  -> DataCache+  -> DataCache res+  -> IO () -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)+insert = insertWithShow show show +-- | Inserts a request-result pair into the 'DataCache', without+-- requiring Show instances of the request or the result.  The cache+-- cannot be subsequently used with `showCache`.+insertNotShowable+  :: (Hashable (req a), Typeable (req a), Eq (req a))+  => req a+  -- ^ Request+  -> res a+  -- ^ Result+  -> DataCache res+  -> IO ()++insertNotShowable = insertWithShow notShowable notShowable++-- | Inserts a request-result pair into the 'DataCache', with the given+-- functions used to show the request and result.+insertWithShow+  :: (Hashable (req a), Typeable (req a), Eq (req a))+  => (req a -> String)+  -- ^ Show function for request+  -> (a -> String)+  -- ^ Show function for result+  -> req a+  -- ^ Request+  -> res a+  -- ^ Result+  -> DataCache res+  -> IO ()++insertWithShow showRequest showResult request result (DataCache m) =+  H.mutateIO m (typeOf request) (mutate showRequest showResult request result)++notShowable :: a+notShowable = error "insertNotShowable"++-- | A mutation function for mutateIO. If the key doesn't exist in the top-level+-- cache, creates a new hashtable and inserts the request and result.+-- If the key exists, insert the request and result into the existing subcache,+-- replacing any existing mapping.+mutate :: (Hashable (req a), Typeable (req a), Eq (req a))+  => (req a -> String)+  -> (a -> String)+  -> req a+  -> res a+  -> Maybe (SubCache res)+  -> IO (Maybe (SubCache res), ())+mutate showRequest showResult request result Nothing = do+  newTable <- H.new+  H.insert newTable request result+  return (Just (SubCache showRequest showResult newTable), ())+mutate _ _ request result (Just sc@(SubCache _ _ oldTable)) = do+    H.insert oldTable (unsafeCoerce request) (unsafeCoerce result)+    return (Just sc, ())+ -- | Looks up the cached result of a request. lookup-  :: Typeable (r a)-  => r a+  :: Typeable (req a)+  => req a   -- ^ Request-  -> DataCache-  -> Maybe (ResultVar a)+  -> DataCache res+  -> IO (Maybe (res a)) -lookup req (DataCache m) =-      case HashMap.lookup (typeOf req) m of-        Nothing -> Nothing-        Just (SubCache sc) ->-           unsafeCoerce (HashMap.lookup (unsafeCoerce req) sc)+lookup req (DataCache m) = do+  mbRes <- H.lookup m (typeOf req)+  case mbRes of+    Nothing -> return Nothing+    Just (SubCache _ _ sc) ->+      unsafeCoerce (H.lookup sc (unsafeCoerce req)) +filter+  :: forall res+  . (forall a. res a -> IO Bool)+  -> DataCache res+  -> IO (DataCache res)+filter pred (DataCache cache) = do+  cacheList <- H.toList cache+  filteredCache <- filterSubCache `mapM` cacheList+  DataCache <$> H.fromList filteredCache+  where+    filterSubCache+      :: (TypeRep, SubCache res)+      -> IO (TypeRep, SubCache res)+    filterSubCache (ty, SubCache showReq showRes hm) = do+      filteredList <- H.foldM go [] hm+      filteredSC <- H.fromList filteredList+      return (ty, SubCache showReq showRes filteredSC)+      where+        go res (request, rvar) = do+          predRes <- pred rvar+          return $ if predRes then (request, rvar):res else res+ -- | Dumps the contents of the cache, with requests and responses--- converted to 'String's using 'show'.  The entries are grouped by--- 'TypeRep'.---+-- converted to 'String's using the supplied show functions.  The+-- entries are grouped by 'TypeRep'.  Note that this will fail if+-- 'insertNotShowable' has been used to insert any entries. showCache-  :: DataCache+  :: forall res+  .  DataCache res+  -> (forall a . res a -> IO (Maybe (Either SomeException a)))   -> 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)+showCache (DataCache cache) readRes = H.foldM goSubCache [] cache+  where+    goSubCache+      :: [(TypeRep, [(String, Either SomeException String)])]+      -> (TypeRep, SubCache res)+      -> IO [(TypeRep, [(String, Either SomeException String)])]+    goSubCache res (ty, SubCache showReq showRes hm) = do+      subCacheResult <- H.foldM go [] hm+      return $ (ty, subCacheResult):res+      where+        go res (request, rvar) = do+          maybe_r <- readRes rvar+          return $ case maybe_r of+            Nothing -> res+            Just (Left e) -> (showReq request, Left e) : res+            Just (Right result) ->+              (showReq request, Right (showRes result)) : res -  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)))+-- | Dumps the contents of the cache responses to list+readCache+  :: forall res ret+  .  DataCache res+  -> (forall a . res a -> IO ret)+  -> IO [(TypeRep, [Either SomeException ret])]+readCache (DataCache cache) readRes = H.foldM goSubCache [] cache+  where+    goSubCache+      :: [(TypeRep, [Either SomeException ret])]+      -> (TypeRep, SubCache res)+      -> IO [(TypeRep, [Either SomeException ret])]+    goSubCache res (ty, SubCache _showReq _showRes hm) = do+      subCacheResult <- H.foldM go [] hm+      return $ (ty, subCacheResult):res+      where+        go res (_request, rvar) = do+          r <- try $ readRes rvar+          return $ r : res
+ Haxl/Core/DataSource.hs view
@@ -0,0 +1,565 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- The 'DataSource' class and related types and functions.  This+-- module is provided for access to Haxl internals only; most users+-- should import "Haxl.Core" instead.+--+module Haxl.Core.DataSource+  (+  -- * Data fetching+    DataSource(..)+  , DataSourceName(..)+  , Request+  , BlockedFetch(..)+  , PerformFetch(..)+  , SchedulerHint(..)+  , FailureClassification(..)++  -- * Result variables+  , ResultVar(..)+  , mkResultVar+  , putFailure+  , putResult+  , putResultFromChildThread+  , putSuccess+  , putResultWithStats+  , putResultWithStatsFromChildThread++  -- * Default fetch implementations+  , asyncFetch, asyncFetchWithDispatch+  , asyncFetchAcquireRelease+  , backgroundFetchSeq, backgroundFetchPar+  , backgroundFetchAcquireRelease+  , backgroundFetchAcquireReleaseMVar+  , stubFetch+  , syncFetch++  -- * Utilities+  , except+  , setError+  ) where++import Control.Exception+import Control.Monad+import Data.Hashable+import Data.Text (Text)+import Data.Kind (Type)+import Data.Typeable++import Haxl.Core.Exception+import Haxl.Core.Flags+import Haxl.Core.ShowP+import Haxl.Core.StateStore+import Haxl.Core.Stats+++import GHC.Conc ( newStablePtrPrimMVar+                , PrimMVar)+import Control.Concurrent ( threadCapability+                          , forkOn+                          , myThreadId )+import Control.Concurrent.MVar+import Foreign.StablePtr++-- ---------------------------------------------------------------------------+-- DataSource class++-- | 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://github.com/facebook/Haxl/tree/master/example Examples>.+--+class (DataSourceName req, StateKey req, ShowP req) => DataSource u req where++  -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch'+  -- objects contain both the request and the 'ResultVar's into which to put+  -- the results.+  fetch+    :: State req+      -- ^ Current state.+    -> Flags+      -- ^ Tracing flags.+    -> u+      -- ^ User environment.+    -> PerformFetch req+      -- ^ Fetch the data; see 'PerformFetch'.++  schedulerHint :: u -> SchedulerHint req+  schedulerHint _ = TryToBatch++  schedulerHintState :: Maybe (State req) -> u -> SchedulerHint req+  schedulerHintState _ u = schedulerHint u++  classifyFailure :: u -> req a -> SomeException -> FailureClassification+  classifyFailure _ _ _ = StandardFailure++class DataSourceName (req :: Type -> Type) where+  -- | The name of this 'DataSource', used in tracing and stats. Must+  -- take a dummy request.+  dataSourceName :: Proxy req -> Text++-- The 'ShowP' 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). 'ShowP' 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+  )++-- | Hints to the scheduler about this data source+data SchedulerHint (req :: Type -> Type)+  = TryToBatch+    -- ^ Hold data-source requests while we execute as much as we can, so+    -- that we can hopefully collect more requests to batch.+  | SubmitImmediately+    -- ^ Submit a request via fetch as soon as we have one, don't try to+    -- batch multiple requests.  This is really only useful if the data source+    -- returns BackgroundFetch, otherwise requests to this data source will+    -- be performed synchronously, one at a time.++-- | Hints to the stats module about how to deal with these failures+data FailureClassification+  = StandardFailure+  | IgnoredForStatsFailure++-- | A data source can fetch data in one of four ways.+--+data PerformFetch req+  = SyncFetch  ([BlockedFetch req] -> IO ())+    -- ^ Fully synchronous, returns only when all the data is fetched.+    -- See 'syncFetch' for an example.+  | AsyncFetch ([BlockedFetch req] -> IO () -> IO ())+    -- ^ Asynchronous; performs an arbitrary IO action while the data+    -- is being fetched, but only returns when all the data is+    -- fetched.  See 'asyncFetch' for an example.+  | BackgroundFetch ([BlockedFetch req] -> IO ())+    -- ^ Fetches the data in the background, calling 'putResult' at+    -- any time in the future.  This is the best kind of fetch,+    -- because it provides the most concurrency.+++-- | A 'BlockedFetch' is a pair of+--+--   * The request to fetch (with result type @a@)+--+--   * A 'ResultVar' 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 'ResultVar'+-- out, the type system knows that the result type of the request+-- matches the type parameter of the 'ResultVar', so it will let us take the+-- result of the request and store it in the 'ResultVar'.+--+data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a)+++-- -----------------------------------------------------------------------------+-- ResultVar++-- | A sink for the result of a data fetch in 'BlockedFetch'+newtype ResultVar a =+  ResultVar (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())+  -- The Bool here is True if result was returned by a child thread,+  -- rather than the main runHaxl thread.  see Note [tracking allocation in+  -- child threads]++mkResultVar+  :: (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())+  -> ResultVar a+mkResultVar = ResultVar++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 io) res = io res False Nothing++putResultWithStats+  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()+putResultWithStats (ResultVar io) res st = io res False (Just st)++putResultWithStatsFromChildThread+  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()+putResultWithStatsFromChildThread (ResultVar io) res st = io res True (Just st)++-- | Like `putResult`, but used to get correct accounting when work is+-- being done in child threads.  This is particularly important for+-- data sources that are using 'BackgroundFetch', The allocation performed+-- in the child thread up to this point will be propagated back to the+-- thread that called 'runHaxl'.+--+-- Note: if you're doing multiple 'putResult' calls in the same thread+-- ensure that only the /last/ one is 'putResultFromChildThread'.  If you+-- make multiple 'putResultFromChildThread' calls, the allocation will be+-- counted multiple times.+--+-- If you are reusing a thread for multiple fetches, you should call+-- @System.Mem.setAllocationCounter 0@ after+-- 'putResultFromChildThread', so that allocation is not counted+-- multiple times.+putResultFromChildThread :: ResultVar a -> Either SomeException a -> IO ()+putResultFromChildThread (ResultVar io) res =  io res True Nothing+  -- see Note [tracking allocation in child threads]++-- | 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+++-- -----------------------------------------------------------------------------+-- Fetch templates++stubFetch+  :: (Exception e) => (forall a. r a -> e)+  -> State r -> Flags -> u -> PerformFetch r+stubFetch e _state _flags _si = SyncFetch $ mapM_ (setError e)++-- | 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.++  -> PerformFetch request++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.++  -> PerformFetch request++asyncFetchWithDispatch+  withService dispatch wait enqueue _state _flags _si =+  AsyncFetch $ \requests inner -> withService $ \service -> do+    getResults <- mapM (submitFetch service enqueue) requests+    dispatch service+    inner+    wait service+    sequence_ getResults++asyncFetch withService wait enqueue _state _flags _si =+  AsyncFetch $ \requests inner -> withService $ \service -> do+    getResults <- mapM (submitFetch service enqueue) requests+    inner+    wait service+    sequence_ getResults++syncFetch withService dispatch enqueue _state _flags _si =+  SyncFetch $ \requests -> withService $ \service -> do+  getResults <- mapM (submitFetch service enqueue) requests+  dispatch service+  sequence_ getResults++backgroundFetchSeq, backgroundFetchPar+  :: (forall a. request a -> IO (Either SomeException a))+  -- ^ Run one request, will be run in a background thread++  -> State request+  -- ^ Currently unused.++  -> Flags+  -- ^ Currently unused.++  -> u+  -- ^ Currently unused.++  -> PerformFetch request++backgroundFetchSeq run _state _flags _si =+  BackgroundFetch $ \requests -> do+    (cap, _) <- threadCapability =<< myThreadId+    mask $ \restore -> void $ forkOn cap $ do+      let rethrow = rethrowFromBg requests+      restore (mapM_ runOne requests) `catch` rethrow+      where+        runOne (BlockedFetch request result) = do+          res <- run request+          putResultFromBg result res++backgroundFetchPar run _state _flags _si =+  BackgroundFetch $ \requests -> do+    (cap, _) <- threadCapability =<< myThreadId+    mapM_ (runOneInThread cap) requests+  where+    runOneInThread cap request = do+      mask $ \restore -> void $ forkOn cap $ do+        let rethrow = rethrowFromBg [request]+        restore (runOne request) `catch` rethrow+    runOne (BlockedFetch request result) = do+      res <- run request+      putResultFromBg result res+++{- |+A version of 'asyncFetch' (actually 'asyncFetchWithDispatch') that+handles exceptions correctly.  You should use this instead of+'asyncFetch' or 'asyncFetchWithDispatch'.  The danger with+'asyncFetch' is that if an exception is thrown by @withService@, the+@inner@ action won't be executed, and we'll drop some data-fetches in+the same round.++'asyncFetchAcquireRelease' behaves like the following:++> asyncFetchAcquireRelease acquire release dispatch wait enqueue =+>   AsyncFetch $ \requests inner ->+>     bracket acquire release $ \service -> do+>       getResults <- mapM (submitFetch service enqueue) requests+>       dispatch service+>       inner+>       wait service+>       sequence_ getResults++except that @inner@ is run even if @acquire@, @enqueue@, or @dispatch@ throws,+/unless/ an async exception is received.+-}++asyncFetchAcquireRelease+  :: IO service+  -- ^ Resource acquisition for this datasource++  -> (service -> IO ())+  -- ^ Resource release++  -> (service -> IO ())+  -- ^ Dispatch all the pending requests and wait for the results++  -> (service -> IO ())+  -- ^ 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.++  -> PerformFetch request++asyncFetchAcquireRelease+  acquire release dispatch wait enqueue _state _flags _si =+  AsyncFetch $ \requests inner -> mask $ \restore -> do+    r1 <- tryWithRethrow acquire+    case r1 of+      Left err -> do restore inner; throwIO (err :: SomeException)+      Right service -> do+        flip finally (release service) $ restore $ do+          r2 <- tryWithRethrow $ do+            getResults <- mapM (submitFetch service enqueue) requests+            dispatch service+            return getResults+          inner  --  we assume this cannot throw, ensured by performFetches+          case r2 of+            Left err -> throwIO (err :: SomeException)+            Right getResults -> do wait 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 fetchFn (BlockedFetch request result)+  = (putResult result =<<) <$> fetchFn service request++putResultFromBg :: ResultVar a -> Either SomeException a -> IO ()+putResultFromBg result r = do+  -- See comment on putResultFromChildThread+  -- We must set the allocation counter to 0 here in case there are more+  -- results in the batch.+  -- This is safe as we own this thread, and know that there+  -- is no allocation limits set.+  putResultFromChildThread result r+  setAllocationCounter 0++rethrowFromBg :: [BlockedFetch req] -> SomeException -> IO ()+rethrowFromBg requests e = do+  mapM_ (rethrow1bg e) requests+  rethrowAsyncExceptions e+  where+    rethrow1bg e (BlockedFetch _ result) =+      putResultFromBg result (Left e)+++backgroundFetchAcquireReleaseMVar+  :: IO service+  -- ^ Resource acquisition for this datasource++  -> (service -> IO ())+  -- ^ Resource release++  -> (service -> Int -> MVar () -> IO ())+  -- ^ Dispatch all the pending requests and when ready trigger the given mvar++  -> (service -> IO ())+  -- ^ Process all requests++  -> (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.++  -> PerformFetch request++backgroundFetchAcquireReleaseMVar+  acquire release dispatch process enqueue _state _flags _si =+  BackgroundFetch $ \requests -> do+    mvar <- newEmptyMVar+    mask $ \restore -> do+      (cap, _) <- threadCapability =<< myThreadId+      service <- acquire+      getResults <- (do+        results <- restore $ mapM (submit service) requests+        -- dispatch takes ownership of mvar, so we call it under `mask` to+        -- ensure that it can safely manage that resource.+        dispatch service cap mvar+        return (sequence_ results)) `onException` release service+      -- now spawn off a background thread to wait on the dispatch to finish+      _tid <- forkOn cap $ do+        takeMVar mvar+          -- todo: it is possible that we would want to do+          -- this processResults on the main scheduler thread for performance+          -- which might reduce thread switching, especially for large batches+          -- but for now this seems to work just fine+        let rethrow = rethrowFromBg requests+        _ <- finally+          (restore (process service >> getResults) `catch` rethrow)+          (release service `catch` rethrow)+        return ()+      return ()+  where+    submit service (BlockedFetch request result) =+      (putResultFromBg result =<<) <$> enqueue service request+++{- |+A version of 'backgroundFetchAcquireReleaseMVar' where the dispatch function+is given a 'StablePtr PrimMVar' which is more useful for C based APIs.+-}++backgroundFetchAcquireRelease+  :: IO service+  -- ^ Resource acquisition for this datasource++  -> (service -> IO ())+  -- ^ Resource release++  -> (service -> Int -> StablePtr PrimMVar -> IO ())+  -- ^ Dispatch all the pending requests and when ready trigger the given mvar++  -> (service -> IO ())+  -- ^ Process all requests++  -> (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.++  -> PerformFetch request++backgroundFetchAcquireRelease+  a r dispatch = backgroundFetchAcquireReleaseMVar+                 a+                 r+                 (\s c mvar -> do+                     sp <- newStablePtrPrimMVar mvar+                     dispatch s c sp)
− Haxl/Core/Env.hs 
@@ -1,65 +0,0 @@--- 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
@@ -1,10 +1,13 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -24,7 +27,10 @@ -- 'withDefault' to be useful, for example, you'll want your -- exceptions to be children of 'LogicError' or 'TransientError' as -- appropriate.-+--+-- Most users should import "Haxl.Core" instead of importing this+-- module directly.+-- module Haxl.Core.Exception (    HaxlException(..),@@ -38,6 +44,10 @@   logicErrorToException,   logicErrorFromException, +  LogicBug(..),+  logicBugToException,+  logicBugFromException,+   TransientError(..),   transientErrorToException,   transientErrorFromException,@@ -45,6 +55,7 @@   -- ** Internal exceptions   CriticalError(..),   DataSourceError(..),+  NonHaxlException(..),    -- ** Logic exceptions   NotFound(..),@@ -52,21 +63,30 @@   EmptyList(..),   JSONError(..),   InvalidParameter(..),+  MonadFail(..),    -- ** Transient exceptions   FetchError(..),    -- * Exception utilities   asHaxlException,-+  MiddleException(..),+  rethrowAsyncExceptions,+  tryWithRethrow,   ) where -import Control.Exception+#if __GLASGOW_HASKELL__ >= 808+import Prelude hiding (MonadFail)+#endif+import Control.Exception as Exception import Data.Aeson+import Data.Binary (Binary) import Data.Typeable import Data.Text (Text)+import qualified Data.Text as Text  import Haxl.Core.Util+import GHC.Stack  -- | We have a 3-tiered hierarchy of exceptions, with 'HaxlException' at -- the top, and all Haxl exceptions as children of this. Users should@@ -76,8 +96,11 @@ -- --   ['InternalError']  Something is wrong with Haxl core. -----   ['LogicError']     Something is wrong with Haxl client code.+--   ['LogicBug']       Something is wrong with Haxl client code. --+--   ['LogicError']     Things that really should be return values, e.g.+--                      NotFound.+-- --   ['TransientError'] Something is temporarily failing (usually in a fetch). -- -- These are not meant to be thrown (but likely be caught). Thrown@@ -86,30 +109,43 @@ -- (generic transient failure) or 'CriticalError' (internal failure). -- data HaxlException-  = forall e. (Exception e, MiddleException e) => HaxlException e+  = forall e. (MiddleException e)+    => HaxlException+         (Maybe Stack)  -- filled in with the call stack when thrown,+                        -- if PROFILING is on+         e   deriving (Typeable) +type Stack = [Text]+  -- hopefully this will get more informative in the future+ instance Show HaxlException where-  show (HaxlException e) = show e+  show (HaxlException (Just stk@(_:_)) e) =+    show e ++ '\n' : renderStack (reverse $ map Text.unpack stk)+  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-    ]+  toJSON (HaxlException stk e) = object fields+    where+      fields | Just s@(_:_) <- stk = ("stack" .= s) : rest+             | otherwise = rest+      rest =+        [ "type" .= show (typeOf e)+        , "name" .= eName e+        , "txt"  .= show e+        ]  haxlExceptionToException-  :: (Exception e, MiddleException e) => e -> SomeException-haxlExceptionToException = toException . HaxlException+  :: (MiddleException e) => e -> SomeException+haxlExceptionToException = toException . HaxlException Nothing  haxlExceptionFromException-  :: (Exception e, MiddleException e) => SomeException -> Maybe e+  :: (MiddleException e) => SomeException -> Maybe e haxlExceptionFromException x = do-  HaxlException a <- fromException x+  HaxlException _ a <- fromException x   cast a  class (Exception a) => MiddleException a where@@ -181,61 +217,103 @@   LogicError a <- fromException x   cast a +data LogicBug = forall e . (Exception e) => LogicBug e+  deriving (Typeable)++deriving instance Show LogicBug++instance Exception LogicBug where+ toException   = haxlExceptionToException+ fromException = haxlExceptionFromException++instance MiddleException LogicBug where+  eName (LogicBug e) = show $ typeOf e++logicBugToException :: (Exception e) => e -> SomeException+logicBugToException = toException . LogicBug++logicBugFromException+  :: (Exception e) => SomeException -> Maybe e+logicBugFromException x = do+  LogicBug 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)+newtype CriticalError = CriticalError Text+  deriving (Typeable, Binary, Eq, Show)  instance Exception CriticalError where   toException   = internalErrorToException   fromException = internalErrorFromException +-- | Exceptions that are converted to HaxlException by+-- asHaxlException.  Typically these will be pure exceptions,+-- e.g., the 'error' function in pure code, or a pattern-match+-- failure.+newtype NonHaxlException = NonHaxlException Text+  deriving (Typeable, Binary, Eq, Show)++instance Exception NonHaxlException where+  toException   = internalErrorToException+  fromException = internalErrorFromException+ -- | Generic \"something was not found\" exception.-data NotFound = NotFound Text-  deriving (Typeable, Show)+newtype NotFound = NotFound Text+  deriving (Typeable, Binary, Eq, Show)  instance Exception NotFound where   toException = logicErrorToException   fromException = logicErrorFromException  -- | Generic \"something had the wrong type\" exception.-data UnexpectedType = UnexpectedType Text-  deriving (Typeable, Show)+newtype UnexpectedType = UnexpectedType Text+  deriving (Typeable, Eq, Show)  instance Exception UnexpectedType where   toException = logicErrorToException   fromException = logicErrorFromException  -- | Generic \"input list was empty\" exception.-data EmptyList = EmptyList Text-  deriving (Typeable,Show)+newtype EmptyList = EmptyList Text+  deriving (Typeable, Eq, Show)  instance Exception EmptyList where   toException = logicErrorToException   fromException = logicErrorFromException+  -- TODO: should be a child of LogicBug  -- | Generic \"Incorrect assumptions about JSON data\" exception.-data JSONError = JSONError Text-  deriving (Typeable, Show)+newtype JSONError = JSONError Text+  deriving (Typeable, Eq, Show)  instance Exception JSONError where   toException = logicErrorToException   fromException = logicErrorFromException  -- | Generic \"passing some invalid parameter\" exception.-data InvalidParameter = InvalidParameter Text-  deriving (Typeable, Show)+newtype InvalidParameter = InvalidParameter Text+  deriving (Typeable, Eq, Show)  instance Exception InvalidParameter where   toException = logicErrorToException   fromException = logicErrorFromException+  -- TODO: should be a child of LogicBug +-- | Generic \"fail was called\" exception.+newtype MonadFail = MonadFail Text+  deriving (Typeable, Eq, Show)++instance Exception MonadFail where+  toException = logicErrorToException+  fromException = logicErrorFromException+ -- | Generic transient fetching exceptions.-data FetchError = FetchError Text+newtype FetchError = FetchError Text   deriving (Typeable, Eq, Show)  instance Exception FetchError where@@ -243,7 +321,7 @@   fromException = transientErrorFromException  -- | A data source did something wrong-data DataSourceError = DataSourceError Text+newtype DataSourceError = DataSourceError Text   deriving (Typeable, Eq, Show)  instance Exception DataSourceError where@@ -251,10 +329,45 @@   fromException = internalErrorFromException  -- | Converts all exceptions that are not derived from 'HaxlException'--- into 'CriticalError', using 'show'.+-- into 'NonHaxlException', using 'show'. asHaxlException :: SomeException -> HaxlException asHaxlException e   | Just haxl_exception <- fromException e = -- it's a HaxlException      haxl_exception   | otherwise =-     HaxlException (InternalError (CriticalError (textShow e)))+     HaxlException Nothing (InternalError (NonHaxlException (textShow e)))++-- We must be careful about turning IO monad exceptions into Haxl+-- exceptions.  An IO monad exception will normally propagate right+-- out of runHaxl and terminate the whole computation, whereas a Haxl+-- exception can get dropped on the floor, if it is on the right of+-- <*> and the left side also throws, for example.  So turning an IO+-- monad exception into a Haxl exception is a dangerous thing to do.+-- In particular, we never want to do it for an asynchronous exception+-- (AllocationLimitExceeded, ThreadKilled, etc.), because these are+-- supposed to unconditionally terminate the computation.+--+-- There are three places where we take an arbitrary IO monad exception and+-- turn it into a Haxl exception:+--+--  * wrapFetchInCatch.  Here we want to propagate a failure of the+--    data source to the callers of the data source, but if the+--    failure came from elsewhere (an asynchronous exception), then we+--    should just propagate it+--+--  * cacheResult (cache the results of IO operations): again,+--    failures of the IO operation should be visible to the caller as+--    a Haxl exception, but we exclude asynchronous exceptions from+--    this.++--  * unsafeToHaxlException: assume the caller knows what they're+--    doing, and just wrap all exceptions.+--+rethrowAsyncExceptions :: SomeException -> IO ()+rethrowAsyncExceptions e+  | Just SomeAsyncException{} <- fromException e = Exception.throw e+  | otherwise = return ()++tryWithRethrow :: IO a -> IO (Either SomeException a)+tryWithRethrow io =+  (Right <$> io) `catch` \e -> do rethrowAsyncExceptions e ; return (Left e)
Haxl/Core/Fetch.hs view
@@ -1,172 +1,756 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-} --- | Generic fetching infrastructure, used by 'Haxl.Core.Monad'.+-- | Implementation of data-fetching operations.  Most users should+-- import "Haxl.Core" instead.+-- module Haxl.Core.Fetch-  ( CacheResult(..)-  , cached-  , memoized+  ( dataFetch+  , dataFetchWithShow+  , dataFetchWithInsert+  , uncachedRequest+  , cacheResult+  , dupableCacheRequest+  , cacheResultWithShow+  , cacheRequest   , performFetches+  , performRequestStore+  , ShowReq   ) where +import Control.Concurrent.STM+import Control.Exception as Exception+import Control.Monad+import Data.Either+import Data.Hashable+import Data.IORef+import Data.Int+import Data.List+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif+import Data.Proxy+import Data.Typeable+import Data.Text (Text)+import Data.Kind (Type)+import qualified Data.Text as Text+import Text.Printf+#ifdef PROFILING+import GHC.Stack+#endif++import Haxl.Core.DataSource import Haxl.Core.DataCache as DataCache-import Haxl.Core.Env import Haxl.Core.Exception+import Haxl.Core.Flags+import Haxl.Core.Monad+import Haxl.Core.Profile import Haxl.Core.RequestStore-import Haxl.Core.Show1+import Haxl.Core.ShowP+import Haxl.Core.Stats 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+-- -----------------------------------------------------------------------------+-- Data fetching and caching --- | 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+-- | Possible responses when checking the cache.+data CacheResult u w a+  -- | The request hadn't been seen until now.+  = Uncached+       (ResultVar a)+       {-# UNPACK #-} !(IVar u w a)+       {-# UNPACK #-} !CallId -  t0 <- getCurrentTime+  -- | The request has been seen before, but its result has not yet been+  -- fetched.+  | CachedNotFetched+      {-# UNPACK #-} !(IVar u w a)+       {-# UNPACK #-} !CallId +  -- | The request has been seen before, and its result has already been+  -- fetched.+  | Cached (ResultVal a w)+           {-# UNPACK #-} !CallId+++-- | Show functions for request and its result.+type ShowReq r a = (r a -> String, a -> String)++-- Note [showFn]+--+-- Occasionally, for tracing purposes or generating exceptions, we need to+-- call 'show' on the request in a place where we *cannot* have a Show+-- dictionary. (Because the function is a worker which is called by one of+-- the *WithShow variants that take explicit show functions via a ShowReq+-- argument.) None of the functions that does this is exported, so this is+-- hidden from the Haxl user.++cachedWithInsert+  :: forall r a u w.+     (DataSource u r, Typeable (r a))+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> DataCacheItem u w a -> DataCache (DataCacheItem u w) -> IO ())+  -> Env u w -> r a -> IO (CacheResult u w a)+cachedWithInsert showFn insertFn env@Env{..} req = do   let-    roundstats =-      [ (dataSourceName (getReq reqs), length reqs)-      | BlockedFetches reqs <- jobs ]-      where-      getReq :: [BlockedFetch r] -> r a-      getReq = undefined+    doFetch = do+      ivar <- newIVar+      k <- nextCallId env+      let !rvar = stdResultVar env ivar (Proxy :: Proxy r)+      insertFn req (DataCacheItem ivar k) dataCache+      return (Uncached rvar ivar k)+  mbRes <- DataCache.lookup req dataCache+  case mbRes of+    Nothing -> doFetch+    Just (DataCacheItem i@IVar{ivarRef = cr} k) -> do+      e <- readIORef cr+      case e of+        IVarEmpty _ -> do+          ivar <- withCurrentCCS i+          return (CachedNotFetched ivar k)+        IVarFull r -> do+          ifTrace flags 3 $ putStrLn $ case r of+            ThrowIO{} -> "Cached error: " ++ showFn req+            ThrowHaxl{} -> "Cached error: " ++ showFn req+            Ok{} -> "Cached request: " ++ showFn req+          return (Cached r k) -  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+-- | Make a ResultVar with the standard function for sending a CompletionReq+-- to the scheduler. This is the function will be executed when the fetch+-- completes.+stdResultVar+  :: forall r a u w. (DataSourceName r, Typeable r)+  => Env u w+  -> IVar u w a+  -> Proxy r+  -> ResultVar a+stdResultVar Env{..} ivar p =+  mkResultVar $ \r isChildThread _ -> do+    allocs <- if isChildThread+      then+        -- In a child thread, return the current allocation counter too,+        -- for correct tracking of allocation.+        getAllocationCounter+      else+        return 0+    atomicallyOnBlocking+      (LogicBug (ReadingCompletionsFailedFetch (dataSourceName p))) $ do+      cs <- readTVar completions+      writeTVar completions (CompleteReq (eitherToResult r) ivar allocs : cs)+    -- Decrement the counter as request has finished. Do this after updating the+    -- completions TVar so that if the scheduler is tracking what was being+    -- waited on it gets a consistent view.+    ifReport flags ReportOutgoneFetches $+      atomicModifyIORef' submittedReqsRef (\m -> (subFromCountMap p 1 m, ()))+{-# INLINE stdResultVar #-} ++-- | Record the call stack for a data fetch in the Stats.  Only useful+-- when profiling.+logFetch :: Env u w -> (r a -> String) -> r a -> CallId -> IO ()+#ifdef PROFILING+logFetch env showFn req fid = do+  ifReport (flags env) ReportFetchStack $ do+    stack <- currentCallStack+    modifyIORef' (statsRef env) $ \(Stats s) ->+      Stats (FetchCall (showFn req) stack fid : s)+#else+logFetch _ _ _ _ = return ()+#endif++calcFailure+  :: forall u req a . DataSource u req+  => u+  -> req a+  -> Either SomeException a+  -> FailureCount+calcFailure _u _r Right{} = mempty+calcFailure u r (Left e) = case classifyFailure u r e of+  StandardFailure -> mempty { failureCountStandard = 1 }+  IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }++addFallbackFetchStats+  :: forall u w req a . DataSource u req+  => Env u w+  -> CallId+  -> req a+  -> ResultVal a w+  -> IO ()+addFallbackFetchStats Env{..} fid req res = do+  bid <- atomicModifyIORef' statsBatchIdRef $ \x -> (x+1,x+1)+  start <- getTimestamp+  let+    dsName = dataSourceName (Proxy :: Proxy req)+    FailureCount{..} = case res of+      Ok{} -> mempty+      (ThrowHaxl e _) -> calcFailure userEnv req (Left e)+      (ThrowIO e) -> calcFailure userEnv req (Left e)+    this = FetchStats { fetchDataSource = dsName+                      , fetchBatchSize = 1+                      , fetchStart = start+                      , fetchDuration = 0+                      , fetchSpace = 0+                      , fetchFailures = failureCountStandard+                      , fetchIgnoredFailures = failureCountIgnored+                      , fetchBatchId = bid+                      , fetchIds = [fid] }+  atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ())++addFallbackResult+  :: Env u w+  -> ResultVal a w+  -> IVar u w a+  -> IO ()+addFallbackResult Env{..} res ivar = do+  atomicallyOnBlocking+    (LogicBug (ReadingCompletionsFailedFetch "addFallbackResult")) $ do+    cs <- readTVar completions+    writeTVar completions (CompleteReq res ivar 0 : cs)++-- | Performs actual fetching of data for a 'Request' from a 'DataSource'.+dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a+dataFetch = dataFetchWithInsert show DataCache.insert++-- | Performs actual fetching of data for a 'Request' from a 'DataSource', using+-- the given show functions for requests and their results.+dataFetchWithShow+  :: (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))+  => ShowReq r a+  -> r a -> GenHaxl u w a+dataFetchWithShow (showReq, showRes) = dataFetchWithInsert showReq+  (DataCache.insertWithShow showReq showRes)++-- | Performs actual fetching of data for a 'Request' from a 'DataSource', using+-- the given function to insert requests in the cache.+dataFetchWithInsert+  :: forall u w r a+   . (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> DataCacheItem u w a -> DataCache (DataCacheItem u w) -> IO ())+  -> r a+  -> GenHaxl u w a+dataFetchWithInsert showFn insertFn req =+  GenHaxl $ \env@Env{..} -> do+  -- First, check the cache+  res <- cachedWithInsert showFn insertFn env req+  case res of+    -- This request has not been seen before+    Uncached rvar ivar fid -> do+      logFetch env showFn req fid+      ifProfiling flags $ addProfileFetch env req fid False+      --+      -- Check whether the data source wants to submit requests+      -- eagerly, or batch them up.+      --+      let+        blockedFetch = BlockedFetch req rvar+        blockedFetchI = BlockedFetchInternal fid+        submitFetch = do+          let hint :: SchedulerHint r+              hint = schedulerHintState (stateGet states) userEnv+          case hint of+            SubmitImmediately ->+              performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]+            TryToBatch ->+              -- add the request to the RequestStore and continue+              modifyIORef' reqStoreRef $ \bs ->+                addRequest blockedFetch blockedFetchI bs+          return $ Blocked ivar (Return ivar)++      -- if there is a fallback configured try that,+      -- else dispatch the fetch+      case dataCacheFetchFallback of+        Nothing -> submitFetch+        Just (DataCacheLookup dcl) -> do+          mbFallbackRes <- dcl req+          case mbFallbackRes of+            Nothing -> submitFetch+            Just fallbackRes -> do+              addFallbackResult env fallbackRes ivar+              ifReport flags ReportFetchStats $ addFallbackFetchStats+                env+                fid+                req+                fallbackRes+              return $ Blocked ivar (Return ivar)++    -- Seen before but not fetched yet.  We're blocked, but we don't have+    -- to add the request to the RequestStore.+    CachedNotFetched ivar fid -> do+      ifProfiling flags $ addProfileFetch env req fid True+      return $ Blocked ivar (Return ivar)++    -- Cached: either a result, or an exception+    Cached r fid -> do+      ifProfiling flags $ addProfileFetch env req fid True+      done env r++-- | 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 arbitrarily 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.+--+-- if we are recording or running a test, we fallback to using dataFetch+-- This allows us to store the request in the cache when recording, which+-- allows a transparent run afterwards. Without this, the test would try to+-- call the datasource during testing and that would be an exception.+uncachedRequest+ :: forall a u w (r :: Type -> Type). (DataSource u r, Request r a)+ => r a -> GenHaxl u w a+uncachedRequest req = do+  flg <- env flags+  if recording flg /= 0+    then dataFetch req+    else GenHaxl $ \e@Env{..} -> do+      ivar <- newIVar+      k <- nextCallId e+      let !rvar = stdResultVar e ivar (Proxy :: Proxy r)+      modifyIORef' reqStoreRef $ \bs ->+        addRequest (BlockedFetch req rvar) (BlockedFetchInternal k) bs+      return $ Blocked ivar (Return ivar)+++-- | Transparently provides caching. Useful for datasources that can+-- return immediately, but also caches values.  Exceptions thrown by+-- the IO operation (except for asynchronous exceptions) are+-- propagated into the Haxl monad and can be caught by 'catch' and+-- 'try'.+cacheResult :: Request r a => r a -> IO a -> GenHaxl u w a+cacheResult = cacheResultWithInsert show DataCache.insert++-- | Transparently provides caching in the same way as 'cacheResult', but uses+-- the given functions to show requests and their results.+cacheResultWithShow+  :: (Eq (r a), Hashable (r a), Typeable (r a))+  => ShowReq r a -> r a -> IO a -> GenHaxl u w a+cacheResultWithShow (showReq, showRes) = cacheResultWithInsert showReq+  (DataCache.insertWithShow showReq showRes)++-- Transparently provides caching, using the given function to insert requests+-- into the cache.+cacheResultWithInsert+  :: Typeable (r a)+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> DataCacheItem u w a -> DataCache (DataCacheItem u w) -> IO ())+  -> r a+  -> IO a+  -> GenHaxl u w a+cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env@Env{..} -> do+  mbRes <- DataCache.lookup req dataCache+  case mbRes of+    Nothing -> do+      let+        getResult = do+          eitherResult <- Exception.try val+          case eitherResult of+            Left e -> rethrowAsyncExceptions e+            _ -> return ()+          return $ eitherToResultThrowIO eitherResult+      -- if there is a fallback configured try that+      result <- case dataCacheFetchFallback of+        Nothing -> getResult+        Just (DataCacheLookup dcl) -> do+          mbFallbackRes <- dcl req+          maybe getResult return mbFallbackRes+      ivar <- newFullIVar result+      k <- nextCallId env+      insertFn req (DataCacheItem ivar k) dataCache+      done env result+    Just (DataCacheItem IVar{ivarRef = cr} _) -> do+      e <- readIORef cr+      case e of+        IVarEmpty _ -> raise env corruptCache+        IVarFull r -> done env r+  where+    corruptCache = DataSourceError $ Text.concat+      [ Text.pack (showFn 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 w ()+cacheRequest request result = GenHaxl $ \e@Env{..} -> do+  mbRes <- DataCache.lookup request dataCache+  case mbRes of+    Nothing -> do+      cr <- newFullIVar (eitherToResult result)+      k <- nextCallId e+      DataCache.insert request (DataCacheItem cr k) dataCache+      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 e $+      DataSourceError "cacheRequest: request is already in the cache"++-- | Similar to @cacheRequest@ but doesn't throw an exception if the key+-- already exists in the cache.+-- If this function is called twice to cache the same Haxl request, the first+-- value will be discarded and overwritten with the second value.+-- Useful e.g. for unit tests+dupableCacheRequest+  :: Request req a => req a -> Either SomeException a -> GenHaxl u w ()+dupableCacheRequest request result = GenHaxl $ \e@Env{..} -> do+  cr <- newFullIVar (eitherToResult result)+  k <- nextCallId e+  DataCache.insert request (DataCacheItem cr k) dataCache+  return (Done ())++performRequestStore+   :: forall u w. Env u w -> RequestStore u -> IO ()+performRequestStore env reqStore =+  performFetches env (contents reqStore)++-- | 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 w. Env u w -> [BlockedFetches u] -> IO ()+performFetches env@Env{flags=f, statsRef=sref, statsBatchIdRef=sbref} jobs = do+  t0 <- getTimestamp+   ifTrace f 3 $-    forM_ jobs $ \(BlockedFetches reqs) ->-      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (show1 r)+    forM_ jobs $ \(BlockedFetches reqs _) ->+      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (showp r)    let-    applyFetch (BlockedFetches (reqs :: [BlockedFetch r])) =+    applyFetch i bfs@(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+          return (FetchToDo reqs (SyncFetch (mapM_ (setError e))))+         where+           e :: ShowP req => req a -> DataSourceError+           e req = DataSourceError $ "data source not initialized: " <> dsName+                  <> ": "+                  <> Text.pack (showp req)         Just state ->-          return $ wrapFetch reqs $ fetch state f (userEnv env) reqs+          return $ FetchToDo reqs+            $ (if testReportFlag ReportFetchStats $ report f+                then wrapFetchInStats+                        (userEnv env)+                        sref+                        sbref+                        dsName+                        (length reqs)+                        bfs+                else id)+            $ wrapFetchInTrace i (length reqs) dsName+            $ wrapFetchInCatch reqs+            $ fetch state f (userEnv env)+      where+        dsName = dataSourceName (Proxy :: Proxy r) -  fetches <- mapM applyFetch jobs+  fetches <- zipWithM applyFetch [0..] jobs -  scheduleFetches fetches+  scheduleFetches fetches (submittedReqsRef env) (flags env) -  ifTrace f 1 $ do-    t1 <- getCurrentTime-    printf "Batch data fetch done (%.2fs)\n"-      (realToFrac (diffUTCTime t1 t0) :: Double)+  t1 <- getTimestamp+  let roundtime = fromIntegral (t1 - t0) / 1000000 :: Double +  ifTrace f 1 $+    printf "Batch data fetch done (%.4fs)\n" (realToFrac roundtime :: Double)++data FetchToDo where+  FetchToDo+    :: forall (req :: Type -> Type). (DataSourceName req, Typeable req)+    => [BlockedFetch req] -> PerformFetch req -> FetchToDo+ -- 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 =+wrapFetchInCatch :: [BlockedFetch req] -> PerformFetch req -> PerformFetch req+wrapFetchInCatch reqs fetch =   case fetch of-    SyncFetch io -> SyncFetch (io `catch` handler)-    AsyncFetch fio -> AsyncFetch (\io -> fio io `catch` handler)+    SyncFetch f ->+      SyncFetch $ \reqs -> f reqs `Exception.catch` handler+    AsyncFetch f ->+      AsyncFetch $ \reqs io -> f reqs io `Exception.catch` handler+      -- this might be wrong: if the outer 'fio' throws an exception,+      -- then we don't know whether we have executed the inner 'io' or+      -- not.  If not, then we'll likely get some errors about "did+      -- not set result var" later, because we haven't executed some+      -- data fetches.  But we can't execute 'io' in the handler,+      -- because we might have already done it.  It isn't possible to+      -- do it completely right here, so we have to rely on data+      -- sources themselves to catch (synchronous) exceptions.  Async+      -- exceptions aren't a problem because we're going to rethrow+      -- them all the way to runHaxl anyway.+    BackgroundFetch f ->+      BackgroundFetch $ \reqs -> f reqs `Exception.catch` handler   where     handler :: SomeException -> IO ()-    handler e = mapM_ (forceError e) reqs+    handler e = do+      rethrowAsyncExceptions 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+    forceError e (BlockedFetch _ rvar) =       putResult rvar (except e) ++data FailureCount = FailureCount+  { failureCountStandard :: {-# UNPACK #-} !Int+  , failureCountIgnored :: {-# UNPACK #-} !Int+  }++#if __GLASGOW_HASKELL__ >= 804+instance Semigroup FailureCount where+  FailureCount s1 i1 <> FailureCount s2 i2 = FailureCount (s1+s2) (i1+i2)+#endif++instance Monoid FailureCount where+  mempty = FailureCount 0 0+#if __GLASGOW_HASKELL__ < 804+  mappend (FailureCount s1 i1) (FailureCount s2 i2)+    = FailureCount (s1+s2) (i1+i2)+#endif++wrapFetchInStats+  :: DataSource u req+  => u+  -> IORef Stats+  -> IORef Int+  -> Text+  -> Int+  -> BlockedFetches u+  -> PerformFetch req+  -> PerformFetch req+wrapFetchInStats+  u+  !statsRef+  !batchIdRef+  dataSource+  batchSize+  (BlockedFetches _reqs reqsI)+  perform = do+  case perform of+    SyncFetch f ->+      SyncFetch $ \reqs -> do+        bid <- newBatchId+        fail_ref <- newIORef mempty+        (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref)+          (reqsWithFetchDsStats bid reqs)))+        failures <- readIORef fail_ref+        updateFetchStats bid allFids t0 t alloc batchSize failures+    AsyncFetch f -> do+      AsyncFetch $ \reqs inner -> do+        bid <- newBatchId+        inner_r <- newIORef (0, 0)+        fail_ref <- newIORef mempty+        let inner' = do+              (_,t,alloc,_) <- statsForIO inner+              writeIORef inner_r (t,alloc)+            reqs' = map (addFailureCount u fail_ref) reqs+            reqs'' = reqsWithFetchDsStats bid reqs'+        (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs'' inner')+        (innerTime, innerAlloc) <- readIORef inner_r+        failures <- readIORef fail_ref+        updateFetchStats bid allFids t0 (totalTime - innerTime)+          (totalAlloc - innerAlloc) batchSize failures+    BackgroundFetch io -> do+      BackgroundFetch $ \reqs -> do+        bid <- newBatchId+        startTime <- getTimestamp+        io (reqsWithFetchDsStats bid+          (zipWith (addTimer u bid startTime) reqs reqsI))+  where+    allFids = map (\(BlockedFetchInternal k) -> k) reqsI+    newBatchId = atomicModifyIORef' batchIdRef $ \x -> (x+1,x+1)+    statsForIO io = do+      prevAlloc <- getAllocationCounter+      (t0,t,a) <- time io+      postAlloc <- getAllocationCounter+      return (t0,t, fromIntegral $ prevAlloc - postAlloc, a)+    reqsWithFetchDsStats = \bid reqs+      -> zipWith (addFetchDatasourceStats bid) reqs reqsI+    addTimer+      u+      bid+      t0+      (BlockedFetch req (ResultVar fn))+      (BlockedFetchInternal fid) =+        BlockedFetch req $ ResultVar $ \result isChildThread stats -> do+          t1 <- getTimestamp+          -- We cannot measure allocation easily for BackgroundFetch. Here we+          -- just attribute all allocation to the last+          -- `putResultFromChildThread` and use 0 for the others.+          -- While the individual allocations may not be correct,+          -- the total sum and amortized allocation are still meaningful.+          -- see Note [tracking allocation in child threads]+          allocs <- if isChildThread then getAllocationCounter else return 0+          updateFetchStats bid [fid] t0 (t1 - t0)+            (negate allocs)+            1 -- batch size: we don't know if this is a batch or not+            (calcFailure u req result) -- failures+          fn result isChildThread stats++    addFetchDatasourceStats+      :: Int+      -> BlockedFetch r+      -> BlockedFetchInternal+      -> BlockedFetch r+    addFetchDatasourceStats bid+      (BlockedFetch req (ResultVar fn))+      (BlockedFetchInternal fid) = BlockedFetch req $ ResultVar+        $ \result isChildThread stats -> do+          let mkStats dss = FetchDataSourceStats+                { fetchDsStatsCallId = fid+                , fetchDsStatsDataSource = dataSource+                , fetchDsStatsStats = dss+                , fetchBatchId = bid+                }+          case stats of+            Just dss -> atomicModifyIORef' statsRef+              $ \(Stats fs) -> (Stats (mkStats dss : fs), ())+            Nothing -> return ()+          fn result isChildThread stats+++    updateFetchStats+      :: Int+      -> [CallId]+      -> Timestamp+      -> Microseconds+      -> Int64+      -> Int+      -> FailureCount+      -> IO ()+    updateFetchStats bid fids start time space batch FailureCount{..} = do+      let this = FetchStats { fetchDataSource = dataSource+                            , fetchBatchSize = batch+                            , fetchStart = start+                            , fetchDuration = time+                            , fetchSpace = space+                            , fetchFailures = failureCountStandard+                            , fetchIgnoredFailures = failureCountIgnored+                            , fetchBatchId = bid+                            , fetchIds = fids }+      atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ())++    addFailureCount :: DataSource u r+      => u -> IORef FailureCount -> BlockedFetch r -> BlockedFetch r+    addFailureCount u ref (BlockedFetch req (ResultVar fn)) =+      BlockedFetch req $ ResultVar $ \result isChildThread stats -> do+        let addFailures r = (r <> calcFailure u req result, ())+        when (isLeft result) $ atomicModifyIORef' ref addFailures+        fn result isChildThread stats++wrapFetchInTrace+  :: Int+  -> Int+  -> Text+  -> PerformFetch req+  -> PerformFetch req+#ifdef EVENTLOG+wrapFetchInTrace i n dsName f =+  case f of+    SyncFetch io -> SyncFetch (wrapF "Sync" io)+    AsyncFetch fio -> AsyncFetch (wrapF "Async" . fio . unwrapF "Async")+  where+    d = Text.unpack dsName+    wrapF :: String -> IO a -> IO a+    wrapF ty = bracket_ (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)+                        (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)+    unwrapF :: String -> IO a -> IO a+    unwrapF ty = bracket_ (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)+                          (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)+#else+wrapFetchInTrace _ _ _ f = f+#endif++time :: IO a -> IO (Timestamp,Microseconds,a)+time io = do+  t0 <- getTimestamp+  a <- io+  t1 <- getTimestamp+  return (t0, t1 - t0, a)+ -- | 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+scheduleFetches :: [FetchToDo] -> IORef ReqCountMap -> Flags -> IO ()+scheduleFetches fetches ref flags = do+  -- update ReqCountmap for these fetches+  ifReport flags ReportOutgoneFetches $ sequence_+    [ atomicModifyIORef' ref $+        \m -> (addToCountMap (Proxy :: Proxy r) (length reqs) m, ())+    | FetchToDo (reqs :: [BlockedFetch r]) _f <- fetches+    ]++  ifTrace flags 1 $ printf "Batch data fetch round: %s\n" $+     intercalate (", "::String) $+        map (\(c, n, ds) -> printf "%s %s %d" n ds c) stats++  fully_async_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]+  fetchName :: forall req . PerformFetch req -> String+  fetchName (BackgroundFetch _) = "background"+  fetchName (AsyncFetch _) = "async"+  fetchName (SyncFetch _) = "sync" --- | Possible responses when checking the cache.-data CacheResult a-  -- | The request hadn't been seen until now.-  = Uncached (ResultVar a)+  srcName :: forall req . (DataSourceName req) => [BlockedFetch req] -> String+  srcName _ = Text.unpack $ dataSourceName (Proxy :: Proxy req) -  -- | The request has been seen before, but its result has not yet been-  -- fetched.-  | CachedNotFetched (ResultVar a)+  stats = [(length reqs, fetchName f, srcName reqs)+          | FetchToDo reqs f <- fetches] -  -- | The request has been seen before, and its result has already been-  -- fetched.-  | Cached (Either SomeException a)+  fully_async_fetches :: IO ()+  fully_async_fetches = sequence_+    [f reqs | FetchToDo reqs (BackgroundFetch f) <- fetches] +  async_fetches :: IO () -> IO ()+  async_fetches = compose+    [f reqs | FetchToDo reqs (AsyncFetch f) <- fetches] --- | 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)+  sync_fetches :: IO ()+  sync_fetches = sequence_+    [f reqs | FetchToDo reqs (SyncFetch f) <- fetches] --- | 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)+-- | An exception thrown when reading from datasources fails+data ReadingCompletionsFailedFetch = ReadingCompletionsFailedFetch Text+  deriving Show -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)+instance Exception ReadingCompletionsFailedFetch
+ Haxl/Core/Flags.hs view
@@ -0,0 +1,127 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE BangPatterns #-}++-- |+-- The 'Flags' type and related functions.  This module is provided+-- for access to Haxl internals only; most users should import+-- "Haxl.Core" instead.+--+module Haxl.Core.Flags+  (+    -- * Report flags+    ReportFlag(..)+  , ReportFlags+  , defaultReportFlags+  , profilingReportFlags+  , setReportFlag+  , clearReportFlag+  , testReportFlag+    -- * Flags+  , Flags(..)+  , defaultFlags+  , ifTrace+  , ifReport+  , ifProfiling+  ) where++import Control.Monad+import Data.Bits+import Data.List (foldl')+import Text.Printf (printf)++-- ---------------------------------------------------------------------------+-- ReportFlags+data ReportFlag+  = ReportOutgoneFetches  -- ^ outgone fetches, for debugging eg: timeouts+  | ReportFetchStats  -- ^ data fetch stats & errors+  | ReportProfiling   -- ^ enabling label stack and profiling+  | ReportExceptionLabelStack  -- ^ include label stack in HaxlException+  | ReportFetchStack  -- ^ log cost-center stack traces of dataFetch calls+  deriving (Bounded, Enum, Eq, Show)++profilingDependents :: [ReportFlag]+profilingDependents =+  [ ReportExceptionLabelStack+  , ReportFetchStack+  ]++newtype ReportFlags = ReportFlags Int++instance Show ReportFlags where+  show (ReportFlags fs) = printf "%0*b" (fromEnum maxReportFlag + 1) fs+    where+      maxReportFlag = maxBound :: ReportFlag++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags 0++profilingReportFlags :: ReportFlags+profilingReportFlags = foldl' (flip setReportFlag) defaultReportFlags+  [ ReportOutgoneFetches+  , ReportFetchStats+  , ReportProfiling+  ]++setReportFlag :: ReportFlag -> ReportFlags -> ReportFlags+setReportFlag f (ReportFlags fs) =+  ReportFlags $ setDependencies $ setBit fs $ fromEnum f+  where+    setDependencies+      | f `elem` profilingDependents = flip setBit $ fromEnum ReportProfiling+      | otherwise = id++clearReportFlag :: ReportFlag -> ReportFlags -> ReportFlags+clearReportFlag f (ReportFlags fs) =+  ReportFlags $ clearDependents $ clearBit fs $ fromEnum f+  where+    clearDependents z = case f of+      ReportProfiling -> foldl' clearBit z $ map fromEnum profilingDependents+      _ -> z++{-# INLINE testReportFlag #-}+testReportFlag :: ReportFlag -> ReportFlags -> Bool+testReportFlag !f (ReportFlags !fs) = testBit fs $ fromEnum f++-- ---------------------------------------------------------------------------+-- Flags++-- | Flags that control the operation of the engine.+data Flags = Flags+  { trace :: {-# UNPACK #-} !Int+    -- ^ Tracing level (0 = quiet, 3 = very verbose).+  , report :: {-# UNPACK #-} !ReportFlags+    -- ^ Report flags+  , caching :: {-# UNPACK #-} !Int+    -- ^ Non-zero if caching is enabled.  If caching is disabled, then+    -- we still do batching and de-duplication, but do not cache+    -- results.+  , recording :: {-# UNPACK #-} !Int+    -- ^ Non-zero if recording is enabled. This allows tests to record cache+    -- calls for datasources by making uncachedRequest behave like dataFetch+  }++defaultFlags :: Flags+defaultFlags = Flags+  { trace = 0+  , report = defaultReportFlags+  , caching = 1+  , recording = 0+  }++-- | Runs an action if the tracing level is above the given threshold.+ifTrace :: Monad m => Flags -> Int -> m a -> m ()+ifTrace flags i = when (trace flags >= i) . void++-- | Runs an action if the ReportFlag is set.+ifReport :: Monad m => Flags -> ReportFlag -> m a -> m ()+ifReport flags i = when (testReportFlag i $ report flags) . void++ifProfiling :: Monad m => Flags -> m a -> m ()+ifProfiling flags = ifReport flags ReportProfiling
+ Haxl/Core/Memo.hs view
@@ -0,0 +1,475 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Memoization support. This module is provided for access to Haxl+-- internals only; most users should import "Haxl.Core" instead.+--+module Haxl.Core.Memo+  (+    -- * Basic memoization+    cachedComputation+  , preCacheComputation++    -- * High-level memoization+  , memo+  , memoFingerprint+  , MemoFingerprintKey(..)+  , memoize, memoize1, memoize2+  , memoUnique++    -- * Local memoization+  , MemoVar+  , newMemo+  , newMemoWith+  , prepareMemo+  , runMemo+  ) where++import Control.Exception as Exception hiding (throw)+import Data.IORef+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text)+import Data.Typeable+import Data.Hashable+import Data.Int+import Data.Word++import GHC.Prim (Addr#)++import Haxl.Core.Exception+import Haxl.Core.DataCache as DataCache+import Haxl.Core.Flags+import Haxl.Core.Monad+import Haxl.Core.Stats+import Haxl.Core.Profile+import Haxl.Core.Util (trace_)++-- -----------------------------------------------------------------------------+-- Memoization++-- | '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 w a.+      ( Eq (req a)+      , Hashable (req a)+      , Typeable (req a)+      , Monoid w)+   => req a -> GenHaxl u w a -> GenHaxl u w a++cachedComputation req haxl = GenHaxl $ \env@Env{..} -> do+  mbRes <- DataCache.lookup req memoCache+  case mbRes of+    Just (DataCacheItem ivar k) -> do+      ifProfiling flags $ do+        incrementMemoHitCounterFor env k True+      unHaxl (getIVarWithWrites ivar) env+    Nothing -> do+      ivar <- newIVar+      k <- nextCallId env+      -- no need to incremenetMemoHitCounter as execMemo will do it+      DataCache.insertNotShowable req (DataCacheItem ivar k) memoCache+      execMemoNowProfiled env haxl ivar k+++-- | Like 'cachedComputation', but fails if the cache is already+-- populated.+--+-- Memoization can be (ab)used to "mock" a cached computation, by+-- pre-populating the cache with an alternative implementation. In+-- that case we don't want the operation to populate the cache to+-- silently succeed if the cache is already populated.+--+preCacheComputation+  :: forall req u w a.+     ( Eq (req a)+     , Hashable (req a)+     , Typeable (req a)+     , Monoid w)+  => req a -> GenHaxl u w a -> GenHaxl u w a+preCacheComputation req haxl = GenHaxl $ \env@Env{..} -> do+  mbRes <- DataCache.lookup req memoCache+  case mbRes of+    Just _ -> return $ Throw $ toException $ InvalidParameter+      "preCacheComputation: key is already cached"+    Nothing -> do+      ivar <- newIVar+      k <- nextCallId env+      DataCache.insertNotShowable req (DataCacheItem ivar k) memoCache+      execMemoNowProfiled env haxl ivar k++-- -----------------------------------------------------------------------------+-- Memoization++newtype MemoVar u w a = MemoVar (IORef (MemoStatus u w a))++data MemoStatus u w a+  = MemoEmpty+  | MemoReady (GenHaxl u w a) CallId+  | MemoRun {-# UNPACK #-} !(IVar u w a) {-# UNPACK #-} !CallId++-- | Create a new @MemoVar@ for storing a memoized computation. The created+-- @MemoVar@ is initially empty, not tied to any specific computation. Running+-- this memo (with @runMemo@) without preparing it first (with @prepareMemo@)+-- will result in an exception.+newMemo :: GenHaxl u w (MemoVar u w a)+newMemo = unsafeLiftIO $ MemoVar <$> newIORef MemoEmpty++-- | Store a computation within a supplied @MemoVar@. Any memo stored within the+-- @MemoVar@ already (regardless of completion) will be discarded, in favor of+-- the supplied computation. A @MemoVar@ must be prepared before it is run.+prepareMemo :: MemoVar u w a -> GenHaxl u w a -> GenHaxl u w ()+prepareMemo (MemoVar memoRef) memoCmp+  = GenHaxl $ \env -> do+      k <- nextCallId env+      writeIORef memoRef (MemoReady memoCmp k)+      return (Done ())++-- | Convenience function, combines @newMemo@ and @prepareMemo@.+newMemoWith :: GenHaxl u w a -> GenHaxl u w (MemoVar u w a)+newMemoWith memoCmp = do+  memoVar <- newMemo+  prepareMemo memoVar memoCmp+  return memoVar++-- | Continue the memoized computation within a given @MemoVar@.+-- Notes:+--+--   1. If the memo contains a complete result, return that result.+--   2. If the memo contains an in-progress computation, continue it as far as+--      possible for this round.+--   3. If the memo is empty (it was not prepared), throw an error.+--+-- For example, to memoize the computation @one@ given by:+--+-- > one :: Haxl Int+-- > one = return 1+--+-- use:+--+-- > do+-- >   oneMemo <- newMemoWith one+-- >   let memoizedOne = runMemo aMemo one+-- >   oneResult <- memoizedOne+--+-- To memoize mutually dependent computations such as in:+--+-- > h :: Haxl Int+-- > h = do+-- >   a <- f+-- >   b <- g+-- >   return (a + b)+-- >  where+-- >   f = return 42+-- >   g = succ <$> f+--+-- without needing to reorder them, use:+--+-- > h :: Haxl Int+-- > h = do+-- >   fMemoRef <- newMemo+-- >   gMemoRef <- newMemo+-- >+-- >   let f = runMemo fMemoRef+-- >       g = runMemo gMemoRef+-- >+-- >   prepareMemo fMemoRef $ return 42+-- >   prepareMemo gMemoRef $ succ <$> f+-- >+-- >   a <- f+-- >   b <- g+-- >   return (a + b)+--+runMemo :: Monoid w => MemoVar u w a -> GenHaxl u w a+runMemo (MemoVar memoRef) = GenHaxl $ \env -> do+  stored <- readIORef memoRef+  case stored of+    -- Memo was not prepared first; throw an exception.+    MemoEmpty -> trace_ "MemoEmpty " $+      raise env $ CriticalError "Attempting to run empty memo."+    -- Memo has been prepared but not run yet+    MemoReady cont k -> trace_ "MemoReady" $ do+      ivar <- newIVar+      writeIORef memoRef (MemoRun ivar k)+      execMemoNowProfiled env cont ivar k+    -- The memo has already been run, get (or wait for) for the result+    MemoRun ivar k -> trace_ "MemoRun" $ do+      ifProfiling (flags env) $ do+        incrementMemoHitCounterFor env k True+      unHaxl (getIVarWithWrites ivar) env++execMemoNowProfiled+  :: Monoid w+  => Env u w+  -> GenHaxl u w a+  -> IVar u w a+  -> CallId+  -> IO (Result u w a)+execMemoNowProfiled envOuter cont ivar cid =+  if not $ testReportFlag ReportProfiling $ report $ flags envOuter+  then execMemoNow envOuter cont ivar+  else do+    incrementMemoHitCounterFor envOuter cid False+    unHaxl+      (collectMemoData 0 $ GenHaxl $ \e -> execMemoNow e cont ivar)+      envOuter+  where+    addStats :: Env u w -> Int64 -> IO ()+    addStats env acc = modifyIORef' (statsRef env) $ \(Stats s) ->+      Stats (MemoCall cid acc : s)+    collectMemoData :: Int64 -> GenHaxl u w a -> GenHaxl u w a+    collectMemoData acc f = GenHaxl $ \env -> do+      a0 <- getAllocationCounter+      r <- unHaxl f env{memoKey=cid}+      a1 <- getAllocationCounter+      let newTotal = acc + (a0 - a1)+      ret <- case r of+        Done a -> do addStats env newTotal; return (Done a)+        Throw e -> do addStats env newTotal; return (Throw e)+        Blocked ivar k ->+          return (Blocked ivar (Cont (collectMemoData newTotal (toHaxl k))))+      setAllocationCounter a1+      return ret++execMemoNow :: Monoid w => Env u w -> GenHaxl u w a -> IVar u w a -> IO (Result u w a)+execMemoNow env cont ivar = do+  wlogs <- newIORef mempty+  let+    !menv = env { writeLogsRef = wlogs }+    -- use an env with empty writes, so we can memoize the extra+    -- writes done as part of 'cont'+  r <- Exception.try $ unHaxl cont menv++  case r of+    Left e -> trace_ ("execMemoNow: Left " ++ show e) $ do+      rethrowAsyncExceptions e+      putIVar ivar (ThrowIO e) env+      throwIO e+    Right (Done a) -> trace_ "execMemoNow: Done" $ do+      wt <- readIORef wlogs+      putIVar ivar (Ok a (Just wt)) env+      modifyIORef' (writeLogsRef env) (<> wt)+      return (Done a)+    Right (Throw ex) -> trace_ ("execMemoNow: Throw" ++ show ex) $ do+      wt <- readIORef wlogs+      putIVar ivar (ThrowHaxl ex (Just wt)) env+      modifyIORef' (writeLogsRef env) (<> wt)+      return (Throw ex)+    Right (Blocked ivar' cont) -> trace_ "execMemoNow: Blocked" $ do+      -- We "block" this memoized computation in the new environment 'menv', so+      -- that when it finishes, we can store all the write logs from the env+      -- in the IVar.+      addJob menv (toHaxl cont) ivar ivar'+      -- Now we call @getIVarWithWrites@ to populate the writes in the original+      -- environment 'env'.+      return (Blocked ivar (Cont (getIVarWithWrites ivar)))++-- -----------------------------------------------------------------------------+-- 1-ary and 2-ary memo functions++newtype MemoVar1 u w a b = MemoVar1 (IORef (MemoStatus1 u w a b))+newtype MemoVar2 u w a b c = MemoVar2 (IORef (MemoStatus2 u w a b c))++data MemoStatus1 u w a b+  = MemoEmpty1+  | MemoTbl1 (a -> GenHaxl u w b) (HashMap.HashMap a (MemoVar u w b))++data MemoStatus2 u w a b c+  = MemoEmpty2+  | MemoTbl2+      (a -> b -> GenHaxl u w c)+      (HashMap.HashMap a (HashMap.HashMap b (MemoVar u w c)))++newMemo1 :: GenHaxl u w (MemoVar1 u w a b)+newMemo1 = unsafeLiftIO $ MemoVar1 <$> newIORef MemoEmpty1++newMemoWith1 :: (a -> GenHaxl u w b) -> GenHaxl u w (MemoVar1 u w a b)+newMemoWith1 f = newMemo1 >>= \r -> prepareMemo1 r f >> return r++prepareMemo1 :: MemoVar1 u w a b -> (a -> GenHaxl u w b) -> GenHaxl u w ()+prepareMemo1 (MemoVar1 r) f+  = unsafeLiftIO $ writeIORef r (MemoTbl1 f HashMap.empty)++runMemo1 :: (Eq a, Hashable a, Monoid w) => MemoVar1 u w a b -> a -> GenHaxl u w b+runMemo1 (MemoVar1 r) k = unsafeLiftIO (readIORef r) >>= \case+  MemoEmpty1 -> throw $ CriticalError "Attempting to run empty memo."+  MemoTbl1 f h -> case HashMap.lookup k h of+    Nothing -> do+      x <- newMemoWith (f k)+      unsafeLiftIO $ writeIORef r (MemoTbl1 f (HashMap.insert k x h))+      runMemo x+    Just v -> runMemo v++newMemo2 :: GenHaxl u w (MemoVar2 u w a b c)+newMemo2 = unsafeLiftIO $ MemoVar2 <$> newIORef MemoEmpty2++newMemoWith2 :: (a -> b -> GenHaxl u w c) -> GenHaxl u w (MemoVar2 u w a b c)+newMemoWith2 f = newMemo2 >>= \r -> prepareMemo2 r f >> return r++prepareMemo2 :: MemoVar2 u w a b c -> (a -> b -> GenHaxl u w c) -> GenHaxl u w ()+prepareMemo2 (MemoVar2 r) f+  = unsafeLiftIO $ writeIORef r (MemoTbl2 f HashMap.empty)++runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b, Monoid w)+         => MemoVar2 u w a b c+         -> a -> b -> GenHaxl u w c+runMemo2 (MemoVar2 r) k1 k2 = unsafeLiftIO (readIORef r) >>= \case+  MemoEmpty2 -> throw $ CriticalError "Attempting to run empty memo."+  MemoTbl2 f h1 -> case HashMap.lookup k1 h1 of+    Nothing -> do+      v <- newMemoWith (f k1 k2)+      unsafeLiftIO $ writeIORef r+        (MemoTbl2 f (HashMap.insert k1 (HashMap.singleton k2 v) h1))+      runMemo v+    Just h2 -> case HashMap.lookup k2 h2 of+      Nothing -> do+        v <- newMemoWith (f k1 k2)+        unsafeLiftIO $ writeIORef r+          (MemoTbl2 f (HashMap.insert k1 (HashMap.insert k2 v h2) h1))+        runMemo v+      Just v -> runMemo v++-- -----------------------------------------------------------------------------+-- A key type that can be used for memoizing computations by a Text key++-- | Memoize a computation using an arbitrary key.  The result will be+-- calculated once; the second and subsequent time it will be returned+-- immediately.  It is the caller's responsibility to ensure that for+-- every two calls @memo key haxl@, if they have the same @key@ then+-- they compute the same result.+memo+  :: (Typeable a, Typeable k, Hashable k, Eq k, Monoid w)+  => k -> GenHaxl u w a -> GenHaxl u w a+memo key = cachedComputation (MemoKey key)++{-# RULES+"memo/Text" memo = memoText :: (Typeable a, Monoid w) =>+            Text -> GenHaxl u w a -> GenHaxl u w a+ #-}++{-# NOINLINE memo #-}++-- | Memoize a computation using its location and a Fingerprint. This ensures+-- uniqueness across computations.+memoUnique+  :: (Typeable a, Typeable k, Hashable k, Eq k, Monoid w)+  => MemoFingerprintKey a -> Text -> k -> GenHaxl u w a -> GenHaxl u w a+memoUnique fp label key = withLabel label . memo (fp, key)++{-# NOINLINE memoUnique #-}++data MemoKey k a where+  MemoKey :: (Typeable k, Hashable k, Eq k) => k -> MemoKey k a+  deriving Typeable++deriving instance Eq (MemoKey k a)++instance Hashable (MemoKey k a) where+  hashWithSalt s (MemoKey t) = hashWithSalt s t++-- An optimised memo key for Text keys.  This is used automatically+-- when the key is Text, due to the RULES pragma above.++data MemoTextKey a where+  MemoText :: Text -> MemoTextKey a+  deriving Typeable++deriving instance Eq (MemoTextKey a)++instance Hashable (MemoTextKey a) where+  hashWithSalt s (MemoText t) = hashWithSalt s t++memoText :: (Typeable a, Monoid w) => Text -> GenHaxl u w a -> GenHaxl u w a+memoText key = withLabel key . cachedComputation (MemoText key)++-- | A memo key derived from a 128-bit MD5 hash.  Do not use this directly,+-- it is for use by automatically-generated memoization.+data MemoFingerprintKey a where+  MemoFingerprintKey+    :: {-# UNPACK #-} !Word64+    -> {-# UNPACK #-} !Word64+    -> Addr# -> Addr#+    -> MemoFingerprintKey a+  deriving Typeable++deriving instance Eq (MemoFingerprintKey a)++instance Hashable (MemoFingerprintKey a) where+  hashWithSalt s (MemoFingerprintKey x _ _ _) =+    hashWithSalt s (fromIntegral x :: Int)++-- This is optimised for cheap call sites: when we have a call+--+--   memoFingerprint (MemoFingerprintKey 1234 5678 "module"# "name"#) e+--+-- then the MemoFingerprintKey constructor will be statically+-- allocated (with two 64-bit fields and pointers to cstrings for the names),+-- and shared by all calls to memo. So the memo call will not allocate,+-- unlike memoText.+--+{-# NOINLINE memoFingerprint #-}+memoFingerprint+  :: (Typeable a, Monoid w) => MemoFingerprintKey a -> GenHaxl u w a -> GenHaxl u w a+memoFingerprint key@(MemoFingerprintKey _ _ mnPtr nPtr) =+  withFingerprintLabel mnPtr nPtr . cachedComputation key++-- * Generic memoization machinery.++-- | Transform a Haxl computation into a memoized version of itself.+--+-- Given a Haxl computation, @memoize@ creates a version which stores its result+-- in a @MemoVar@ (which @memoize@ creates), and returns the stored result on+-- subsequent invocations. This permits the creation of local memos, whose+-- lifetimes are scoped to the current function, rather than the entire request.+memoize :: Monoid w => GenHaxl u w a -> GenHaxl u w (GenHaxl u w a)+memoize a = runMemo <$> newMemoWith a++-- | Transform a 1-argument function returning a Haxl computation into a+-- memoized version of itself.+--+-- Given a function @f@ of type @a -> GenHaxl u w b@, @memoize1@ creates a version+-- which memoizes the results of @f@ in a table keyed by its argument, and+-- returns stored results on subsequent invocations with the same argument.+--+-- e.g.:+--+-- > allFriends :: [Int] -> GenHaxl u w [Int]+-- > allFriends ids = do+-- >   memoizedFriendsOf <- memoize1 friendsOf+-- >   concat <$> mapM memoizeFriendsOf ids+--+-- The above implementation will not invoke the underlying @friendsOf@+-- repeatedly for duplicate values in @ids@.+memoize1 :: (Eq a, Hashable a, Monoid w)+         => (a -> GenHaxl u w b)+         -> GenHaxl u w (a -> GenHaxl u w b)+memoize1 f = runMemo1 <$> newMemoWith1 f++-- | Transform a 2-argument function returning a Haxl computation, into a+-- memoized version of itself.+--+-- The 2-ary version of @memoize1@, see its documentation for details.+memoize2 :: (Eq a, Hashable a, Eq b, Hashable b, Monoid w)+         => (a -> b -> GenHaxl u w c)+         -> GenHaxl u w (a -> b -> GenHaxl u w c)+memoize2 f = runMemo2 <$> newMemoWith2 f
Haxl/Core/Monad.hs view
@@ -1,351 +1,1138 @@--- 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))) $$+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{- TODO++- do EVENTLOG stuff, track the data fetch numbers for performFetch++- timing: we should be using clock_gettime(CLOCK_MONOTONIC) instead of+  getCurrentTime, which will be affected by NTP and leap seconds.++- write different scheduling policies++-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- The implementation of the 'Haxl' monad.  Most users should+-- import "Haxl.Core" instead of importing this module directly.+--+module Haxl.Core.Monad+  (+    -- * The monad+    GenHaxl(..)+  , Result(..)++    -- * Writes (for debugging only)+  , WriteTree(..)+  , tellWrite+  , tellWriteNoMemo+  , write+  , writeNoMemo+  , flattenWT+  , appendWTs+  , mbModifyWLRef+  , mapWrites+  , mapWriteTree++    -- * Cont+  , Cont(..)+  , toHaxl++    -- * IVar+  , IVar(..)+  , IVarContents(..)+  , newIVar+  , newFullIVar+  , withCurrentCCS+  , getIVar+  , getIVarWithWrites+  , putIVar++    -- * ResultVal+  , ResultVal(..)+  , done+  , eitherToResult+  , eitherToResultThrowIO++    -- * CompleteReq+  , CompleteReq(..)++    -- * Env+  , Env(..)+  , DataCacheItem(..)+  , DataCacheLookup(..)+  , HaxlDataCache+  , Caches+  , caches+  , initEnvWithData+  , initEnv+  , emptyEnv+  , env, withEnv+  , nextCallId+  , sanitizeEnv++    -- * Profiling+  , ProfileCurrent(..)++    -- * JobList+  , JobList(..)+  , appendJobList+  , lengthJobList+  , addJob++    -- * Exceptions+  , throw+  , raise+  , catch+  , catchIf+  , try+  , tryToHaxlException++    -- * Dumping the cache+  , dumpCacheAsHaskell+  , dumpCacheAsHaskellFn++    -- * CallGraph+#ifdef PROFILING+  , withCallGraph+#endif++    -- * Unsafe operations+  ,  unsafeLiftIO, unsafeToHaxlException+  ) where++import Haxl.Core.Flags+import Haxl.Core.Stats+import Haxl.Core.StateStore+import Haxl.Core.Exception+import Haxl.Core.RequestStore as RequestStore+import Haxl.Core.DataCache as DataCache+import Haxl.Core.Util (trace_)++import Control.Applicative (liftA2)+import Control.Arrow (left)+import Control.Concurrent.STM+import qualified Control.Monad.Catch as Catch+import Control.Exception (Exception(..), SomeException, throwIO)+#if __GLASGOW_HASKELL__ >= 808+import Control.Monad hiding (MonadFail)+import qualified Control.Monad as CTL+#else+import Control.Monad+#endif+import qualified Control.Exception as Exception+import Data.Either (rights)+import Data.IORef+import Data.Int+import Data.Maybe+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import qualified Data.Text as Text+import Data.Typeable+import GHC.Exts (IsString(..))+import Text.PrettyPrint hiding ((<>))+import Text.Printf+#ifdef EVENTLOG+import Control.Exception (bracket_)+import Debug.Trace (traceEventIO)+#endif++#ifdef PROFILING+import qualified Data.Map as Map+import Data.Text (Text)+import Foreign.Ptr (Ptr)+import GHC.Stack+import Haxl.Core.CallGraph+#endif++-- -----------------------------------------------------------------------------+-- The environment++-- | The data we carry around in the Haxl monad.++data DataCacheItem u w a = DataCacheItem (IVar u w a) {-# UNPACK #-} !CallId+type HaxlDataCache u w = DataCache (DataCacheItem u w)+newtype DataCacheLookup w =+  DataCacheLookup+    (forall req a . Typeable (req a)+    => req a+    -> IO (Maybe (ResultVal a w)))++data Env u w = Env+  { dataCache     :: {-# UNPACK #-} !(HaxlDataCache u w)+      -- ^ cached data fetches++  , memoCache      :: {-# UNPACK #-} !(HaxlDataCache u w)+      -- ^ memoized computations++  , memoKey    :: {-# UNPACK #-} !CallId+      -- ^ current running memo key++  , flags        :: !Flags+      -- conservatively not unpacking, because this is passed+      -- to 'fetch' and would need to be rebuilt.++  , userEnv      :: u+      -- ^ user-supplied data, retrievable with 'env'++  , statsRef     :: {-# UNPACK #-} !(IORef Stats)+      -- ^ statistics, collected according to the 'report' level in 'flags'.++  , statsBatchIdRef :: {-# UNPACK #-} !(IORef Int)+     -- ^ keeps track of a Unique ID for each batch dispatched with stats+     -- enabled, for aggregating after.++  , callIdRef :: {-# UNPACK #-} !(IORef CallId)+     -- ^ keeps track of a Unique ID for each fetch/memo.++  , profCurrent    :: ProfileCurrent+     -- ^ current profiling label, see 'withLabel'++  , profRef      :: {-# UNPACK #-} !(IORef Profile)+      -- ^ profiling data, collected according to the 'report' level in 'flags'.++  , states       :: StateStore+      -- ^ Data sources and other components can store their state in+      -- here. Items in this store must be instances of 'StateKey'.++  , reqStoreRef :: {-# UNPACK #-} !(IORef (RequestStore u))+       -- ^ The set of requests that we have not submitted to data sources yet.+       -- Owned by the scheduler.++  , runQueueRef :: {-# UNPACK #-} !(IORef (JobList u w))+       -- ^ runnable computations. Things get added to here when we wake up+       -- a computation that was waiting for something.  When the list is+       -- empty, either we're finished, or we're waiting for some data fetch+       -- to return.++  , submittedReqsRef :: {-# UNPACK #-} !(IORef ReqCountMap)+       -- ^ all outgone fetches which haven't yet returned. Entries are+       -- removed from this map as the fetches finish. This field is+       -- useful for tracking outgone fetches to detect downstream+       -- failures.++  , completions :: {-# UNPACK #-} !(TVar [CompleteReq u w])+       -- ^ Requests that have completed.  Modified by data sources+       -- (via putResult) and the scheduler.  Waiting for this list to+       -- become non-empty is how the scheduler blocks waiting for+       -- data fetches to return.++  , writeLogsRef :: {-# UNPACK #-} !(IORef w)+       -- ^ A log of all writes done as part of this haxl computation. Any+       -- haxl computation that needs to be memoized runs in its own+       -- environment so that we can get a hold of those writes and put them+       -- in the IVar associated with the compuatation.+  , writeLogsRefNoMemo :: {-# UNPACK #-} !(IORef w)+       -- ^ This is just a specialized version of @writeLogsRef@, where we put+       -- logs that user doesn't want memoized. This is a better alternative to+       -- doing arbitrary IO from a (memoized) Haxl computation.++  , dataCacheFetchFallback :: !(Maybe (DataCacheLookup w))+       -- ^ Allows you to inject a DataCache lookup just before a dataFetch is+       -- dispatched. This is useful for injecting fetch results in testing.++#ifdef PROFILING+  , callGraphRef ::  Maybe (IORef CallGraph)+       -- ^ An edge list representing the current function call graph. The type+       -- is wrapped in a Maybe to avoid changing the existing callsites.++  , currFunction :: QualFunction+       -- ^ The most recent function call.+#endif+  }++data ProfileCurrent = ProfileCurrent+  { profCurrentKey ::  {-# UNPACK #-} !ProfileKey+  , profLabelStack :: {-# UNPACK #-} !(NonEmpty ProfileLabel)+  }++type Caches u w = (HaxlDataCache u w, HaxlDataCache u w)++caches :: Env u w -> Caches u w+caches env = (dataCache env, memoCache env)++getMaxCallId :: HaxlDataCache u w -> IO (Maybe Int)+getMaxCallId c = do+  callIds  <- rights . concatMap snd <$>+              DataCache.readCache c (\(DataCacheItem _ i) -> return i)+  case callIds of+    [] -> return Nothing+    vals -> return $ Just (maximum vals)+++-- | Initialize an environment with a 'StateStore', an input map, a+-- preexisting 'DataCache', and a seed for the random number generator.+initEnvWithData :: Monoid w => StateStore -> u -> Caches u w -> IO (Env u w)+initEnvWithData states e (dcache, mcache) = do+  newCid <- max <$>+    (maybe 0 ((+) 1) <$> getMaxCallId dcache) <*>+    (maybe 0 ((+) 1) <$> getMaxCallId mcache)+  ciref<- newIORef newCid+  sref <- newIORef emptyStats+  sbref <- newIORef 0+  pref <- newIORef emptyProfile+  rs <- newIORef noRequests          -- RequestStore+  rq <- newIORef JobNil              -- RunQueue+  sr <- newIORef emptyReqCounts      -- SubmittedReqs+  comps <- newTVarIO []              -- completion queue+  wl <- newIORef mempty+  wlnm <- newIORef mempty+  return Env+    { dataCache = dcache+    , memoCache = mcache+    , memoKey = (-1)+    , flags = defaultFlags+    , userEnv = e+    , states = states+    , statsRef = sref+    , statsBatchIdRef = sbref+    , profCurrent = ProfileCurrent 0 $ "MAIN" :| []+    , callIdRef = ciref+    , profRef = pref+    , reqStoreRef = rs+    , runQueueRef = rq+    , submittedReqsRef = sr+    , completions = comps+    , writeLogsRef = wl+    , writeLogsRefNoMemo = wlnm+    , dataCacheFetchFallback = Nothing+#ifdef PROFILING+    , callGraphRef = Nothing+    , currFunction = mainFunction+#endif+    }++-- | Initializes an environment with 'StateStore' and an input map.+initEnv :: Monoid w => StateStore -> u -> IO (Env u w)+initEnv states e = do+  dcache <- emptyDataCache+  mcache <- emptyDataCache+  initEnvWithData states e (dcache, mcache)++-- | A new, empty environment.+emptyEnv :: Monoid w => u -> IO (Env u w)+emptyEnv = initEnv stateEmpty++-- | If you're using the env from a failed Haxl computation in a second Haxl+-- computation, it is recommended to sanitize the Env to remove all empty+-- IVars - especially if it's possible the first Haxl computation could've+-- been interrupted via an async exception. This is because if the Haxl+-- computation was interrupted by an exception, it's possible that there are+-- entries in the cache which are still blocked, while the results from+-- outgone fetches have been discarded.+sanitizeEnv :: Env u w -> IO (Env u w)+sanitizeEnv env@Env{..} = do+  sanitizedDC <- DataCache.filter isIVarFull dataCache+  sanitizedMC <- DataCache.filter isIVarFull memoCache+  rs <- newIORef noRequests          -- RequestStore+  rq <- newIORef JobNil              -- RunQueue+  comps <- newTVarIO []              -- completion queue+  sr <- newIORef emptyReqCounts      -- SubmittedReqs+  return env+    { dataCache = sanitizedDC+    , memoCache = sanitizedMC+    , reqStoreRef = rs+    , runQueueRef = rq+    , completions = comps+    , submittedReqsRef = sr+    }+  where+  isIVarFull (DataCacheItem IVar{..} _) = do+    ivarContents <- readIORef ivarRef+    case ivarContents of+      IVarFull _ -> return True+      _ -> return False++-- -----------------------------------------------------------------------------+-- WriteTree++-- | A tree of writes done during a Haxl computation. We could use a simple+-- list, but this allows us to avoid multiple mappends when concatenating+-- writes from two haxl computations.+--+-- Users should try to treat this data type as opaque, and prefer+-- to use @flattenWT@ to get a simple list of writes from a @WriteTree@.+data WriteTree w+  = NilWrites+  | SomeWrite w+  | MergeWrites (WriteTree w) (WriteTree w)+  deriving (Show)++instance Semigroup (WriteTree w) where+  (<>) = appendWTs++instance Monoid (WriteTree w) where+  mempty = NilWrites++appendWTs :: WriteTree w -> WriteTree w -> WriteTree w+appendWTs NilWrites w = w+appendWTs w NilWrites = w+appendWTs w1 w2 = MergeWrites w1 w2++-- This function must be called at the end of the Haxl computation to get+-- a list of writes.+-- Haxl provides no guarantees on the order of the returned logs.+flattenWT :: WriteTree w -> [w]+flattenWT = go []+  where+    go !ws NilWrites = ws+    go !ws (SomeWrite w) = w : ws+    go !ws (MergeWrites w1 w2) = go (go ws w2) w1++-- This is a convenience wrapper over modifyIORef, which only modifies+-- writeLogsRef IORef, for non NilWrites.+mbModifyWLRef :: WriteTree w -> IORef (WriteTree w) -> IO ()+mbModifyWLRef NilWrites _ = return ()+mbModifyWLRef !wt ref = modifyIORef' ref (`appendWTs` wt)++mapWriteTree :: (w -> w) -> WriteTree w -> WriteTree w+mapWriteTree _ NilWrites = NilWrites+mapWriteTree f (SomeWrite w) = SomeWrite (f w)+mapWriteTree f (MergeWrites wt1 wt2) =+  MergeWrites (mapWriteTree f wt1) (mapWriteTree f wt2)++-- -----------------------------------------------------------------------------+-- | The Haxl monad, which does several things:+--+--  * It is a reader monad for 'Env', which contains the current state+--    of the scheduler, including unfetched requests and the run queue+--    of computations.+--+--  * It is a writer monad for 'WriteTree'. These can be used to do+--    arbitrary "logs" from any Haxl computation. These are better than+--    doing arbitrary IO from a Haxl computation as these writes also get+--    memoized if the Haxl computation associated with them is memoized.+--    Now if this memoized computation is run again, you'll get the writes+--    twice.++--  * 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 w a = GenHaxl+  { unHaxl :: Env u w -> IO (Result u w a) }++tellWrite :: w -> GenHaxl u (WriteTree w) ()+tellWrite = write . SomeWrite++write :: Monoid w => w -> GenHaxl u w ()+write wt = GenHaxl $ \Env{..} -> do+  modifyIORef' writeLogsRef (<> wt)+  return $ Done ()++tellWriteNoMemo :: w -> GenHaxl u (WriteTree w) ()+tellWriteNoMemo = writeNoMemo . SomeWrite++writeNoMemo :: Monoid w => w -> GenHaxl u w ()+writeNoMemo wt = GenHaxl $ \Env{..} -> do+  modifyIORef' writeLogsRefNoMemo (<> wt)+  return $ Done ()+++instance IsString a => IsString (GenHaxl u w a) where+  fromString s = return (fromString s)++-- -----------------------------------------------------------------------------+-- JobList++-- | A list of computations together with the IVar into which they+-- should put their result.+--+-- This could be an ordinary list, but the optimised representation+-- saves space and time.+--+data JobList u w+ = JobNil+ | forall a . JobCons+     (Env u w)          -- See Note [make withEnv work] below.+     (GenHaxl u w a)+     {-# UNPACK #-} !(IVar u w a)+     (JobList u w)++-- Note [make withEnv work]+--+-- The withEnv operation supplies a new Env for the scope of a GenHaxl+-- computation.  The problem is that the computation might be split+-- into pieces and put onto various JobLists, so we have to be sure to+-- use the correct Env when we execute the pieces. Furthermore, if one+-- of these pieces blocks and gets run again later, we must ensure to+-- restart it with the correct Env.  So we stash the Env along with+-- the continuation in the JobList.++appendJobList :: JobList u w -> JobList u w -> JobList u w+appendJobList JobNil c = c+appendJobList c JobNil = c+appendJobList (JobCons a b c d) e = JobCons a b c $! appendJobList d e++lengthJobList :: JobList u w -> Int+lengthJobList JobNil = 0+lengthJobList (JobCons _ _ _ j) = 1 + lengthJobList j+++-- -----------------------------------------------------------------------------+-- IVar++-- | A synchronisation point.  It either contains a value, or a list+-- of computations waiting for the value.+#ifdef PROFILING+data IVar u w a = IVar+  { ivarRef :: {-# UNPACK #-} !(IORef (IVarContents u w a))+  , ivarCCS :: {-# UNPACK #-} !(Ptr CostCentreStack)+#else+newtype IVar u w a = IVar+  { ivarRef :: IORef (IVarContents u w a)+#endif+  }++data IVarContents u w a+  = IVarFull (ResultVal a w)+  | IVarEmpty (JobList u w)+    -- morally this is a list of @a -> GenHaxl u w ()@, but instead of+    -- using a function, each computation begins with `getIVar` to grab+    -- the value it is waiting for.  This is less type safe but a little+    -- faster (benchmarked with tests/MonadBench.hs).++newIVar :: IO (IVar u w a)+newIVar = do+  ivarRef <- newIORef (IVarEmpty JobNil)+#ifdef PROFILING+  ivarCCS <- getCurrentCCS ivarRef+#endif+  return IVar{..}++newFullIVar :: ResultVal a w -> IO (IVar u w a)+newFullIVar r = do+  ivarRef <- newIORef (IVarFull r)+#ifdef PROFILING+  ivarCCS <- getCurrentCCS ivarRef+#endif+  return IVar{..}++withCurrentCCS :: IVar u w a -> IO (IVar u w a)+#ifdef PROFILING+withCurrentCCS ivar = do+  ccs <- getCurrentCCS ivar+  return ivar{ivarCCS = ccs}+#else+withCurrentCCS = return+#endif++getIVar :: IVar u w a -> GenHaxl u w a+getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \env -> do+  e <- readIORef ref+  case e of+    IVarFull (Ok a _wt) -> return (Done a)+    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e+    IVarFull (ThrowIO e) -> throwIO e+    IVarEmpty _ -> return (Blocked i (Return i))++-- Just a specialised version of getIVar, for efficiency in <*>+getIVarApply :: IVar u w (a -> b) -> a -> GenHaxl u w b+getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \env -> do+  e <- readIORef ref+  case e of+    IVarFull (Ok f _wt) -> return (Done (f a))+    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e+    IVarFull (ThrowIO e) -> throwIO e+    IVarEmpty _ ->+      return (Blocked i (Cont (getIVarApply i a)))++-- Another specialised version of getIVar, for efficiency in cachedComputation+getIVarWithWrites :: Monoid w => IVar u w a -> GenHaxl u w a+getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \env@Env{..} -> do+  e <- readIORef ref+  case e of+    IVarFull (Ok a wt) -> do+      modifyIORef' writeLogsRef (<> fromMaybe mempty wt)+      return (Done a)+    IVarFull (ThrowHaxl e wt) -> do+      modifyIORef' writeLogsRef (<> fromMaybe mempty wt)+      raiseFromIVar env i e+    IVarFull (ThrowIO e) -> throwIO e+    IVarEmpty _ ->+      return (Blocked i (Cont (getIVarWithWrites i)))++putIVar :: IVar u w a -> ResultVal a w -> Env u w -> IO ()+putIVar IVar{ivarRef = !ref} a Env{..} = do+  e <- readIORef ref+  case e of+    IVarEmpty jobs -> do+      writeIORef ref (IVarFull a)+      modifyIORef' runQueueRef (appendJobList jobs)+      -- An IVar is typically only meant to be written to once+      -- so it would make sense to throw an error here. But there+      -- are legitimate use-cases for writing several times.+      -- (See Haxl.Core.Parallel)+    IVarFull{} -> return ()++{-# INLINE addJob #-}+addJob :: Env u w -> GenHaxl u w b -> IVar u w b -> IVar u w a -> IO ()+addJob env !haxl !resultIVar IVar{ivarRef = !ref} =+  modifyIORef' ref $ \contents ->+    case contents of+      IVarEmpty list -> IVarEmpty (JobCons env haxl resultIVar list)+      _ -> addJobPanic++addJobPanic :: forall a . a+addJobPanic = error "addJob: not empty"+++-- -----------------------------------------------------------------------------+-- ResultVal++-- | The contents of a full IVar.  We have to distinguish exceptions+-- thrown in the IO monad from exceptions thrown in the Haxl monad, so+-- that when the result is fetched using getIVar, we can throw the+-- exception in the right way.+data ResultVal a w+  = Ok a (Maybe w)+  | ThrowHaxl SomeException (Maybe w)+  | ThrowIO SomeException+    -- we get no write logs when an IO exception occurs++done :: Env u w -> ResultVal a w -> IO (Result u w a)+done _ (Ok a _) = return (Done a)+done env (ThrowHaxl e _) = raise env e+done _ (ThrowIO e) = throwIO e++eitherToResultThrowIO :: Either SomeException a -> ResultVal a w+eitherToResultThrowIO (Right a) = Ok a Nothing+eitherToResultThrowIO (Left e)+  | Just HaxlException{} <- fromException e = ThrowHaxl e Nothing+  | otherwise = ThrowIO e++eitherToResult :: Either SomeException a -> ResultVal a w+eitherToResult (Right a) = Ok a Nothing+eitherToResult (Left e) = ThrowHaxl e Nothing+++-- -----------------------------------------------------------------------------+-- CompleteReq++-- | A completed request from a data source, containing the result,+-- and the 'IVar' representing the blocked computations.  The job of a+-- data source is just to add these to a queue ('completions') using+-- 'putResult'; the scheduler collects them from the queue and unblocks+-- the relevant computations.+data CompleteReq u w+  = forall a . CompleteReq+      (ResultVal a w)+      !(IVar u w a)  -- IVar because the result is cached+      {-# UNPACK #-} !Int64 -- see Note [tracking allocation in child threads]+++{- Note [tracking allocation in child threads]++For a BackgroundFetch, we might be doing some of the work in a+separate thread, but we want to make sure that the parent thread gets+charged for the allocation, so that allocation limits still work.++The design is a bit tricky here.  We want to track the allocation+accurately but without adding much overhead.++The best way to propagate the allocation back from the child thread is+through putResult.  If we had some other method, we would also need a+way to synchronise it with the main runHaxl loop; the advantage of+putResult is that this is already a synchronisation method, because+runHaxl is waiting for the result of the dataFetch.++We need a special version of putResult for child threads+(putResultFromChildThread), because we don't want to propagate any+allocation from the runHaxl thread back to itself and count it twice.++We also want to capture the allocation as late as possible, so that we+count everything.  For that reason, we pass a Bool down from putResult+into the function in the ResultVar, and it reads the allocation+counter as the last thing before adding the result to the completions+TVar.++The other problem to consider is how to capture the allocation when+the child thread is doing multiple putResults.  Our solution here is+to ensure that the *last* one is a putResultFromChildThread, so it+captures all the allocation from everything leading up to it.++Why not reset the counter each time, so we could do multiple+putResultFromChildThreads?  Because the child thread might be using an+allocation limit itself, and changing the counter would mess it up.+-}++-- -----------------------------------------------------------------------------+-- Result++-- | 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 w a+  = Done a+  | Throw SomeException+  | forall b . Blocked+      {-# UNPACK #-} !(IVar u w b)+      (Cont u w a)+         -- ^ The 'IVar' is what we are blocked on; 'Cont' is the+         -- continuation.  This might be wrapped further if we're+         -- nested inside multiple '>>=', before finally being added+         -- to the 'IVar'.  Morally @b -> GenHaxl u w a@, but see+         -- 'IVar',++instance (Show a) => Show (Result u w a) where+  show (Done a) = printf "Done(%s)" $ show a+  show (Throw e) = printf "Throw(%s)" $ show e+  show Blocked{} = "Blocked"++instance Functor (Result u w) where+  fmap f (Done a) = Done (f a)+  fmap _ (Throw exc) = Throw exc+  fmap f (Blocked ivar cont) = Blocked ivar (f :<$> cont)++{- Note [Exception]++How do we want to represent Haxl exceptions (those that are thrown by+"throw" in the Haxl monad)?++1) Explicitly via a Throw constructor in the Result type+2) Using throwIO in the IO monad++If we did (2), we would have to use an exception handler in <*>,+because an exception in the right-hand argument of <*> should not+necessarily be thrown by the whole computation - an exception on the+left should get priority, and the left might currently be Blocked.++We must be careful about turning IO monad exceptions into Haxl+exceptions.  An IO monad exception will normally propagate right+out of runHaxl and terminate the whole computation, whereas a Haxl+exception can get dropped on the floor, if it is on the right of+<*> and the left side also throws, for example.  So turning an IO+monad exception into a Haxl exception is a dangerous thing to do.+In particular, we never want to do it for an asynchronous exception+(AllocationLimitExceeded, ThreadKilled, etc.), because these are+supposed to unconditionally terminate the computation.++There are three places where we take an arbitrary IO monad exception and+turn it into a Haxl exception:++ * wrapFetchInCatch.  Here we want to propagate a failure of the+   data source to the callers of the data source, but if the+   failure came from elsewhere (an asynchronous exception), then we+   should just propagate it++ * cacheResult (cache the results of IO operations): again,+   failures of the IO operation should be visible to the caller as+   a Haxl exception, but we exclude asynchronous exceptions from+   this.++ * unsafeToHaxlException: assume the caller knows what they're+   doing, and just wrap all exceptions.+-}+++-- -----------------------------------------------------------------------------+-- Cont++-- | A data representation of a Haxl continuation.  This is to avoid+-- repeatedly traversing a left-biased tree in a continuation, leading+-- O(n^2) complexity for some pathalogical cases - see the "seql" benchmark+-- in tests/MonadBench.hs.+-- See "A Smart View on Datatypes", Jaskelioff/Rivas, ICFP'15+data Cont u w a+  = Cont (GenHaxl u w a)+  | forall b. Cont u w b :>>= (b -> GenHaxl u w a)+  | forall b. (b -> a) :<$> (Cont u w b)+  | Return (IVar u w a)++toHaxl :: Cont u w a -> GenHaxl u w a+toHaxl (Cont haxl) = haxl+toHaxl (m :>>= k) = toHaxlBind m k+toHaxl (f :<$> x) = toHaxlFmap f x+toHaxl (Return i) = getIVar i++toHaxlBind :: Cont u w b -> (b -> GenHaxl u w a) -> GenHaxl u w a+toHaxlBind (m :>>= k) k2 = toHaxlBind m (k >=> k2)+toHaxlBind (Cont haxl) k = haxl >>= k+toHaxlBind (f :<$> x) k = toHaxlBind x (k . f)+toHaxlBind (Return i) k = getIVar i >>= k++toHaxlFmap :: (a -> b) -> Cont u w a -> GenHaxl u w b+toHaxlFmap f (m :>>= k) = toHaxlBind m (k >=> return . f)+toHaxlFmap f (Cont haxl) = f <$> haxl+toHaxlFmap f (g :<$> x) = toHaxlFmap (f . g) x+toHaxlFmap f (Return i) = f <$> getIVar i++-- -----------------------------------------------------------------------------+-- Monad/Applicative instances++instance Monad (GenHaxl u w) where+  return = pure+  GenHaxl m >>= k = GenHaxl $ \env -> do+    e <- m env+    case e of+      Done a -> unHaxl (k a) env+      Throw e -> return (Throw e)+      Blocked ivar cont -> trace_ ">>= Blocked" $+        return (Blocked ivar (cont :>>= k))++  -- We really want the Applicative version of >>+  (>>) = (*>)++#if __GLASGOW_HASKELL__ >= 808+instance CTL.MonadFail (GenHaxl u w) where+#endif+  fail msg = GenHaxl $ \_env ->+    return $ Throw $ toException $ MonadFail $ Text.pack msg++instance Functor (GenHaxl u w) where+  fmap f (GenHaxl m) = GenHaxl $ \env -> do+    r <- m env+    case r of+      Done a -> return (Done (f a))+      Throw e -> return (Throw e)+      Blocked ivar cont -> trace_ "fmap Blocked" $+        return (Blocked ivar (f :<$> cont))++instance Applicative (GenHaxl u w) where+  pure a = GenHaxl $ \_env -> pure (Done a)+  GenHaxl ff <*> GenHaxl aa = GenHaxl $ \env -> do+    rf <- ff env+    case rf of+      Done f -> do+        ra <- aa env+        case ra of+          Done a -> trace_ "Done/Done" $ return (Done (f a))+          Throw e -> trace_ "Done/Throw" $ return (Throw e)+          Blocked ivar fcont -> trace_ "Done/Blocked" $+            return (Blocked ivar (f :<$> fcont))+      Throw e -> trace_ "Throw" $ return (Throw e)+      Blocked ivar1 fcont -> do+        ra <- aa env+        case ra of+          Done a -> trace_ "Blocked/Done" $+            return (Blocked ivar1 (($ a) :<$> fcont))+          Throw e -> trace_ "Blocked/Throw" $+            return (Blocked ivar1 (fcont :>>= (\_ -> throw e)))+          Blocked ivar2 acont -> trace_ "Blocked/Blocked" $+            blockedBlocked env ivar1 fcont ivar2 acont+             -- Note [Blocked/Blocked]++instance Semigroup a => Semigroup (GenHaxl u w a) where+  (<>) = liftA2 (<>)++instance Monoid a => Monoid (GenHaxl u w a) where+  mempty = pure mempty+#if __GLASGOW_HASKELL__ < 804+  mappend = liftA2 mappend+#endif++blockedBlocked+  :: Env u w+  -> IVar u w c+  -> Cont u w (a -> b)+  -> IVar u w d+  -> Cont u w a+  -> IO (Result u w b)+blockedBlocked _ _ (Return i) ivar2 acont =+  return (Blocked ivar2 (acont :>>= getIVarApply i))+blockedBlocked _ _ (g :<$> Return i) ivar2 acont =+  return (Blocked ivar2 (acont :>>= \ a -> (\f -> g f a) <$> getIVar i))+blockedBlocked env ivar1 fcont ivar2 acont = do+  i <- newIVar+  addJob env (toHaxl fcont) i ivar1+  let cont = acont :>>= \a -> getIVarApply i a+  return (Blocked ivar2 cont)++-- Note [Blocked/Blocked]+--+-- This is the tricky case: we're blocked on both sides of the <*>.+-- We need to divide the computation into two pieces that may continue+-- independently when the resources they are blocked on become+-- available.  Moreover, the computation as a whole depends on the two+-- pieces.  It works like this:+--+--   ff <*> aa+--+-- becomes+--+--   (ff >>= putIVar i) <*> (a <- aa; f <- getIVar i; return (f a)+--+-- where the IVar i is a new synchronisation point.  If the right side+-- gets to the `getIVar` first, it will block until the left side has+-- called 'putIVar'.+--+-- We can also do it the other way around:+--+--   (do ff <- f; getIVar i; return (ff a)) <*> (a >>= putIVar i)+--+-- The first was slightly faster according to tests/MonadBench.hs.++++-- -----------------------------------------------------------------------------+-- Env utils++-- | Extracts data from the 'Env'.+env :: (Env u w -> a) -> GenHaxl u w a+env f = GenHaxl $ \env -> return (Done (f env))++-- | Returns a version of the Haxl computation which always uses the+-- provided 'Env', ignoring the one specified by 'runHaxl'.+withEnv :: Env u w -> GenHaxl u w a -> GenHaxl u w a+withEnv newEnv (GenHaxl m) = GenHaxl $ \_env -> do+  r <- m newEnv+  case r of+    Done a -> return (Done a)+    Throw e -> return (Throw e)+    Blocked ivar k ->+      return (Blocked ivar (Cont (withEnv newEnv (toHaxl k))))++nextCallId :: Env u w -> IO CallId+nextCallId env = atomicModifyIORef' (callIdRef env) $ \x -> (x+1,x+1)++-- | Runs the Haxl computation, transforming the writes within using the+-- provided function.+--+-- Memoization behavior is unchanged, meaning if a memoized computation is run+-- once inside @mapWrites@ and then once without, the writes from the second run+-- will NOT be transformed.+mapWrites :: Monoid w => (w -> w) -> GenHaxl u w a -> GenHaxl u w a+mapWrites f action = GenHaxl $ \curEnv -> do+  wlogs <- newIORef mempty+  wlogsNoMemo <- newIORef mempty+  let+    !newEnv = curEnv { writeLogsRef = wlogs, writeLogsRefNoMemo = wlogsNoMemo }+  unHaxl (mapWritesImpl curEnv newEnv action) newEnv+  where+    mapWritesImpl oldEnv curEnv (GenHaxl m) = GenHaxl $ \_ -> do+      let+        pushTransformedWrites = do+          wt <- readIORef $ writeLogsRef curEnv+          modifyIORef' (writeLogsRef oldEnv) (<> f wt)+          wtNoMemo <- readIORef $ writeLogsRefNoMemo curEnv+          modifyIORef' (writeLogsRefNoMemo oldEnv) (<> f wtNoMemo)++      r <- m curEnv++      case r of+        Done a -> pushTransformedWrites >> return (Done a)+        Throw e -> pushTransformedWrites >> return (Throw e)+        Blocked ivar k -> return+          (Blocked ivar (Cont (mapWritesImpl oldEnv curEnv (toHaxl k))))++#ifdef PROFILING+-- -----------------------------------------------------------------------------+-- CallGraph recording++-- | Returns a version of the Haxl computation which records function calls in+-- an edge list which is the function call graph. Each function that is to be+-- recorded must be wrapped with a call to @withCallGraph@.+withCallGraph+  :: Typeable a+  => (a -> Maybe Text)+  -> QualFunction+  -> GenHaxl u w a+  -> GenHaxl u w a+withCallGraph toText f a = do+  coreEnv <- env id+  -- TODO: Handle exceptions+  value <- withEnv coreEnv{currFunction = f} a+  case callGraphRef coreEnv of+    Just graph -> unsafeLiftIO $ modifyIORef' graph+      (updateCallGraph (f, currFunction coreEnv) (toText value))+    _ -> throw $ CriticalError+      "withCallGraph called without an IORef CallGraph"+  return value+  where+    updateCallGraph :: FunctionCall -> Maybe Text -> CallGraph -> CallGraph+    updateCallGraph fnCall@(childQFunc, _) (Just value) (edgeList, valueMap) =+      (fnCall : edgeList, Map.insert childQFunc value valueMap)+    updateCallGraph fnCall Nothing (edgeList, valueMap) =+      (fnCall : edgeList, valueMap)+#endif++-- -----------------------------------------------------------------------------+-- Exceptions++-- | Throw an exception in the Haxl monad+throw :: Exception e => e -> GenHaxl u w a+throw e = GenHaxl $ \env -> raise env e++raise :: Exception e => Env u w -> e -> IO (Result u w a)+raise env e = raiseImpl env (toException e)+#ifdef PROFILING+  currentCallStack+#endif+++raiseFromIVar :: Exception e => Env u w -> IVar u w a -> e -> IO (Result u w b)+#ifdef PROFILING+raiseFromIVar env IVar{..} e =+  raiseImpl env (toException e) (ccsToStrings ivarCCS)+#else+raiseFromIVar env _ivar e = raiseImpl env (toException e)+#endif++{-# INLINE raiseImpl #-}+#ifdef PROFILING+raiseImpl :: Env u w -> SomeException -> IO [String] -> IO (Result u w b)+raiseImpl Env{..} e getCostCentreStack+#else+raiseImpl :: Env u w -> SomeException -> IO (Result u w b)+raiseImpl Env{..} e+#endif+  | testReportFlag ReportExceptionLabelStack $ report flags+  , Just (HaxlException Nothing h) <- fromException e = do+    let stk = NonEmpty.toList $ profLabelStack profCurrent+    return $ Throw $ toException $ HaxlException (Just stk) h+#ifdef PROFILING+  | Just (HaxlException Nothing h) <- fromException e = do+    stk <- reverse . map Text.pack <$> getCostCentreStack+    return $ Throw $ toException $ HaxlException (Just stk) h+#endif+  | otherwise = return $ Throw e++-- | Catch an exception in the Haxl monad+catch :: Exception e => GenHaxl u w a -> (e -> GenHaxl u w a) -> GenHaxl u w a+catch (GenHaxl m) h = GenHaxl $ \env -> do+   r <- m env+   case r of+     Done a    -> return (Done a)+     Throw e | Just e' <- fromException e -> unHaxl (h e') env+             | otherwise -> return (Throw e)+     Blocked ivar k -> return (Blocked ivar (Cont (catch (toHaxl k) h)))++-- | Catch exceptions that satisfy a predicate+catchIf+  :: Exception e => (e -> Bool) -> GenHaxl u w a -> (e -> GenHaxl u w a)+  -> GenHaxl u w a+catchIf cond haxl handler =+  catch haxl $ \e -> if cond e then handler e else throw e++-- | Returns @'Left' e@ if the computation throws an exception @e@, or+-- @'Right' a@ if it returns a result @a@.+try :: Exception e => GenHaxl u w a -> GenHaxl u w (Either e a)+try haxl = (Right <$> haxl) `catch` (return . Left)++-- | @since 0.3.1.0+instance Catch.MonadThrow (GenHaxl u w) where throwM = Haxl.Core.Monad.throw+-- | @since 0.3.1.0+instance Catch.MonadCatch (GenHaxl u w) where catch = Haxl.Core.Monad.catch+++-- -----------------------------------------------------------------------------+-- Unsafe operations++-- | Under ordinary circumstances this is unnecessary; users of the Haxl+-- monad should generally /not/ perform arbitrary IO.+unsafeLiftIO :: IO a -> GenHaxl u w a+unsafeLiftIO m = GenHaxl $ \_env -> 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.+--+-- Note: this function does not catch async exceptions. This is a flaw in Haxl+-- where it can sometimes leave the environment in a bad state when async+-- exceptions are thrown (for example the cache may think a fetch is happening+-- but the exception has stopped it). TODO would be to make Haxl async exception+-- safe and then remove the rethrowAsyncExceptions below, but for now this is+-- safer to avoid bugs. Additionally this would not protect you from async+-- exceptions thrown while executing code in the scheduler, and so relying on+-- this function to catch all async exceptions would be ambitious at best.+unsafeToHaxlException :: GenHaxl u w a -> GenHaxl u w a+unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env -> do+  r <- m env `Exception.catch` \e -> do+    rethrowAsyncExceptions e+    return (Throw e)+  case r of+    Blocked cvar c ->+      return (Blocked cvar (Cont (unsafeToHaxlException (toHaxl 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 w a -> GenHaxl u w (Either HaxlException a)+tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)+++-- -----------------------------------------------------------------------------++-- | 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 w ()+-- > loadCache = do+-- >   cacheRequest (ListWombats 3) (Right ([1,2,3]))+-- >   cacheRequest (CountAardvarks "abcabc") (Right (2))+--+dumpCacheAsHaskell :: GenHaxl u w String+dumpCacheAsHaskell =+    dumpCacheAsHaskellFn "loadCache" "GenHaxl u w ()" "cacheRequest"++-- | Dump the contents of the cache as Haskell code that, when+-- compiled and run, will recreate the same cache contents.+-- Does not take into account the writes done as part of the computation.+--+-- Takes the name and type for the resulting function as arguments.+-- Also takes the cacheFn to use, we can use either @cacheRequest@ or+-- @dupableCacheRequest@.+dumpCacheAsHaskellFn :: String -> String -> String -> GenHaxl u w String+dumpCacheAsHaskellFn fnName fnType cacheFn = do+  cache <- env dataCache  -- NB. dataCache, not memoCache.  We ignore memoized+                       -- results when dumping the cache.+  let+    readIVar (DataCacheItem IVar{ivarRef = !ref} _) = do+      r <- readIORef ref+      case r of+        IVarFull (Ok a _) -> return (Just (Right a))+        IVarFull (ThrowHaxl e _) -> return (Just (Left e))+        IVarFull (ThrowIO e) -> return (Just (Left e))+        IVarEmpty _ -> return Nothing++    mk_cr (req, res) =+      text cacheFn <+> parens (text req) <+> parens (result res)+    result (Left e) = text "except" <+> parens (text (show e))+    result (Right s) = text "Right" <+> parens (text s)++  entries <- unsafeLiftIO $ do+    showCache cache readIVar++  let+    body = if null entries+      then text "return ()"+      else vcat (map mk_cr (concatMap snd entries))++  return $ show $+    text (fnName ++ " :: " ++ fnType) $$+    text (fnName ++ " = do") $$+      nest 2 body $$     text "" -- final newline
+ Haxl/Core/Parallel.hs view
@@ -0,0 +1,153 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Psuedo-parallel operations.  Most users should import "Haxl.Core"+-- instead.+--+module Haxl.Core.Parallel+  ( -- * Parallel operations+    biselect+  , pAnd+  , pOr+  , unsafeChooseFirst+  ) where++import Haxl.Core.Monad hiding (catch, throw)+import Haxl.Core.Exception++import Control.Exception (throw)++-- -----------------------------------------------------------------------------+-- Parallel operations++-- Bind more tightly than .&&, .||+infixr 5 `pAnd`+infixr 4 `pOr`+++biselect :: GenHaxl u w (Either a b)+         -> GenHaxl u w (Either a c)+         -> GenHaxl u w (Either a (b,c))+biselect haxla haxlb = biselect_opt id id Left Right haxla haxlb++{-# INLINE biselect_opt #-}+biselect_opt :: (l -> Either a b)+             -> (r -> Either a c)+             -> (a -> t)+             -> ((b,c) -> t)+             -> GenHaxl u w l+             -> GenHaxl u w r+             -> GenHaxl u w t+biselect_opt discrimA discrimB left right haxla haxlb =+  let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env -> do+        ra <- haxla env+        case ra of+          Done ea ->+            case discrimA ea of+              Left a -> return (Done (left a))+              Right b -> do+                  rb <- haxlb env+                  case rb of+                    Done eb ->+                      case discrimB eb of+                        Left a -> return (Done (left a))+                        Right c -> return (Done (right (b,c)))+                    Throw e -> return (Throw e)+                    Blocked ib haxlb' ->+                      return (Blocked ib+                              (haxlb' :>>= \b' -> go_right b b'))+          Throw e -> return (Throw e)+          Blocked ia haxla' -> do+            rb <- haxlb env+            case rb of+              Done eb ->+                case discrimB eb of+                  Left a -> return (Done (left a))+                  Right c ->+                     return (Blocked ia+                             (haxla' :>>= \a' -> go_left a' c))+              Throw e -> return (Throw e)+              Blocked ib haxlb' -> do+                i <- newIVar+                addJob env (return ()) i ia+                addJob env (return ()) i ib+                return (Blocked i (Cont (go (toHaxl haxla') (toHaxl haxlb'))))+                -- The code above makes sure that the computation+                -- wakes up whenever either 'ia' or 'ib' is filled.+                -- The ivar 'i' is used as a synchronisation point+                -- for the whole computation, and we make sure that+                -- whenever 'ia' or 'ib' are filled in then 'i' will+                -- also be filled.++      go_right b eb =+        case discrimB eb of+          Left a -> return (left a)+          Right c -> return (right (b,c))+      go_left ea c =+        case discrimA ea of+          Left a -> return (left a)+          Right b -> return (right (b,c))+  in go haxla haxlb++-- | Parallel version of '(.||)'.  Both arguments are evaluated in+-- parallel, and if either returns 'True' then the other is+-- not evaluated any further.+--+-- WARNING: exceptions may be unpredictable when using 'pOr'.  If one+-- argument returns 'True' before the other completes, then 'pOr'+-- returns 'True' immediately, ignoring a possible exception that+-- the other argument may have produced if it had been allowed to+-- complete.+pOr :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool+pOr x y = biselect_opt discrim discrim left right x y+  where+    discrim True = Left ()+    discrim False = Right ()+    left _ = True+    right _ = False++-- | Parallel version of '(.&&)'.  Both arguments are evaluated in+-- parallel, and if either returns 'False' then the other is+-- not evaluated any further.+--+-- WARNING: exceptions may be unpredictable when using 'pAnd'.  If one+-- argument returns 'False' before the other completes, then 'pAnd'+-- returns 'False' immediately, ignoring a possible exception that+-- the other argument may have produced if it had been allowed to+-- complete.+pAnd :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool+pAnd x y = biselect_opt discrim discrim left right x y+  where+    discrim False = Left ()+    discrim True = Right ()+    left _ = False+    right _ = True++-- | This function takes two haxl computations as input, and returns the+-- output of whichever computation finished first. This is clearly+-- non-deterministic in its output and exception behavior, be careful when+-- using it.+unsafeChooseFirst+  :: GenHaxl u w a+  -> GenHaxl u w b+  -> GenHaxl u w (Either a b)+unsafeChooseFirst x y = biselect_opt discrimx discrimy id right x y+  where+    discrimx :: a -> Either (Either a b) ()+    discrimx a = Left (Left a)++    discrimy :: b -> Either (Either a b) ()+    discrimy b = Left (Right b)++    right _ = throw $ CriticalError+      "unsafeChooseFirst: We should never have a 'Right ()'"
+ Haxl/Core/Profile.hs view
@@ -0,0 +1,244 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Implementation of lightweight profiling.  Most users should+-- import "Haxl.Core" instead.+--+module Haxl.Core.Profile+  ( withLabel+  , withFingerprintLabel+  , addProfileFetch+  , incrementMemoHitCounterFor+  , collectProfileData+  , profileCont+  ) where++import Data.IORef+import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..), (<|))+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif+import Data.Typeable+import qualified Data.HashMap.Strict as HashMap+import GHC.Exts+import qualified Data.Text as Text+import Haxl.Core.DataSource+import Haxl.Core.Flags+import Haxl.Core.Stats+import Haxl.Core.Monad++-- -----------------------------------------------------------------------------+-- Profiling++-- | Label a computation so profiling data is attributed to the label.+withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a+withLabel l (GenHaxl m) = GenHaxl $ \env ->+  if not $ testReportFlag ReportProfiling $ report $ flags env+     then m env+     else collectProfileData l m env++-- | Label a computation so profiling data is attributed to the label.+-- Intended only for internal use by 'memoFingerprint'.+withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a+withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->+  if not $ testReportFlag ReportProfiling $ report $ flags env+     then m env+     else collectProfileData+            (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)+            m env++-- | Collect profiling data and attribute it to given label.+collectProfileData+  :: ProfileLabel+  -> (Env u w -> IO (Result u w a))+  -> Env u w+  -> IO (Result u w a)+collectProfileData l m env = do+  let ProfileCurrent prevProfKey (prevProfLabel :| _) = profCurrent env+  if prevProfLabel == l+  then+    -- do not add a new label if we are recursing+    m env+  else do+    key <- atomicModifyIORef' (profRef env) $ \p ->+      case HashMap.lookup (l, prevProfKey) (profileTree p) of+        Just k -> (p, k)+        Nothing -> (p+          { profileTree = HashMap.insert+            (l, prevProfKey)+            (profileNextKey p)+            (profileTree p)+          , profileNextKey = profileNextKey p + 1 }, profileNextKey p)+    runProfileData l key m False env+{-# INLINE collectProfileData #-}++runProfileData+  :: ProfileLabel+  -> ProfileKey+  -> (Env u w -> IO (Result u w a))+  -> Bool+  -> Env u w+  -> IO (Result u w a)+runProfileData l key m isCont env = do+  t0 <- getTimestamp+  a0 <- getAllocationCounter+  let+    ProfileCurrent caller stack = profCurrent env+    nextCurrent = ProfileCurrent+      { profCurrentKey = key+      , profLabelStack = l <| stack+      }+    runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True++  r <- m env{profCurrent=nextCurrent} -- what if it throws?++  -- Make the result strict in Done/Throw so that if the user code+  -- returns (force a), the force is evaluated *inside* the profile.+  result <- case r of+    Done !a -> return (Done a)+    Throw !e -> return (Throw e)+    Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k)))++  a1 <- getAllocationCounter+  t1 <- getTimestamp++  -- caller might not be the actual caller of this function+  -- for example MAIN may be continuing a function from the middle of the stack.+  -- But this is what we want as we need to account for allocations.+  -- So do not be tempted to pass through prevProfKey (from collectProfileData)+  -- which is the original caller+  modifyProfileData env key caller (a0 - a1) (t1-t0) (if isCont then 0 else 1)++  -- So we do not count the allocation overhead of modifyProfileData+  setAllocationCounter a1+  return result+{-# INLINE runProfileData #-}++modifyProfileData+  :: Env u w+  -> ProfileKey+  -> ProfileKey+  -> AllocCount+  -> Microseconds+  -> LabelHitCount+  -> IO ()+modifyProfileData env key caller allocs t labelIncrement = do+  modifyIORef' (profRef env) $ \ p ->+    p { profile =+          HashMap.insertWith updEntry key newEntry .+          HashMap.insertWith updCaller caller newCaller $+          profile p }+  where newEntry =+          emptyProfileData+            { profileAllocs = allocs+            , profileLabelHits = labelIncrement+            , profileTime = t+            }+        updEntry _ old =+          old+            { profileAllocs = profileAllocs old + allocs+            , profileLabelHits = profileLabelHits old + labelIncrement+            , profileTime = profileTime old + t+            }+        -- subtract allocs/time from caller, so they are not double counted+        -- we don't know the caller's caller, but it will get set on+        -- the way back out, so an empty hashset is fine for now+        newCaller =+          emptyProfileData { profileAllocs = -allocs+                           , profileTime = -t+                           }+        updCaller _ old =+          old { profileAllocs = profileAllocs old - allocs+              , profileTime = profileTime old - t+              }+++-- Like collectProfileData, but intended to be run from the scheduler.+--+-- * doesn't add a dependency (the original withLabel did this)+--+-- * doesn't subtract allocs from the caller (we're evaluating this+--   cont from the top level, so we don't need this)+--+-- * doesn't wrap a Blocked continuation in withLabel (the scheduler+--   will call profileCont the next time this cont runs)+--+profileCont+  :: (Env u w -> IO (Result u w a))+  -> Env u w+  -> IO (Result u w a)+profileCont m env = do+  t0 <- getTimestamp+  a0 <- getAllocationCounter+  r <- m env+  a1 <- getAllocationCounter+  t1 <- getTimestamp+  let+    allocs = a0 - a1+    t = t1 - t0+    newEntry = emptyProfileData+      { profileAllocs = allocs+      , profileTime = t+      }+    updEntry _ old = old+      { profileAllocs = profileAllocs old + allocs+      , profileTime = profileTime old + t+      }+    profKey = profCurrentKey (profCurrent env)+  modifyIORef' (profRef env) $ \ p ->+    p { profile =+         HashMap.insertWith updEntry profKey newEntry $+         profile p }+  -- So we do not count the allocation overhead of modifyProfileData+  setAllocationCounter a1+  return r+{-# INLINE profileCont #-}++incrementMemoHitCounterFor :: Env u w -> CallId -> Bool -> IO ()+incrementMemoHitCounterFor env callId wasCached = do+  modifyIORef' (profRef env) $ \p ->  p {+    profile = HashMap.insertWith+                upd+                (profCurrentKey $ profCurrent env)+                (emptyProfileData { profileMemos = [val] })+                (profile p)+    }+  where+    val = ProfileMemo callId wasCached+    upd _ old = old { profileMemos = val : profileMemos old }++{-# NOINLINE addProfileFetch #-}+addProfileFetch+  :: forall r u w a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a))+  => Env u w -> r a -> CallId -> Bool -> IO ()+addProfileFetch env _req cid wasCached = do+  c <- getAllocationCounter+  let (ProfileCurrent profKey _) = profCurrent env+  modifyIORef' (profRef env) $ \ p ->+    let+      val = ProfileFetch cid (memoKey env) wasCached+      upd _ old = old { profileFetches = val : profileFetches old }++    in p { profile =+           HashMap.insertWith+             upd+             profKey+             (emptyProfileData { profileFetches = [val] })+             (profile p)+         }+  -- So we do not count the allocation overhead of addProfileFetch+  setAllocationCounter c
Haxl/Core/RequestStore.hs view
@@ -1,14 +1,16 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-} -- | Bucketing requests by 'DataSource'. -- -- When a request is issued by the client via 'dataFetch', it is placed@@ -16,14 +18,35 @@ -- of requests, the 'contents' operation extracts the fetches, bucketed -- by 'DataSource'. ---module Haxl.Core.RequestStore (-    BlockedFetches(..), RequestStore,-    noRequests, addRequest, contents+-- This module is provided for access to Haxl internals only; most+-- users should not need to import it.+--+module Haxl.Core.RequestStore+  ( BlockedFetches(..)+  , BlockedFetchInternal(..)+  , RequestStore+  , isEmpty+  , noRequests+  , addRequest+  , contents+  , getSize+  , ReqCountMap(..)+  , emptyReqCounts+  , filterRCMap+  , getMapFromRCMap+  , getSummaryMapFromRCMap+  , addToCountMap+  , subFromCountMap   ) where -import Haxl.Core.Types+import Haxl.Core.DataSource+import Haxl.Core.Stats import Data.Map (Map)+import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map+import Data.Proxy+import Data.Text (Text)+import Data.Kind (Type) import Data.Typeable import Unsafe.Coerce @@ -33,10 +56,16 @@   -- is dynamically-typed.  It maps the TypeRep of the request to the   -- 'BlockedFetches' for that 'DataSource'. +newtype BlockedFetchInternal = BlockedFetchInternal CallId+ -- | A batch of 'BlockedFetch' objects for a single 'DataSource' data BlockedFetches u =-  forall r. (DataSource u r) => BlockedFetches [BlockedFetch r]+  forall r. (DataSource u r) =>+        BlockedFetches [BlockedFetch r] [BlockedFetchInternal] +isEmpty :: RequestStore u -> Bool+isEmpty (RequestStore m) = Map.null m+ -- | A new empty 'RequestStore'. noRequests :: RequestStore u noRequests = RequestStore Map.empty@@ -44,13 +73,13 @@ -- | 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+  => BlockedFetch r -> BlockedFetchInternal -> RequestStore u -> RequestStore u+addRequest bf bfi (RequestStore m) =+  RequestStore $ Map.insertWith combine ty (BlockedFetches [bf] [bfi]) m  where   combine :: BlockedFetches u -> BlockedFetches u -> BlockedFetches u-  combine _ (BlockedFetches bfs)-    | typeOf1 (getR bfs) == ty = BlockedFetches (unsafeCoerce bf:bfs)+  combine _ (BlockedFetches bfs bfis)+    | typeOf1 (getR bfs) == ty = BlockedFetches (unsafeCoerce bf:bfs) (bfi:bfis)     | 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@@ -63,8 +92,79 @@    -- The TypeRep of requests for this data source   ty :: TypeRep-  ty = typeOf1 (undefined :: r a)+  !ty = typeOf1 (undefined :: r a)  -- | Retrieves the whole contents of the 'RequestStore'. contents :: RequestStore u -> [BlockedFetches u] contents (RequestStore m) = Map.elems m++getSize :: RequestStore u -> Int+getSize (RequestStore m) = Map.size m++-- A counter to keep track of outgone requests. Entries are added to this+-- map as we send requests to datasources, and removed as these fetches+-- are completed.+-- This is a 2 level map: the 1st level stores requests for a particular+-- datasource, the 2nd level stores count of requests per type.+newtype ReqCountMap = ReqCountMap (Map Text (Map TypeRep Int))+  deriving (Show)++emptyReqCounts :: ReqCountMap+emptyReqCounts = ReqCountMap Map.empty++addToCountMap+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)+  => Proxy r+  -> Int -- type and number of requests+  -> ReqCountMap+  -> ReqCountMap+addToCountMap = updateCountMap (+)++subFromCountMap+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)+  => Proxy r+  -> Int -- type and number of requests+  -> ReqCountMap+  -> ReqCountMap+subFromCountMap = updateCountMap (-)++updateCountMap+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)+  => (Int -> Int -> Int)+  -> Proxy r+  -> Int -- type and number of requests+  -> ReqCountMap+  -> ReqCountMap+updateCountMap op p n (ReqCountMap m) = ReqCountMap $ Map.insertWith+  (flip (Map.unionWith op)) -- flip is important as "op" is not commutative+  (dataSourceName p) (Map.singleton ty n)+  m+  where+    -- The TypeRep of requests for this data source+    -- The way this is implemented, all elements in the 2nd level map will be+    -- mapped to the same key, as all requests to a datasource have the same+    -- "type". It will be more beneficial to be able to instead map requests+    -- to their names (ie, data constructor) - but there's no cheap way of doing+    -- that.+    ty :: TypeRep+    !ty = typeOf1 (undefined :: r a)++-- Filter all keys with 0 fetches. Since ReqCountMap is a 2-level map, we need+-- nested filter operations.+filterRCMap :: ReqCountMap -> ReqCountMap+filterRCMap (ReqCountMap m) = ReqCountMap $+  Map.filter ((> 0) . Map.size) (Map.filter (> 0) <$> m)++-- Filters the ReqCountMap by default+getMapFromRCMap :: ReqCountMap -> Map Text (Map TypeRep Int)+getMapFromRCMap r+  | ReqCountMap m <- filterRCMap r = m++getSummaryMapFromRCMap :: ReqCountMap -> HashMap.HashMap Text Int+getSummaryMapFromRCMap (ReqCountMap m) = HashMap.fromList+  [ (k, s)+  | (k, v) <- Map.toList m+  , not $ Map.null v+  , let s = sum $ Map.elems v+  , s > 0+  ]
+ Haxl/Core/Run.hs view
@@ -0,0 +1,290 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Defines 'runHaxl'.  Most users should import "Haxl.Core" instead.+--+module Haxl.Core.Run+  ( runHaxl+  , runHaxlWithWrites+  ) where++import Control.Concurrent.STM+import Control.Exception as Exception+import Control.Monad+import Data.IORef+import Data.Maybe+import Text.Printf+import Unsafe.Coerce++import Haxl.Core.DataCache+import Haxl.Core.Exception+import Haxl.Core.Flags+import Haxl.Core.Monad+import Haxl.Core.Fetch+import Haxl.Core.Profile+import Haxl.Core.RequestStore as RequestStore+import Haxl.Core.Stats+import Haxl.Core.Util++import qualified Data.HashTable.IO as H++-- -----------------------------------------------------------------------------+-- runHaxl++-- | Runs a 'Haxl' computation in the given 'Env'.+--+-- Note: to make multiple concurrent calls to 'runHaxl', each one must+-- have a separate 'Env'. A single 'Env' must /not/ be shared between+-- multiple concurrent calls to 'runHaxl', otherwise deadlocks or worse+-- will likely ensue.+--+-- However, multiple 'Env's may share a single 'StateStore', and thereby+-- use the same set of datasources.+runHaxl:: forall u w a. Monoid w => Env u w -> GenHaxl u w a -> IO a+runHaxl env haxl = fst <$> runHaxlWithWrites env haxl++runHaxlWithWrites :: forall u w a. Monoid w => Env u w -> GenHaxl u w a -> IO (a, w)+runHaxlWithWrites env@Env{..} haxl = do+  result@IVar{ivarRef = resultRef} <- newIVar -- where to put the final result+  ifTraceLog <- do+    if trace flags < 3+    then return $ \_ -> return ()+    else do+      start <- getTimestamp+      return $ \s -> do+        now <- getTimestamp+        let t = fromIntegral (now - start) / 1000.0 :: Double+        printf "%.1fms: %s" t (s :: String)+  let+    -- Run a job, and put its result in the given IVar+    schedule :: Env u w -> JobList u w -> GenHaxl u w b -> IVar u w b -> IO ()+    schedule env@Env{..} rq (GenHaxl run) ivar@IVar{ivarRef = !ref} = do+      ifTraceLog $ printf "schedule: %d\n" (1 + lengthJobList rq)+      let {-# INLINE result #-}+          result r = do+            e <- readIORef ref+            case e of+              IVarFull _ ->+                -- An IVar is typically only meant to be written to once+                -- so it would make sense to throw an error here. But there+                -- are legitimate use-cases for writing several times.+                -- (See Haxl.Core.Parallel)+                reschedule env rq+              IVarEmpty haxls -> do+                writeIORef ref (IVarFull r)+                -- Have we got the final result now?+                if ref == unsafeCoerce resultRef+                        -- comparing IORefs of different types is safe, it's+                        -- pointer-equality on the MutVar#.+                   then+                     -- We have a result, but don't discard unfinished+                     -- computations in the run queue. See+                     -- Note [runHaxl and unfinished requests].+                     -- Nothing can depend on the final IVar, so haxls must+                     -- be empty.+                     case rq of+                       JobNil -> return ()+                       _ -> modifyIORef' runQueueRef (appendJobList rq)+                   else reschedule env (appendJobList haxls rq)+      r <-+        if testReportFlag ReportProfiling $ report flags  -- withLabel unfolded+          then Exception.try $ profileCont run env+          else Exception.try $ run env+      case r of+        Left e -> do+          rethrowAsyncExceptions e+          result (ThrowIO e)+        Right (Done a) -> do+          wt <- readIORef writeLogsRef+          result $ Ok a (Just wt)+        Right (Throw ex) -> do+          wt <- readIORef writeLogsRef+          result $ ThrowHaxl ex (Just wt)+        Right (Blocked i fn) -> do+          addJob env (toHaxl fn) ivar i+          reschedule env rq++    -- Here we have a choice:+    --   - If the requestStore is non-empty, we could submit those+    --     requests right away without waiting for more.  This might+    --     be good for latency, especially if the data source doesn't+    --     support batching, or if batching is pessimal.+    --   - To optimise the batch sizes, we want to execute as much as+    --     we can and only submit requests when we have no more+    --     computation to do.+    --   - compromise: wait at least Nms for an outstanding result+    --     before giving up and submitting new requests.+    --+    -- For now we use the batching strategy in the scheduler, but+    -- individual data sources can request that their requests are+    -- sent eagerly by using schedulerHint.+    --+    reschedule :: Env u w -> JobList u w -> IO ()+    reschedule env@Env{..} haxls = do+      case haxls of+        JobNil -> do+          rq <- readIORef runQueueRef+          case rq of+            JobNil -> emptyRunQueue env+            JobCons env' a b c -> do+              writeIORef runQueueRef JobNil+              schedule env' c a b+        JobCons env' a b c ->+          schedule env' c a b++    emptyRunQueue :: Env u w -> IO ()+    emptyRunQueue env = do+      ifTraceLog $ printf "emptyRunQueue\n"+      haxls <- checkCompletions env+      case haxls of+        JobNil -> checkRequestStore env+        _ -> reschedule env haxls++    checkRequestStore :: Env u w -> IO ()+    checkRequestStore env@Env{..} = do+      ifTraceLog $ printf "checkRequestStore\n"+      reqStore <- readIORef reqStoreRef+      if RequestStore.isEmpty reqStore+        then waitCompletions env+        else do+          ifTraceLog $ printf "performFetches %d\n" (RequestStore.getSize reqStore)+          writeIORef reqStoreRef noRequests+          performRequestStore env reqStore+          -- empty the cache if we're not caching.  Is this the best+          -- place to do it?  We do get to de-duplicate requests that+          -- happen simultaneously.+          when (caching flags == 0) $ do+            let DataCache dc = dataCache+            H.foldM (\_ (k, _) -> H.delete dc k) () dc+          emptyRunQueue env++    checkCompletions :: Env u w -> IO (JobList u w)+    checkCompletions Env{..} = do+      ifTraceLog $ printf "checkCompletions\n"+      comps <- atomicallyOnBlocking (LogicBug ReadingCompletionsFailedRun) $ do+        c <- readTVar completions+        writeTVar completions []+        return c+      case comps of+        [] -> return JobNil+        _ -> do+          ifTraceLog $ printf "%d complete\n" (length comps)+          let+              getComplete (CompleteReq a IVar{ivarRef = !cr} allocs) = do+                when (allocs < 0) $ do+                  cur <- getAllocationCounter+                  setAllocationCounter (cur + allocs)+                r <- readIORef cr+                case r of+                  IVarFull _ -> do+                    ifTraceLog $ printf "existing result\n"+                    return JobNil+                    -- this happens if a data source reports a result,+                    -- and then throws an exception.  We call putResult+                    -- a second time for the exception, which comes+                    -- ahead of the original request (because it is+                    -- pushed on the front of the completions list) and+                    -- therefore overrides it.+                  IVarEmpty cv -> do+                    writeIORef cr (IVarFull a)+                    return cv+          jobs <- mapM getComplete comps+          return (foldr appendJobList JobNil jobs)++    waitCompletions :: Env u w -> IO ()+    waitCompletions env@Env{..} = do+      ifTraceLog $ printf "waitCompletions\n"+      let+        wrapped = atomicallyOnBlocking (LogicBug ReadingCompletionsFailedRun)+        doWait = wrapped $ do+          c <- readTVar completions+          when (null c) retry+        doWaitProfiled = do+          queueEmpty <- null <$> wrapped (readTVar completions)+          when queueEmpty $ do+            -- Double check the queue as we want to make sure that+            -- submittedReqsRef is copied before waiting on the queue but as a+            -- fast path do not want to copy it if the queue is empty.+            -- There is still a race oppoortunity as submittedReqsRef is+            -- decremented in whatever thread the completion happens, and so it+            -- is possible for waitingOn to be empty while queueEmpty2 is True.+            waitingOn <- readIORef submittedReqsRef+            queueEmpty2 <- null <$> wrapped (readTVar completions)+            when queueEmpty2 $ do+              start <- getTimestamp+              doWait+              end <- getTimestamp+              let fw = FetchWait+                        { fetchWaitReqs = getSummaryMapFromRCMap waitingOn+                        , fetchWaitStart = start+                        , fetchWaitDuration = (end-start)+                        }+              modifyIORef' statsRef $ \(Stats s) -> Stats (fw:s)+      if testReportFlag ReportFetchStats $ report flags+        then doWaitProfiled+        else doWait+      emptyRunQueue env++  --+  schedule env JobNil haxl result+  r <- readIORef resultRef+  writeIORef writeLogsRef mempty+  wtNoMemo <- atomicModifyIORef' writeLogsRefNoMemo+    (\old_wrts -> (mempty, old_wrts))+  case r of+    IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result")+    IVarFull (Ok a wt) -> do+      return (a, fromMaybe mempty wt <> wtNoMemo)+    IVarFull (ThrowHaxl e _wt)  -> throwIO e+      -- The written logs are discarded when there's a Haxl exception. We+      -- can change this behavior if we need to get access to partial logs.+    IVarFull (ThrowIO e)  -> throwIO e+++{- Note [runHaxl and unfinished requests]++runHaxl returns immediately when the supplied computation has returned+a result.  This doesn't necessarily mean that the whole computation+graph has completed, however.  In particular, when using pAnd and pOr,+we might have created some data fetches that have not completed, but+weren't required, because the other branch of the pAnd/pOr subsumed+the result.++When runHaxl returns, it might be that:+- reqStoreRef contains some unsubmitted requests+- runQueueRef contains some jobs+- there are in-flight BackgroundFetch requests, that will return their+  results to the completions queue in due course.+- there are various unfilled IVars in the cache and/or memo tables++This should be all safe, we can even restart runHaxl with the same Env+after it has stopped and the in-progress computations will+continue. But don't discard the contents of+reqStoreRef/runQueueRef/completions, because then we'll deadlock if we+discover one of the unfilled IVars in the cache or memo table.+-}++{- TODO: later+data SchedPolicy+  = SubmitImmediately+  | WaitAtLeast Int{-ms-}+  | WaitForAllPendingRequests+-}++-- | An exception thrown when reading from datasources fails+data ReadingCompletionsFailedRun = ReadingCompletionsFailedRun+  deriving Show++instance Exception ReadingCompletionsFailedRun
− Haxl/Core/Show1.hs 
@@ -1,15 +0,0 @@--- 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/ShowP.hs view
@@ -0,0 +1,20 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- |+-- Most users should import "Haxl.Core" instead of importing this+-- module directly.+--+module Haxl.Core.ShowP+  ( ShowP(..)+  ) where++-- | A class of type constructors for which we can show all+-- parameterizations.+class ShowP f where+  showp :: f a -> String
Haxl/Core/StateStore.hs view
@@ -1,22 +1,35 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} -module Haxl.Core.StateStore (-    StateKey(..), StateStore, stateGet, stateSet, stateEmpty+-- |+-- Most users should import "Haxl.Core" instead of importing this+-- module directly.+--+module Haxl.Core.StateStore+  ( StateKey(..)+  , StateStore+  , stateGet+  , stateSet+  , stateEmpty   ) where  import Data.Map (Map)+import Data.Kind (Type) import qualified Data.Map.Strict as Map+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif import Data.Typeable import Unsafe.Coerce @@ -24,17 +37,30 @@ -- 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+class Typeable f => StateKey (f :: Type -> Type) where   data State f-#endif +  -- | We default this to typeOf1, but if f is itself a complex type that is+  -- already applied to some paramaters, we want to be able to use the same+  -- state by using typeOf2, etc+  getStateType :: Proxy f -> TypeRep+  getStateType = typeRep+ -- | The 'StateStore' maps a 'StateKey' to the 'State' for that type. newtype StateStore = StateStore (Map TypeRep StateStoreData) +#if __GLASGOW_HASKELL__ >= 804+instance Semigroup StateStore where+  -- Left-biased union+  StateStore m1 <> StateStore m2 = StateStore $ m1 <> m2+#endif++instance Monoid StateStore where+  mempty = stateEmpty+#if __GLASGOW_HASKELL__ < 804+  mappend (StateStore m1) (StateStore m2) = StateStore $ m1 <> m2+#endif+ -- | Encapsulates the type of 'StateStore' data so we can have a -- heterogeneous collection. data StateStoreData = forall f. StateKey f => StateStoreData (State f)@@ -46,22 +72,18 @@ -- | 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)+  StateStore (Map.insert (getStateType (Proxy :: Proxy f)) (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+     Just (StateStoreData (st :: State f))+       | getStateType (Proxy :: Proxy f) == 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)+  ty = getStateType (Proxy :: Proxy r)
+ Haxl/Core/Stats.hs view
@@ -0,0 +1,313 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++-- |+-- Types and operations for statistics and profiling.  Most users+-- should import "Haxl.Core" instead of importing this module+-- directly.+--+module Haxl.Core.Stats+  (+  -- * Data-source stats+    Stats(..)+  , CallId+  , FetchStats(..)+  , Microseconds+  , Timestamp+  , DataSourceStats(..)+  , getTimestamp+  , emptyStats+  , numFetches+  , ppStats+  , ppFetchStats+  , aggregateFetchBatches++  -- * Profiling+  , Profile(..)+  , ProfileMemo(..)+  , ProfileFetch(..)+  , emptyProfile+  , ProfileKey+  , ProfileLabel+  , ProfileData(..)+  , emptyProfileData+  , AllocCount+  , LabelHitCount++  -- * Allocation+  , getAllocationCounter+  , setAllocationCounter+  ) where++import Data.Aeson+import Data.Function (on)+import Data.Maybe (mapMaybe)+import Data.HashMap.Strict (HashMap)+import Data.Int+import Data.List (intercalate, sortOn, groupBy)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup)+#endif+import Data.Ord (Down(..))+import Data.Text (Text)+import Data.Time.Clock.POSIX+import Data.Typeable+import Text.Printf+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text++import GHC.Conc (getAllocationCounter, setAllocationCounter)++-- ---------------------------------------------------------------------------+-- Measuring time++type Microseconds = Int64+type Timestamp = Microseconds -- since an epoch++getTimestamp :: IO Timestamp+getTimestamp = do+  t <- getPOSIXTime -- for now, TODO better+  return (round (t * 1000000))++-- ---------------------------------------------------------------------------+-- Stats++data DataSourceStats =+  forall a. (Typeable a, Show a, Eq a, ToJSON a) => DataSourceStats a++instance Show DataSourceStats where+  show (DataSourceStats x) = printf "DataSourceStats %s" (show x)++instance Eq DataSourceStats where+  (==) (DataSourceStats a) (DataSourceStats b) =+    cast a == Just b++-- | Stats that we collect along the way.+newtype Stats = Stats [FetchStats]+  deriving (Show, ToJSON, Semigroup, Monoid)++-- | Pretty-print Stats.+ppStats :: Stats -> String+ppStats (Stats rss) =+  intercalate "\n"+    [ "["+    ++ [+      if fetchWasRunning rs+          (minStartTime + (t - 1) * usPerDash)+          (minStartTime + t * usPerDash)+        then fetchSymbol rs+        else '-'+      | t <- [1..numDashes]+      ]+    ++ "] " ++ show i ++ " - " ++ ppFetchStats rs+    | (i, rs) <- zip [(1::Int)..] validFetchStats ]+  where+    isFetchStats FetchStats{} = True+    isFetchStats FetchWait{} = True+    isFetchStats FetchDataSourceStats{} = True+    isFetchStats _ = False+    validFetchStats = filter isFetchStats (reverse rss)+    numDashes = 50+    getStart FetchStats{..} = Just fetchStart+    getStart FetchWait{..} = Just fetchWaitStart+    getStart _ = Nothing+    getEnd FetchStats{..} = Just $ fetchStart + fetchDuration+    getEnd FetchWait{..} = Just $ fetchWaitStart + fetchWaitDuration+    getEnd _ = Nothing+    minStartTime = minimum $ mapMaybe getStart validFetchStats+    endTime = maximum $ mapMaybe getEnd validFetchStats+    usPerDash = (endTime - minStartTime) `div` numDashes+    fetchSymbol FetchStats{} = '*'+    fetchSymbol FetchWait{} = '.'+    fetchSymbol _ = '?'+    fetchWasRunning :: FetchStats -> Timestamp -> Timestamp -> Bool+    fetchWasRunning fs@FetchStats{} t1 t2 =+      (fetchStart fs + fetchDuration fs) >= t1 && fetchStart fs < t2+    fetchWasRunning fw@FetchWait{} t1 t2 =+      (fetchWaitStart fw + fetchWaitDuration fw) >= t1 && fetchWaitStart fw < t2+    fetchWasRunning _ _ _ = False++type CallId = Int++-- | 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.+data FetchStats+    -- | Timing stats for a (batched) data fetch+  = FetchStats+    { fetchDataSource :: Text+    , fetchBatchSize :: {-# UNPACK #-} !Int+    , fetchStart :: {-# UNPACK #-} !Timestamp+    , fetchDuration :: {-# UNPACK #-} !Microseconds+    , fetchSpace :: {-# UNPACK #-} !Int64+    , fetchFailures :: {-# UNPACK #-} !Int+    , fetchIgnoredFailures :: {-# UNPACK #-} !Int+    , fetchBatchId :: {-# UNPACK #-} !Int+    , fetchIds :: [CallId]+    }++    -- | The stack trace of a call to 'dataFetch'.  These are collected+    -- only when profiling and reportLevel is 5 or greater.+  | FetchCall+    { fetchReq :: String+    , fetchStack :: [String]+    , fetchStatId :: {-# UNPACK #-} !CallId+    }+  | MemoCall+    { memoStatId :: {-# UNPACK #-} !CallId+    , memoSpace :: {-# UNPACK #-} !Int64+    }+  | FetchWait+    { fetchWaitReqs :: HashMap Text Int+       -- ^ What DataSources had requests that were being waited for+    , fetchWaitStart :: {-# UNPACK #-} !Timestamp+    , fetchWaitDuration :: {-# UNPACK #-} !Microseconds+    }+  | FetchDataSourceStats+    { fetchDsStatsCallId :: CallId+    , fetchDsStatsDataSource :: Text+    , fetchDsStatsStats :: DataSourceStats+    , fetchBatchId :: {-# UNPACK #-} !Int+    }+  deriving (Eq, Show)++-- | Pretty-print RoundStats.+ppFetchStats :: FetchStats -> String+ppFetchStats FetchStats{..} =+  printf "%s: %d fetches (%.2fms, %d bytes, %d failures)"+    (Text.unpack fetchDataSource) fetchBatchSize+    (fromIntegral fetchDuration / 1000 :: Double)  fetchSpace fetchFailures+ppFetchStats (FetchCall r ss _) = show r ++ '\n':show ss+ppFetchStats MemoCall{} = ""+ppFetchStats FetchWait{..}+  | HashMap.size fetchWaitReqs == 0 = msg "unexpected: Blocked on nothing"+  | HashMap.size fetchWaitReqs <= 2 =+    msg $ printf "Blocked on %s"+      (intercalate "," [printf "%s (%d reqs)" ds c+                       | (ds,c) <- HashMap.toList fetchWaitReqs])+  | otherwise = msg $ printf "Blocked on %d sources (%d reqs)"+                        (HashMap.size fetchWaitReqs)+                        (sum $ HashMap.elems fetchWaitReqs)+  where+    msg :: String -> String+    msg x = printf "%s (%.2fms)"+                x+                (fromIntegral fetchWaitDuration / 1000 :: Double)+ppFetchStats FetchDataSourceStats{..} =+  printf "%s (stats): %s" (Text.unpack fetchDsStatsDataSource)+    (show fetchDsStatsStats)++-- | Aggregate stats merging FetchStats from the same dispatched batch into one.+aggregateFetchBatches :: ([FetchStats] -> a) -> Stats -> [a]+aggregateFetchBatches agg (Stats fetches) =+      map agg $+      groupBy ((==) `on` fetchBatchId) $+      sortOn (Down . fetchBatchId)+      [f | f@FetchStats{} <- fetches]++instance ToJSON FetchStats where+  toJSON FetchStats{..} = object+    [ "type" .= ("FetchStats" :: Text)+    , "datasource" .= fetchDataSource+    , "fetches" .= fetchBatchSize+    , "start" .= fetchStart+    , "duration" .= fetchDuration+    , "allocation" .= fetchSpace+    , "failures" .= fetchFailures+    , "ignoredFailures" .= fetchIgnoredFailures+    , "batchid" .= fetchBatchId+    , "fetchids" .= fetchIds+    ]+  toJSON (FetchCall req strs fid) = object+    [ "type" .= ("FetchCall" :: Text)+    , "request" .= req+    , "stack" .= strs+    , "fetchid" .= fid+    ]+  toJSON (MemoCall cid allocs) = object+    [ "type" .= ("MemoCall" :: Text)+    , "callid" .= cid+    , "allocation" .= allocs+    ]+  toJSON FetchWait{..} = object+    [ "type" .= ("FetchWait" :: Text)+    , "duration" .= fetchWaitDuration+    ]+  toJSON FetchDataSourceStats{..} = object+    [ "type" .= ("FetchDataSourceStats" :: Text)+    , "datasource" .= fetchDsStatsDataSource+    , "stats" .= sjson fetchDsStatsStats+    , "batchid" .= fetchBatchId+    ]+    where+      sjson (DataSourceStats s) = toJSON s++emptyStats :: Stats+emptyStats = Stats []++numFetches :: Stats -> Int+numFetches (Stats rs) = sum [ fetchBatchSize | FetchStats{..} <- rs ]+++-- ---------------------------------------------------------------------------+-- Profiling++type ProfileLabel = Text+type AllocCount = Int64+type LabelHitCount = Int64+type ProfileKey = Int64++data ProfileFetch = ProfileFetch+  { profileFetchFetchId :: {-# UNPACK #-} !CallId+  , profileFetchMemoId ::  {-# UNPACK #-} !CallId+  , profileFetchWasCached :: !Bool+  }+  deriving (Show, Eq)++data ProfileMemo = ProfileMemo+  { profileMemoId :: {-# UNPACK #-} !CallId+  , profileMemoWasCached :: !Bool+  }+  deriving (Show, Eq)++data Profile = Profile+  { profile      :: HashMap ProfileKey ProfileData+     -- ^ Data per key (essentially per call stack)+  , profileTree :: HashMap (ProfileLabel, ProfileKey) ProfileKey+     -- ^ (label, parent) -> current. The exception is the root which will have+     -- ("MAIN", 0) -> 0+  , profileNextKey :: ProfileKey+     -- ^ Provides a unique key per callstack+  }++emptyProfile :: Profile+emptyProfile = Profile HashMap.empty (HashMap.singleton ("MAIN", 0) 0) 1++data ProfileData = ProfileData+  { profileAllocs :: {-# UNPACK #-} !AllocCount+     -- ^ allocations made by this label+  , profileFetches :: [ProfileFetch]+     -- ^ fetches made in this label+  , profileLabelHits :: {-# UNPACK #-} !LabelHitCount+     -- ^ number of hits at this label+  , profileMemos :: [ProfileMemo]+     -- ^ memo and a boolean representing if it was cached at the time+  , profileTime :: {-# UNPACK #-} !Microseconds+     -- ^ amount of time spent in computation at this label+  }+  deriving Show++emptyProfileData :: ProfileData+emptyProfileData = ProfileData 0 [] 0 [] 0
− Haxl/Core/Types.hs 
@@ -1,363 +0,0 @@--- 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
@@ -1,40 +1,42 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. -{-# LANGUAGE CPP #-}+  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-} +-- | Internal utilities only.+--+{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Haxl.Core.Util-  ( compose+  ( atomicallyOnBlocking+  , compose   , textShow-  , tryReadMVar+  , trace_   ) where -#if __GLASGOW_HASKELL__ >= 708-import Control.Concurrent (tryReadMVar)-#else-import Control.Concurrent-#endif- import Data.Text (Text)-+import Debug.Trace (trace) import qualified Data.Text as Text +import Control.Concurrent.STM+import Control.Exception++atomicallyOnBlocking :: Exception e => e -> STM a -> IO a+atomicallyOnBlocking e stm =+  catch (atomically stm)+        (\BlockedIndefinitelyOnSTM -> throw e)+ -- | 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++-- | This function can be used to trace a bunch of lines to stdout when+-- debugging haxl core.+trace_ :: String -> a -> a+trace_ _ = id+--trace_ = Debug.Trace.trace
+ Haxl/DataSource/ConcurrentIO.hs view
@@ -0,0 +1,83 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- A generic Haxl datasource for performing arbitrary IO concurrently.+-- Every IO operation will be performed in a separate thread.+-- You can use this with any kind of IO, but each different operation+-- requires an instance of the 'ConcurrentIO' class.+--+-- For example, to make a concurrent sleep operation:+--+-- > sleep :: Int -> GenHaxl u w Int+-- > sleep n = dataFetch (Sleep n)+-- >+-- > data Sleep+-- > instance ConcurrentIO Sleep where+-- >   data ConcurrentIOReq Sleep a where+-- >     Sleep :: Int -> ConcurrentIOReq Sleep Int+-- >+-- >   performIO (Sleep n) = threadDelay (n*1000) >> return n+-- >+-- > deriving instance Eq (ConcurrentIOReq Sleep a)+-- > deriving instance Show (ConcurrentIOReq Sleep a)+-- >+-- > instance ShowP (ConcurrentIOReq Sleep) where showp = show+-- >+-- > instance Hashable (ConcurrentIOReq Sleep a) where+-- >   hashWithSalt s (Sleep n) = hashWithSalt s n+--+-- Note that you can have any number of constructors in your+-- ConcurrentIOReq GADT, so most of the boilerplate only needs to be+-- written once.++module Haxl.DataSource.ConcurrentIO+  ( mkConcurrentIOState+  , ConcurrentIO(..)+  ) where++import Control.Concurrent+import Control.Monad+import qualified Data.Text as Text+import Data.Typeable++import Haxl.Core++class ConcurrentIO tag where+  data ConcurrentIOReq tag a+  performIO :: ConcurrentIOReq tag a -> IO a++deriving instance Typeable ConcurrentIOReq -- not needed by GHC 7.10 and later++instance (Typeable tag) => StateKey (ConcurrentIOReq tag) where+  data State (ConcurrentIOReq tag) = ConcurrentIOState+  getStateType _ = typeRep (Proxy :: Proxy ConcurrentIOReq)++mkConcurrentIOState :: IO (State (ConcurrentIOReq ()))+mkConcurrentIOState = return ConcurrentIOState++instance Typeable tag => DataSourceName (ConcurrentIOReq tag) where+  dataSourceName _ =+    Text.pack (show (typeRepTyCon (typeRep (Proxy :: Proxy tag))))++instance+  (Typeable tag, ShowP (ConcurrentIOReq tag), ConcurrentIO tag)+  => DataSource u (ConcurrentIOReq tag)+ where+  fetch _state _flags _u = BackgroundFetch $ \bfs -> do+    forM_ bfs $ \(BlockedFetch req rv) ->+      forkFinally (performIO req) (putResultFromChildThread rv)
Haxl/Prelude.hs view
@@ -1,10 +1,11 @@--- 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.+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved. +  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,7 +13,7 @@ {-# 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+-- the standard Prelude, plus a selection of stuff that makes -- Haxl client code cleaner and more concise. -- -- We intend Haxl client code to:@@ -31,15 +32,17 @@     module Prelude,      -- * Haxl and Fetching data-    GenHaxl, dataFetch, DataSource,+    GenHaxl, dataFetch, DataSource, memo,+    memoize, memoize1, memoize2,      -- * Extra Monad and Applicative things     Applicative(..),-    mapM, mapM_, sequence, sequence_, (<$>), filterM, foldM,+    mapM, mapM_, sequence, sequence_, filterM, foldM,     forM, forM_,     foldl', sort,     Monoid(..),     join,+    andThen,      -- * Lifted operations     IfThenElse(..),@@ -47,6 +50,7 @@     (.==), (./=), (.&&), (.||),     (.++),     pair,+    pAnd, pOr,      -- * Text things     Text,@@ -60,18 +64,20 @@    ) where -import Haxl.Core.Types+import Haxl.Core.DataSource import Haxl.Core.Exception+import Haxl.Core.Memo import Haxl.Core.Monad+import Haxl.Core.Fetch+import Haxl.Core.Parallel  import Control.Applicative-import Control.Monad (foldM, join)+import Control.Monad (foldM, join, void) 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) @@ -89,19 +95,19 @@   ifThenElse :: a -> b -> b -> b  instance IfThenElse Bool a where-  ifThenElse b t e = case b of True -> t; False -> e+  ifThenElse b t e = if b then t else e  -- The equality constraint is necessary to convince the typechecker that -- this is valid: ----- > if getCountry ip .== "us" then ... else ...+-- > if ipGetCountry ip .== "us" then ... else ... ---instance (u1 ~ u2) => IfThenElse (GenHaxl u1 Bool) (GenHaxl u2 a) where+instance (u1 ~ u2) => IfThenElse (GenHaxl u1 w Bool) (GenHaxl u2 w a) where   ifThenElse fb t e = do     b <- fb     if b then t else e -instance Num a => Num (GenHaxl u a) where+instance Num a => Num (GenHaxl u w a) where   (+)         = liftA2 (+)   (-)         = liftA2 (-)   (*)         = liftA2 (*)@@ -110,7 +116,7 @@   signum      = liftA signum   negate      = liftA negate -instance Fractional a => Fractional (GenHaxl u a) where+instance Fractional a => Fractional (GenHaxl u w a) where   (/) = liftA2 (/)   recip = liftA recip   fromRational = return . fromRational@@ -121,35 +127,35 @@ -- 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+(.>) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool (.>) = liftA2 (Prelude.>) -(.<) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.<) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool (.<) = liftA2 (Prelude.<) -(.>=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.>=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool (.>=) = liftA2 (Prelude.>=) -(.<=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.<=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool (.<=) = liftA2 (Prelude.<=) -(.==) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(.==) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool (.==) = liftA2 (Prelude.==) -(./=) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool+(./=) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool (./=) = liftA2 (Prelude./=) -(.++) :: GenHaxl u [a] -> GenHaxl u [a] -> GenHaxl u [a]+(.++) :: GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a] (.++) = liftA2 (Prelude.++)  -- short-circuiting Bool operations-(.&&):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool+(.&&):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool fa .&& fb = do a <- fa; if a then fb else return False -(.||):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool+(.||):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w 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 :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (a, b) pair = liftA2 (,)  -- -----------------------------------------------------------------------------@@ -167,7 +173,7 @@  -- | See 'mapM'. mapM_ :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f ()-mapM_ f t = const () <$> traverse f t+mapM_ f t = void $ traverse f t  forM_ :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f () forM_ = flip mapM_@@ -178,28 +184,48 @@  -- | See 'mapM'. sequence_ :: (Traversable t, Applicative f) => t (f a) -> f ()-sequence_ t = const () <$> sequenceA t+sequence_ t = void $ 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 ]+filterM :: (Applicative f) => (a -> f Bool) -> [a] -> f [a]+filterM predicate xs =+    filt <$> mapM predicate xs+  where+    filt bools = [ x | (x,True) <- zip xs bools ] +-- | In somes cases, we do want the monadic version of @('>>')@ to disable+-- concurrency and start one computation only after the other finishes, e.g.:+--+-- @+-- deferedFetch x = do+--   sleep 5+--   fetch x  -- fetch will actually run concurrently with sleep+-- @+--+-- But we have defined @('>>') = ('*>')@ with the applicative behavior as this+-- is desired in most cases, so instead we define 'andThen' as the monadic+-- version of @('>>')@:+--+-- @+-- deferedFetch x = sleep 5 `andThen` fetch x+-- @+andThen :: Monad m => m a -> m b -> m b+andThen a b = a >>= \_ -> b+ --------------------------------------------------------------------------------  -- | 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 :: a -> GenHaxl u w a -> GenHaxl u w 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+  :: GenHaxl u w a   -- ^ run this first+  -> GenHaxl u w a   -- ^ if it throws 'LogicError' or 'TransientError', run this+  -> GenHaxl u w a catchAny haxl handler =   haxl `catch` \e ->     if isJust (fromException e :: Maybe LogicError) ||
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Facebook, Inc.+Copyright (c) 2014-present, Facebook, Inc. All rights reserved.  Redistribution and use in source and binary forms, with or without modification,
− PATENTS 
@@ -1,23 +0,0 @@-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
@@ -1,2 +1,11 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module Setup where import Distribution.Simple main = defaultMain
+ changelog.md view
@@ -0,0 +1,109 @@+# Changes in version 2.5.1.1+  * Bump dependencies; builds up to GHC 9.10++# Changes in version 2.5.1.0+  * Add schedulerHintState method to DataSource++# Changes in version 2.4.0.0+  * Added fetchBatchId to FetchStats+  * Profiling now tracks full stacks and links each label to memos/fetches+  * Adds FetchDataSourceStats used to log stats/profiling data returned+    from datasources. This is stored in statsRef like any other Stats.+  * Report flag was changed from sequential numbers to bitmask.+  * Add ReportExceptionLabelStack flag to include label stack in HaxlException.++# Changes in version 2.3.0.0+  * Removed `FutureFetch`++# Changes in version 2.2.0.0++  * Use BasicHashTable for the Haxl DataCache instead of HashMap+  * API Changes in: Haxl.Core.DataCache, Haxl.Core.Fetch+  * Removed support for GHC < 8.2++# Changes in version 2.1.2.0++  * Add a callgraph reference to 'Env' to record the function callgraph during a+    computation. The callgraph is stored as an edge list in the Env through the+    use of `withCallGraph` and enables users to debug a Haxl computation.++# Changes in version 2.1.1.0+  * Adds feature to track outgone datasource fetches. This is only turned on+    for report level greater than 1. The fetches are stored as a running Map+    in the env ('submittedReqsRef').++# Changes in version 2.1.0.0++  * Add a new 'w' parameter to 'GenHaxl' to allow arbitrary writes during+    a computation. These writes are stored as a running log in the Env,+    and are memoized. This allows users to extract information from+    a Haxl computation which throws. Our advise is to limit these writes to+    monitoring and debugging logs.++  * A 'WriteTree' constructor to maintain log of writes inside the Environment.+    This is defined to allow O(1) mappend.++# Changes in version 2.0.1.1++  * Support for GHC 8.6.1+  * Bugfixes++# Changes in version 2.0.1.0++  * Exported MemoVar from Haxl.Core.Memo+  * Updated the facebook example+  * Fixed some links in the documentation+  * Bump some version bounds++# Changes in version 2.0.0.0++  * Completely rewritten internals to support arbitrarily overlapping+    I/O and computation.  Haxl no longer runs batches of I/O in+    "rounds", waiting for all the I/O to complete before resuming the+    computation. In Haxl 2, we can spawn I/O that returns results in+    the background and computation fragments are resumed when the+    values they depend on are available.  See+    `tests/FullyAsyncTest.hs` for an example.++  * A new `PerformFetch` constructor supports the new concurrency+    features: `BackgroundFetch`. The data source is expected to call+    `putResult` in the background on each `BlockedFetch` when its+    result is ready.++  * There is a generic `DataSource` implementation in+    `Haxl.DataSource.ConcurrentIO` for performing each I/O operation+    in a separate thread.++  * Lots of cleanup and refactoring of the APIs.++  * License changed from BSD+PATENTS to plain BSD3.++# Changes in version 0.5.1.0++  * 'pAnd' and 'pOr' were added+  * 'asyncFetchAcquireRelease' was added+  * 'cacheResultWithShow' was exposed+  * GHC 8.2.1 compatibility++# Changes in version 0.5.0.0+  * Rename 'Show1' to 'ShowP' ([#62](https://github.com/facebook/Haxl/issues/62))++# Changes in version 0.3.0.0++  * Some performance improvements, including avoiding quadratic+    slowdown with left-associated binds.++  * Documentation cleanup; Haxl.Core is the single entry point for the+    core and engine docs.++  * (>>) is now defined to be (*>), and therefore no longer forces+    sequencing.  This can have surprising consequences if you are+    using Haxl with side-effecting data sources, so watch out!++  * New function withEnv, for running a sub-computation in a local Env++  * Add a higher-level memoization API, see 'memo'++  * Show is no longer required for keys in cachedComputation++  * Exceptions now have `Eq` instances
haxl.cabal view
@@ -1,79 +1,123 @@ name:                haxl-version:             0.1.0.0+version:             2.5.1.1 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+license-files:       LICENSE author:              Facebook, Inc. maintainer:          The Haxl Team <haxl-team@fb.com>-copyright:           2014 (C) 2014 Facebook, Inc.+copyright:           Copyright (c) 2014-present, Facebook, Inc. category:            Concurrency build-type:          Simple stability:           alpha cabal-version:       >= 1.10+tested-with:+  GHC==8.4.4+  GHC==8.6.5+  GHC==8.8.4+  GHC==8.10.7+  GHC==9.0.2+  GHC==9.2.8+  GHC==9.4.8+  GHC==9.6.6+  GHC==9.8.2+  GHC==9.10.1  description:   Haxl is a library and EDSL for efficient scheduling of concurrent data   accesses with a concise applicative API.+  .+  To use Haxl, you need to implement one or more /data sources/, which+  provide the means for accessing remote data or other I/O that you+  want to perform using Haxl.+  .+  Haxl provides two top-level modules:+  .+  * /Data-source implementations/ import "Haxl.Core",+  .+  * /Client code/ import your data sources and "Haxl.Prelude", or some+   other client-level API that you provide.  extra-source-files:   readme.md-  PATENTS   tests/LoadCache.txt+  changelog.md  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.*,+    aeson >= 0.6 && < 2.3,+    base >= 4.10 && < 5,+    binary >= 0.7 && < 0.10,+    bytestring >= 0.9 && < 0.13,+    containers >= 0.5 && < 0.8,+    deepseq,+    exceptions >=0.8 && <0.11,+    filepath >= 1.3 && < 1.6,+    ghc-prim,+    hashable >= 1.2 && < 1.6,+    hashtables >= 1.2.3.1,     pretty == 1.1.*,-    text == 1.1.*,-    time == 1.4.*,+    -- text 1.2.1.0 required for instance Binary Text+    text >= 1.2.1.0 && < 1.3 || >= 2 && < 2.2,+    time >= 1.4 && < 1.13,+    stm >= 2.4 && < 2.6,+    transformers,     unordered-containers == 0.2.*,-    vector == 0.10.*+    vector >= 0.10 && <0.14    exposed-modules:     Haxl.Core,+    Haxl.Core.CallGraph,     Haxl.Core.DataCache,+    Haxl.Core.DataSource,     Haxl.Core.Exception,-    Haxl.Core.Env,-    Haxl.Core.Fetch,+    Haxl.Core.Flags,+    Haxl.Core.Memo,     Haxl.Core.Monad,+    Haxl.Core.Fetch,+    Haxl.Core.Parallel,+    Haxl.Core.Profile,+    Haxl.Core.Run,     Haxl.Core.RequestStore,+    Haxl.Core.ShowP,     Haxl.Core.StateStore,-    Haxl.Core.Show1,-    Haxl.Core.Types,+    Haxl.Core.Stats,     Haxl.Prelude+    Haxl.DataSource.ConcurrentIO    other-modules:     Haxl.Core.Util    default-language: Haskell2010+  default-extensions:+    TypeOperators    ghc-options:+    -O2 -fprof-auto     -Wall-    -fno-warn-name-shadowing-+    -Wno-name-shadowing  test-suite test    build-depends:-    HUnit,     aeson,-    base == 4.*,+    HUnit >= 1.2 && < 1.7,+    base >= 4.7 && < 5,+    binary,     bytestring,     containers,+    deepseq,+    filepath,     hashable,+    hashtables,     haxl,+    test-framework,+    test-framework-hunit,     text,+    time,     unordered-containers    ghc-options:@@ -85,17 +129,83 @@     tests    main-is:-    Main.hs+    TestMain.hs    other-modules:+    AdoTests+    AllTests+    BadDataSource     BatchTests     CoreTests     DataCacheTest     ExampleDataSource+    ExceptionStackTests+    FullyAsyncTest     LoadCache+    MemoizationTests     MockTAO+    MonadAsyncTest+    OutgoneFetchesTests+    ParallelTests+    ProfileTests+    SleepDataSource+    StatsTests+    TestBadDataSource     TestExampleDataSource     TestTypes+    TestUtils+    WorkDataSource+    WriteTests+    DataSourceDispatchTests    type:     exitcode-stdio-1.0++  default-language: Haskell2010+  default-extensions:+    TypeOperators++flag bench+  default: False++executable monadbench+  if !flag(bench)+    buildable: False+  default-language:+    Haskell2010+  default-extensions:+    TypeOperators+  hs-source-dirs:+    tests+  build-depends:+    base,+    haxl,+    hashable,+    time,+    optparse-applicative+  main-is:+    MonadBench.hs+  other-modules:+    ExampleDataSource+  ghc-options:+    -O2 -main-is MonadBench -rtsopts++executable cachebench+  if !flag(bench)+    buildable: False+  default-language:+    Haskell2010+  default-extensions:+    TypeOperators+  hs-source-dirs:+    tests+  build-depends:+    base,+    haxl,+    hashable,+    hashtables,+    time+  main-is:+    Bench.hs+  ghc-options:+    -O2 -main-is Bench -rtsopts
readme.md view
@@ -1,13 +1,16 @@-![Haxl Logo](http://github.com/facebook/Haxl/raw/master/logo.png)+![Haxl Logo](https://raw.githubusercontent.com/facebook/Haxl/main/logo.png)  # Haxl +[![Support Ukraine](https://img.shields.io/badge/Support-Ukraine-FFD500?style=flat&labelColor=005BBB)](https://opensource.fb.com/support-ukraine) [![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/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.+ * cache previous requests,+ * memoize computations.  Having all this handled for you behind the scenes means that your data-fetching code can be much cleaner and clearer than it would@@ -17,33 +20,48 @@ 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+ * `haxl-facebook` (in [https://github.com/facebook/Haxl/tree/master/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.++There is a generic datasource in "Haxl.DataSource.ConcurrentIO" that+can be used for performing arbitrary IO operations concurrently, given+a bit of boilerplate to define the IO operations you want to perform.+ 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!)+ * [The Story of Haxl](https://code.facebook.com/posts/302060973291128/open-sourcing-haxl-a-library-for-haskell/)    explains how Haxl came about at Facebook, and discusses our    particular use case. - * [An example Facebook data source](example/facebook/readme.md) walks+ * [An example Facebook data source](https://github.com/facebook/Haxl/blob/master/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+ * [Fun with Haxl (part 1)](https://simonmar.github.io/posts/2015-10-20-Fun-With-Haxl-1.html)+   Walks through using Haxl from scratch for a simple SQLite-backed+   blog engine.++ * [The N+1 Selects Problem](https://github.com/facebook/Haxl/blob/master/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.+   without the programmer having to specify this behavior.   * [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).+ * [There is no Fork: An Abstraction for Efficient, Concurrent, and Concise Data Access](http://simonmar.github.io/bib/papers/haxl-icfp14.pdf), our paper on Haxl, accepted for publication at ICFP'14.++## Contributing++We welcome contributions! See [CONTRIBUTING](https://github.com/facebook/Haxl/blob/master/CONTRIBUTING.md) for details on how to get started, and our [Code of Conduct](https://github.com/facebook/Haxl/blob/master/CODE_OF_CONDUCT.md).++## License++Haxl uses the BSD 3-clause License, as found in the [LICENSE](https://github.com/facebook/Haxl/blob/master/LICENSE) file.
+ tests/AdoTests.hs view
@@ -0,0 +1,57 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE RebindableSyntax, OverloadedStrings, ApplicativeDo #-}+module AdoTests (tests) where++import TestUtils+import MockTAO++import Control.Applicative+import Test.HUnit++import Prelude()+import Haxl.Prelude++-- -----------------------------------------------------------------------------++--+-- Test ApplicativeDo batching+--+ado1 = expectResult 12 ado1_++ado1_ = do+  a <- friendsOf =<< id1+  b <- friendsOf =<< id2+  return (length (a ++ b))++ado2 = expectResult 12 ado2_++ado2_ = do+  x <- id1+  a <- friendsOf x+  y <- id2+  b <- friendsOf y+  return (length (a ++ b))++ado3 = expectResult 11 ado3_++ado3_ = do+  x <- id1+  a <- friendsOf x+  a' <- friendsOf =<< if null a then id3 else id4+  y <- id2+  b <- friendsOf y+  b' <- friendsOf  =<< if null b then id4 else id3+  return (length (a' ++ b'))++tests future = TestList+  [ TestLabel "ado1" $ TestCase (ado1 future)+  , TestLabel "ado2" $ TestCase (ado2 future)+  , TestLabel "ado3" $ TestCase (ado3 future)+  ]
+ tests/AllTests.hs view
@@ -0,0 +1,50 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+module AllTests (allTests) where++import TestExampleDataSource+import BatchTests+import CoreTests+import DataCacheTest+import ExceptionStackTests+import AdoTests+import OutgoneFetchesTests+import ProfileTests+import MemoizationTests+import MonadAsyncTest+import TestBadDataSource+import FullyAsyncTest+import WriteTests+import ParallelTests+import StatsTests+import DataSourceDispatchTests++import Test.HUnit++allTests :: Test+allTests = TestList+  [ TestLabel "ExampleDataSource" TestExampleDataSource.tests+  , TestLabel "BatchTests-future" $ BatchTests.tests True+  , TestLabel "BatchTests-sync" $ BatchTests.tests False+  , TestLabel "CoreTests" CoreTests.tests+  , TestLabel "DataCacheTests" DataCacheTest.tests+  , TestLabel "ExceptionStackTests" ExceptionStackTests.tests+  , TestLabel "AdoTests" $ AdoTests.tests False+  , TestLabel "OutgoneFetchesTest" OutgoneFetchesTests.tests+  , TestLabel "ProfileTests" ProfileTests.tests+  , TestLabel "MemoizationTests" MemoizationTests.tests+  , TestLabel "MonadAsyncTests" MonadAsyncTest.tests+  , TestLabel "BadDataSourceTests" TestBadDataSource.tests+  , TestLabel "FullyAsyncTest" FullyAsyncTest.tests+  , TestLabel "WriteTest" WriteTests.tests+  , TestLabel "ParallelTest" ParallelTests.tests+  , TestLabel "StatsTests" StatsTests.tests+  , TestLabel "DataSourceDispatchTests" DataSourceDispatchTests.tests+  ]
+ tests/BadDataSource.hs view
@@ -0,0 +1,132 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++-- | A data source that can be made to fail in various ways, for testing++module BadDataSource (+    -- * initialise the state+    State(..), initGlobalState, FetchImpl(..),++    -- * requests for this data source+    FailAfter(..)+  ) where++import Haxl.Prelude+import Prelude ()++import Haxl.Core++import Control.Exception+import Data.Typeable+import Data.Hashable+import Control.Concurrent+import Control.Monad (void)++import GHC.Conc ( PrimMVar )+import Foreign.StablePtr+import Foreign.C.Types ( CInt(..) )++foreign import ccall safe+  hs_try_putmvar :: CInt -> StablePtr PrimMVar -> IO ()++data FetchImpl =+  Async+  | Background+  | BackgroundMVar+  | BackgroundSeq+  | BackgroundPar++data FailAfter a where+  FailAfter :: Int -> FailAfter Int+  deriving Typeable++deriving instance Eq (FailAfter a)+deriving instance Show (FailAfter a)+instance ShowP FailAfter where showp = show++instance Hashable (FailAfter a) where+   hashWithSalt s (FailAfter a) = hashWithSalt s (0::Int,a)++instance StateKey FailAfter where+  data State FailAfter = FailAfterState+         { failAcquireDelay :: Int+         , failAcquire :: IO ()+         , failReleaseDelay :: Int+         , failRelease :: IO ()+         , failDispatchDelay :: Int+         , failDispatch :: IO ()+         , failWaitDelay :: Int+         , failWait :: IO ()+         , failImpl :: FetchImpl+        }++instance DataSourceName FailAfter where+  dataSourceName _ = "BadDataSource"+++instance DataSource u FailAfter where+  fetch state@FailAfterState{..}+    | BackgroundSeq <- failImpl = backgroundFetchSeq runOne state+    | BackgroundPar <- failImpl = backgroundFetchPar runOne state+    | Background <- failImpl = backgroundFetchAcquireRelease+        acquire release dispatchbg wait+        submit state+    | BackgroundMVar <- failImpl = backgroundFetchAcquireReleaseMVar+        acquire release dispatchbgMVar wait+        submit state+    | Async <- failImpl = asyncFetchAcquireRelease+       acquire release dispatch wait+       submit state+   where+     acquire = do threadDelay failAcquireDelay; failAcquire+     release _ = do threadDelay failReleaseDelay; failRelease+     dispatch _ = do threadDelay failDispatchDelay; failDispatch+     dispatchBase put = (do+                          failDispatch+                          _ <- mask_ $ forkIO $ finally+                            (threadDelay failDispatchDelay)+                            put+                          return ()) `onException` put+     dispatchbg _ c m = dispatchBase (hs_try_putmvar (fromIntegral c) m)+     dispatchbgMVar _ _ m = dispatchBase (void $ tryPutMVar m ())+     wait _ = do threadDelay failWaitDelay; failWait+     submit :: () -> FailAfter a -> IO (IO (Either SomeException a))+     submit _ (FailAfter t) = do+       threadDelay t+       return (return (Left (toException (FetchError "failed request"))))+     runOne :: FailAfter a -> IO (Either SomeException a)+     runOne r = do+       bracket acquire release $ \s -> do+         dispatch s+         getRes <- submit s r+         wait s+         getRes++initGlobalState :: FetchImpl -> IO (State FailAfter)+initGlobalState impl = do+  return FailAfterState+    { failAcquireDelay = 0+    , failAcquire = return ()+    , failReleaseDelay = 0+    , failRelease = return ()+    , failDispatchDelay = 0+    , failDispatch = return ()+    , failWaitDelay = 0+    , failWait = return ()+    , failImpl = impl+    }
tests/BatchTests.hs view
@@ -1,71 +1,33 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} module BatchTests (tests) where  import TestTypes+import TestUtils 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+import Data.IORef  -- ----------------------------------------------------------------------------- -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 = expectResult 12 batching1_  batching1_ = do   a <- id1@@ -75,7 +37,7 @@ -- -- Test batching in mapM (which is really traverse) ---batching2 = expectRounds 1 12 batching2_+batching2 = expectResult 12 batching2_  batching2_ = do   a <- id1@@ -86,7 +48,7 @@ -- -- Test batching when we have a monadic bind in each branch ---batching3 = expectRounds 1 12 batching3_+batching3 = expectResult 12 batching3_  batching3_ = do   let a = id1 >>= friendsOf@@ -96,7 +58,7 @@ -- -- Test batching over both arguments of (+) ---batching4 = expectRounds 1 12 batching4_+batching4 = expectResult 12 batching4_  batching4_ = do   let a = length <$> (id1 >>= friendsOf)@@ -106,7 +68,7 @@ -- -- Test batching over both arguments of (+) ---batching5 = expectRounds 1 2 batching5_+batching5 = expectResult 2 batching5_  batching5_ :: Haxl Int batching5_ = if a .> b then 1 else 2@@ -117,14 +79,14 @@ -- -- Test batching when we perform all batching tests together with sequence ---batching6 = expectRounds 1 [12,12,12,12,2] batching6_+batching6 = expectResult [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 = expectResult 12 batching7_  batching7_ :: Haxl Int batching7_ = if a .> 0 then a+b else 0@@ -133,7 +95,7 @@   b = length <$> (id2 >>= friendsOf)  -- We expect 3 rounds here due to boolean operators-batching8 = expectRounds 3 12 batching8_+batching8 = expectResult 12 batching8_  batching8_ :: Haxl Int batching8_ = if (c .== 0) .|| (a .> 0 .&& b .> 0) then a+b else 0@@ -142,6 +104,12 @@   b = length <$> (id2 >>= friendsOf)   c = length <$> (id3 >>= friendsOf) +-- (>>) should batch, so we expect one round+batching9 = expectResult 6 batching9_++batching9_ :: Haxl Int+batching9_ = (id1 >>= friendsOf) >> (length <$> (id2 >>= friendsOf))+ -- -- Test data caching, numFetches --@@ -167,45 +135,37 @@ -- -- Basic sanity check on data-cache re-use ---cacheReuse = do-  env <- makeTestEnv-  expectRoundsWithEnv 2 12 batching7_ env+cacheReuse future = do+  env <- makeTestEnv future+  expectResultWithEnv 12 batching7_ env    -- make a new env-  tao <- MockTAO.initGlobalState+  tao <- MockTAO.initGlobalState future   let st = stateSet tao stateEmpty   env2 <- initEnvWithData st testinput (caches env)+  cid <- readIORef (callIdRef env2)+  assertBool "callId is unique" (cid > 0)    -- ensure no more data fetching rounds needed-  expectRoundsWithEnv 0 12 batching7_ env2+  expectResultWithEnv 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-  ]+noCaching future = do+  env <- makeTestEnv future+  let env' = env{ flags = (flags env){caching = 0} }+  result <- runHaxl env' caching3_+  assertEqual "result" result 18+  stats <- readIORef (statsRef env)+  assertEqual "fetches" 4 (numFetches stats) -exceptionTest1 = expectRounds 1 []+exceptionTest1 = expectResult []   $ withDefault [] $ friendsOf 101 -exceptionTest2 = expectRounds 1 [7..12] $ liftA2 (++)+exceptionTest2 = expectResult [7..12] $ liftA2 (++)   (withDefault [] (friendsOf 101))   (withDefault [] (friendsOf 2)) -deterministicExceptions = do-  env <- makeTestEnv+deterministicExceptions future = do+  env <- makeTestEnv future   let haxl =         sequence [ do _ <- friendsOf =<< id1; throw (NotFound "xxx")                  , throw (NotFound "yyy")@@ -224,3 +184,124 @@     case r of      Left (NotFound "xxx") -> True      _ -> False++pOrTests future = do+  env <- makeTestEnv future++  -- Test semantics+  r <- runHaxl env $ do+        a <- return False `pOr` return False+        b <- return False `pOr` return True+        c <- return True `pOr` return False+        d <- return True `pOr` return True+        return (not a && b && c && d)+  assertBool "pOr0" r++  -- pOr is left-biased with respect to exceptions:+  r <- runHaxl env $ try $ return True `pOr` throw (NotFound "foo")+  assertBool "pOr1" $+    case (r :: Either NotFound Bool) of+      Right True -> True+      _ -> False+  r <- runHaxl env $ try $ throw (NotFound "foo") `pOr` return True+  assertBool "pOr2" $+    case (r :: Either NotFound Bool) of+      Left (NotFound "foo") -> True+      _ -> False++  -- pOr is non-deterministic (see also Note [tricky pOr/pAnd])+  let nondet = (do _ <- friendsOf 1; throw (NotFound "foo")) `pOr` return True+  r <- runHaxl env $ try nondet+  assertBool "pOr3" $+    case (r :: Either NotFound Bool) of+      Right True -> True+      _ -> False+  -- next we populate the cache+  _ <- runHaxl env $ friendsOf 1+  -- and now exactly the same pOr again will throw this time:+  r <- runHaxl env $ try nondet+  assertBool "pOr4" $+    case (r :: Either NotFound Bool) of+      Left (NotFound "foo") -> True+      _ -> False++  -- One more test: Blocked/False => Blocked+  r <- runHaxl env $ try $+    (do _ <- friendsOf 2; throw (NotFound "foo")) `pOr` return False+  assertBool "pOr5" $+    case (r :: Either NotFound Bool) of+      Left (NotFound _) -> True+      _ -> False++pAndTests future = do+  env <- makeTestEnv future++  -- Test semantics+  r <- runHaxl env $ do+        a <- return False `pAnd` return False+        b <- return False `pAnd` return True+        c <- return True `pAnd` return False+        d <- return True `pAnd` return True+        return (not a && not b && not c && d)+  assertBool "pAnd0" r++  -- pAnd is left-biased with respect to exceptions:+  r <- runHaxl env $ try $ return False `pAnd` throw (NotFound "foo")+  assertBool "pAnd1" $+    case (r :: Either NotFound Bool) of+      Right False -> True+      _ -> False+  r <- runHaxl env $ try $ throw (NotFound "foo") `pAnd` return False+  assertBool "pAnd2" $+    case (r :: Either NotFound Bool) of+      Left (NotFound "foo") -> True+      _ -> False++  -- pAnd is non-deterministic (see also Note [tricky pOr/pAnd])+  let nondet =+        (do _ <- friendsOf 1; throw (NotFound "foo")) `pAnd` return False+  r <- runHaxl env $ try nondet+  assertBool "pAnd3" $+    case (r :: Either NotFound Bool) of+      Right False -> True+      _ -> False+  -- next we populate the cache+  _ <- runHaxl env $ friendsOf 1+  -- and now exactly the same pAnd again will throw this time:+  r <- runHaxl env $ try nondet+  assertBool "pAnd4" $+    case (r :: Either NotFound Bool) of+      Left (NotFound "foo") -> True+      _ -> False++  -- One more test: Blocked/True => Blocked+  r <- runHaxl env $ try $+    (do _ <- friendsOf 2; throw (NotFound "foo")) `pAnd` return True+  assertBool "pAnd5" $+    case (r :: Either NotFound Bool) of+      Left (NotFound _) -> True+      _ -> False++tests :: Bool -> Test+tests future = TestList+  [ TestLabel "batching1" $ TestCase (batching1 future)+  , TestLabel "batching2" $ TestCase (batching2 future)+  , TestLabel "batching3" $ TestCase (batching3 future)+  , TestLabel "batching4" $ TestCase (batching4 future)+  , TestLabel "batching5" $ TestCase (batching5 future)+  , TestLabel "batching6" $ TestCase (batching6 future)+  , TestLabel "batching7" $ TestCase (batching7 future)+  , TestLabel "batching8" $ TestCase (batching8 future)+  , TestLabel "batching9" $ TestCase (batching9 future)+  , TestLabel "caching1" $ TestCase (caching1 future)+  , TestLabel "caching2" $ TestCase (caching2 future)+  , TestLabel "caching3" $ TestCase (caching3 future)+  , TestLabel "CacheReuse" $ TestCase (cacheReuse future)+  , TestLabel "NoCaching" $ TestCase (noCaching future)+  , TestLabel "exceptionTest1" $ TestCase (exceptionTest1 future)+  , TestLabel "exceptionTest2" $ TestCase (exceptionTest2 future)+  , TestLabel "deterministicExceptions" $+      TestCase (deterministicExceptions future)+  , TestLabel "pOrTest" $ TestCase (pOrTests future)+  , TestLabel "pAndTest" $ TestCase (pAndTests future)+  ]
+ tests/Bench.hs view
@@ -0,0 +1,68 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE RankNTypes, GADTs, BangPatterns, DeriveDataTypeable,+    StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-type-defaults #-}++module Bench where++import Haxl.Core.DataCache as DataCache++import Prelude hiding (mapM)++import Data.Hashable+import Data.IORef+import Data.Time.Clock+import Data.Traversable+import Data.Typeable+import System.Environment+import Text.Printf++data TestReq a where+  ReqInt    :: {-# UNPACK #-} !Int -> TestReq Int+  ReqDouble :: {-# UNPACK #-} !Int -> TestReq Double+  ReqBool   :: {-# UNPACK #-} !Int -> TestReq Bool+  deriving Typeable++deriving instance Eq (TestReq a)+deriving instance Show (TestReq a)++instance Hashable (TestReq a) where+  hashWithSalt salt (ReqInt i) = hashWithSalt salt (0::Int, i)+  hashWithSalt salt (ReqDouble i) = hashWithSalt salt (1::Int, i)+  hashWithSalt salt (ReqBool i) = hashWithSalt salt (2::Int, i)++main = do+  [n] <- fmap (fmap read) getArgs+  t0 <- getCurrentTime+  cache <- emptyDataCache+  let+     f 0 = return ()+     f !n = do+       m <- newIORef 0+       DataCache.insert (ReqInt n) m cache+       f (n-1)+  --+  f n+  m <- DataCache.lookup (ReqInt (n `div` 2)) cache+  print =<< mapM readIORef m+  t1 <- getCurrentTime+  printf "insert: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double)++  t0 <- getCurrentTime+  let+     f 0  !m = return m+     f !n !m = do+      mbRes <- DataCache.lookup (ReqInt n) cache+      case mbRes of+        Nothing -> f (n-1) m+        Just _  -> f (n-1) (m+1)+  f n 0 >>= print+  t1 <- getCurrentTime+  printf "lookup: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double)
tests/CoreTests.hs view
@@ -1,4 +1,15 @@-{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RebindableSyntax #-}+ module CoreTests where  import Haxl.Prelude@@ -10,17 +21,29 @@  import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BS+import Data.List  import Control.Exception (Exception(..)) -useless :: String -> GenHaxl u Bool-useless _ = throw (NotFound "ha ha")+import ExampleDataSource -en = error "no env"+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 () :: IO (Env () ())++useless :: String -> GenHaxl u w Bool+useless _ = throw (NotFound "ha ha")+ exceptions :: Assertion exceptions =   do+    en <- emptyEnv () :: IO (Env () ())     a <- runHaxl en $ try (useless "input")     assertBool "NotFound -> HaxlException" $       isLeft (a :: Either HaxlException Bool)@@ -48,14 +71,71 @@     f <- runHaxl en $          throw (NotFound "haha") `catch` \LogicError{} -> return True     assertBool "catch2" f++    -- test catchIf+    let transientOrNotFound e+          | Just TransientError{} <- fromException e  = True+          | Just NotFound{} <- fromException e  = True+          | otherwise = False++    e <- runHaxl en $+         catchIf transientOrNotFound (throw (NotFound "haha")) $ \_ ->+           return True+    assertBool "catchIf1" e++    e <- runHaxl en $+         catchIf transientOrNotFound (throw (FetchError "haha")) $ \_ ->+           return True+    assertBool "catchIf2" e++    e <- runHaxl en $+           (catchIf transientOrNotFound (throw (CriticalError "haha")) $ \_ ->+              return True)+            `catch` \InternalError{} -> return False+    assertBool "catchIf2" (not e)++    -- test tryToHaxlException+    e <- runHaxl en $ tryToHaxlException $ head []+    assertBool "tryToHaxlException1" $+      case e of+        Left ex | Just NonHaxlException{} <- fromException (toException ex)+          -> True+        _ -> False++    env <- testEnv+    e <- runHaxl env $ tryToHaxlException $ do+      xs <- listWombats 3+      return $! length xs `quot` 0+    print e+    assertBool "tryToHaxlException1" $+      case e of+        Left ex | Just NonHaxlException{} <- fromException (toException ex)+          -> True+        _ -> False++    env <- testEnv+    e <- runHaxl env $ mapM tryToHaxlException+      [ do xs <- listWombats 3; return $! length xs `quot` 0+      , head []+      ]+    print e+    assertBool "tryToHaxlException2" $+      case e of+        [Left ex1, Left ex2]+           | "divide" `isInfixOf` show ex1+           , "head" `isInfixOf` show ex2 -> True+        _ -> False   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+base e = do+  en <- emptyEnv () :: IO (Env () ())+  runHaxl en $ throw e `catch` \x -> return x  printing :: Assertion printing = do@@ -73,7 +153,35 @@   BS.putStrLn $ encode c  +withEnvTest :: Test+withEnvTest = TestLabel "withEnvTest" $ TestCase $ do+  exstate <- ExampleDataSource.initGlobalState+  e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ())+  b <- runHaxl e $ withEnv e { userEnv = True } $ env userEnv+  assertBool "withEnv1" b+  e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ())+  b <- runHaxl e $ withEnv e { userEnv = True } $ do+    _ <- countAardvarks "aaa"+    env userEnv+  assertBool "withEnv2" b+  e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ())+  b <- runHaxl e $ withEnv e { userEnv = True } $ do+    memo ("xxx" :: Text) $ do+      _ <- countAardvarks "aaa"+      env userEnv+  assertBool "withEnv3" b+  e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ())+  b <- runHaxl e $+    withEnv e { userEnv = True } $ do+      memo ("yyy" :: Text) $ do+        _ <- countAardvarks "aaa"+        _ <- countAardvarks "bbb"+        env userEnv+  assertBool "withEnv4" b++ tests = TestList   [ TestLabel "exceptions" $ TestCase exceptions,-    TestLabel "print_stuff" $ TestCase printing+    TestLabel "print_stuff" $ TestCase printing,+    TestLabel "withEnv" $ withEnvTest   ]
tests/DataCacheTest.hs view
@@ -1,15 +1,32 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-}-module DataCacheTest (tests) where+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module DataCacheTest (tests, newResult, takeResult) where  import Haxl.Core.DataCache as DataCache-import Haxl.Core.Types+import Haxl.Core.Monad+import Haxl.Core  import Control.Exception+import Data.Either import Data.Hashable import Data.Traversable import Data.Typeable import Prelude hiding (mapM) import Test.HUnit+import Data.IORef+import Data.Text+import Unsafe.Coerce  data TestReq a where    Req :: Int -> TestReq a -- polymorphic result@@ -21,42 +38,165 @@ instance Hashable (TestReq a) where   hashWithSalt salt (Req i) = hashWithSalt salt i +instance DataSource u TestReq where+  fetch = error "no fetch defined" +instance DataSourceName TestReq where+  dataSourceName _ = pack "TestReq"++instance StateKey TestReq where+  data State TestReq = TestReqState++instance ShowP TestReq where showp = show++data CacheableReq x where CacheableInt :: Int -> CacheableReq Int+  deriving Typeable+deriving instance Eq (CacheableReq x)+deriving instance Show (CacheableReq x)+instance Hashable (CacheableReq x) where+  hashWithSalt s (CacheableInt val) = hashWithSalt s (0::Int, val)+++newResult :: Monoid w => a -> IO (IVar u w a)+newResult a = newFullIVar (Ok a mempty)++takeResult :: IVar u w a -> IO (ResultVal a w)+takeResult IVar{ivarRef = ref} = do+  e <- readIORef ref+  case e of+    IVarFull a -> return a+    _ -> error "takeResult"++ 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+  cache <- emptyDataCache+  DataCache.insert (Req 2 :: TestReq String) m2 cache+  DataCache.insert (Req 1 :: TestReq Int) m1 cache    -- "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+  r <- mapM takeResult =<< DataCache.lookup (Req 1) cache   assertBool "dcSoundness1" $-    case r :: Maybe (Either SomeException String) of+    case r :: Maybe (ResultVal String ()) of      Nothing -> True      _something_else -> False -  r <- mapM takeResult $ DataCache.lookup (Req 1) cache+  r <- mapM takeResult =<< DataCache.lookup (Req 1) cache   assertBool "dcSoundness2" $-    case r :: Maybe (Either SomeException Int) of-     Just (Right 1) -> True+    case r :: Maybe (ResultVal Int ()) of+     Just (Ok 1 Nothing) -> True      _something_else -> False -  r <- mapM takeResult $ DataCache.lookup (Req 2) cache+  r <- mapM takeResult =<< DataCache.lookup (Req 2) cache   assertBool "dcSoundness3" $-    case r :: Maybe (Either SomeException String) of-      Just (Right "hello") -> True+    case r :: Maybe (ResultVal String ()) of+      Just (Ok "hello" Nothing) -> True       _something_else -> False -  r <- mapM takeResult $ DataCache.lookup (Req 2) cache+  r <- mapM takeResult =<< DataCache.lookup (Req 2) cache   assertBool "dcSoundness4" $-    case r :: Maybe (Either SomeException Int) of+    case r :: Maybe (ResultVal Int ()) of       Nothing -> True       _something_else -> False  +dcStrictnessTest :: Test+dcStrictnessTest = TestLabel "DataCache strictness" $ TestCase $ do+  env <- initEnv stateEmpty () :: IO (Env () ())+  r <- Control.Exception.try $ runHaxl env $+    cachedComputation (Req (error "BOOM")) $ return "OK"+  assertBool "dcStrictnessTest" $+    case r of+      Left (ErrorCall "BOOM") -> True+      _other -> False++dcFallbackTest :: Test+dcFallbackTest = TestLabel "DataCache fallback" $ TestList+  [ TestLabel "Base" $ TestCase $ do+      env <- mkEnv+      (r,cached) <- runHaxl env (do+                           a <- dataFetch req+                           b <- cacheResult (CacheableInt 1234) (return 99999)+                           return (a,b))+      (Stats stats) <- readIORef (statsRef env)+      assertEqual "fallback still has stats" 1+        (Prelude.length [x | x@FetchStats{} <- stats])+      assertEqual "dcFallbackTest found" 1 r+      assertEqual "dcFallbackTest cached" 1234 cached+  , TestLabel "Exception" $ TestCase $ do+      env <- mkEnv+      rbad <- Control.Exception.try $ runHaxl env (dataFetch reqBad)+      assertBool "dcFallbackTest not found" $+        case rbad of+          Left (ErrorCall "no fetch defined") -> True+          _ -> False+  , TestLabel "Completions" $ TestCase $ do+      -- check applicative still runs as it would have without a fallback+      env <- mkEnv+      let+        fetchA = dataFetch reqEx+        fetchB = tellWrite 7 >> dataFetch req+      (rbad, writes) <- runHaxlWithWrites env $+        Haxl.Core.try $ (,) <$> fetchA <*> fetchB+      fetches <- countFetches env+      assertEqual "dispatched 2 fetches" 2 fetches+      assertBool "exception propogates" $+        case rbad of+          Left (NotFound _) -> True+          _ -> False+      assertEqual "write side effects happen" [7] (flattenWT writes)+  ]+  where++    mkEnv = addLookup <$> initEnv (stateSet TestReqState stateEmpty) ()++    countFetches env = do+      (Stats stats) <- readIORef (statsRef env)+      let+        c = sum [ fetchBatchSize x+                | x@FetchStats{} <- stats+                ]+      return c++    addLookup :: Env () (WriteTree Int) -> Env () (WriteTree Int)+    addLookup e = e { dataCacheFetchFallback = Just (DataCacheLookup lookup)+                    , flags = (flags e) { report = profilingReportFlags }+                    }+    lookup+      :: forall req a . Typeable (req a)+      => req a+      -> IO (Maybe (ResultVal a (WriteTree Int)))+    lookup r+      | typeOf r == typeRep (Proxy :: Proxy (TestReq Int)) =+        -- have to coerce on the way out as results are not Typeable+        -- so you better be sure you do it right!+        return $ unsafeCoerce . doReq <$> cast r+      | typeOf r == typeRep (Proxy :: Proxy (CacheableReq Int)) =+          return $ unsafeCoerce . doCache <$> cast r+      | otherwise = return Nothing++    doReq :: TestReq Int -> ResultVal Int (WriteTree Int)+    doReq (Req 999) = ThrowHaxl (toException $ NotFound empty) Nothing+    doReq (Req r) = Ok r Nothing++    doCache :: CacheableReq Int -> ResultVal Int (WriteTree Int)+    doCache (CacheableInt i) = Ok i Nothing++    req :: TestReq Int+    req = Req 1++    reqEx :: TestReq Int+    reqEx = Req 999++    reqBad :: TestReq String+    reqBad = Req 2++ -- tests :: Assertion-tests = TestList [dcSoundnessTest]+tests = TestList [ dcSoundnessTest+                 , dcStrictnessTest+                 , dcFallbackTest+                 ]
+ tests/DataSourceDispatchTests.hs view
@@ -0,0 +1,83 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}++module DataSourceDispatchTests (tests) where+import Test.HUnit hiding (State)+import Control.Monad+import Haxl.Core+import Data.Hashable++data DataSourceDispatch ty where+    GetBatchSize :: Int -> DataSourceDispatch Int++deriving instance Eq (DataSourceDispatch ty)+deriving instance Show (DataSourceDispatch ty)++instance DataSourceName DataSourceDispatch where+    dataSourceName _ = "DataSourceDispatch"++instance StateKey DataSourceDispatch where+    data State DataSourceDispatch = DataSourceDispatchState++instance ShowP DataSourceDispatch where showp = show++instance Hashable (DataSourceDispatch a) where+  hashWithSalt s (GetBatchSize n) = hashWithSalt s n++initDataSource :: IO (State DataSourceDispatch)+initDataSource = return DataSourceDispatchState++instance DataSource UserEnv DataSourceDispatch where+    fetch _state _flags _u = SyncFetch $ \bfs -> forM_ bfs (fill $ length bfs)+      where+      fill :: Int -> BlockedFetch DataSourceDispatch -> IO ()+      fill l (BlockedFetch (GetBatchSize _ ) rv) = putResult rv (Right l)++    schedulerHint Batching = TryToBatch+    schedulerHint NoBatching = SubmitImmediately++data UserEnv = Batching | NoBatching deriving (Eq)++makeTestEnv :: UserEnv -> IO (Env UserEnv ())+makeTestEnv testUsrEnv = do+  st <- initDataSource+  e <- initEnv (stateSet st stateEmpty) testUsrEnv+  return e { flags = (flags e) {+    report = setReportFlag ReportFetchStats defaultReportFlags } }++schedulerTest:: Test+schedulerTest = TestCase $ do+    let+        fet = do+          x <- dataFetch (GetBatchSize 0)+          y <- dataFetch (GetBatchSize 1)+          return [x,y]++    e <- makeTestEnv Batching+    r1 :: [Int] <- runHaxl e fet+    assertEqual "Failed to create batches for data fetch" [2,2] r1++    eNoBatching <- makeTestEnv NoBatching+    r2 :: [Int] <- runHaxl eNoBatching fet+    assertEqual "Unexpexted batches in SubmitImmediately" [1,1] r2++    return ()++tests :: Test+tests = TestList+  [ TestLabel "schedulerTest" schedulerTest+  ]
tests/ExampleDataSource.hs view
@@ -1,3 +1,11 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -12,7 +20,7 @@     initGlobalState,      -- * requests for this data source-    ExampleReq(..),+    Id(..), ExampleReq(..),     countAardvarks,     listWombats,   ) where@@ -24,6 +32,9 @@  import Data.Typeable import Data.Hashable+import Control.Concurrent+import qualified Control.Exception as E+import System.IO  -- Here is an example minimal data source.  Our data source will have -- two requests:@@ -63,7 +74,7 @@  deriving instance Show (ExampleReq a) -instance Show1 ExampleReq where show1 = show+instance ShowP ExampleReq where showp = show  instance Hashable (ExampleReq a) where    hashWithSalt s (CountAardvarks a) = hashWithSalt s (0::Int,a)@@ -87,7 +98,12 @@   -- I'll define exampleFetch below   fetch = exampleFetch +  -- we don't want to treat NotFound as an exception for stats purposes+  classifyFailure _ _ e+    | Just NotFound{} <- E.fromException e = IgnoredForStatsFailure+    | otherwise = StandardFailure + -- 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@@ -115,10 +131,9 @@ exampleFetch :: State ExampleReq             -- current state              -> Flags                        -- tracing verbosity, etc.              -> u                            -- user environment-             -> [BlockedFetch ExampleReq]    -- requests to fetch-             -> PerformFetch                 -- tells the framework how to fetch+             -> PerformFetch ExampleReq      -- tells the framework how to fetch -exampleFetch _state _flags _user bfs = SyncFetch $ mapM_ fetch1 bfs+exampleFetch _state _flags _user = SyncFetch $ mapM_ fetch1    -- There are two ways a data source can fetch data: synchronously or   -- asynchronously.  See the type 'PerformFetch' in "Haxl.Core.Types" for@@ -134,18 +149,24 @@   putSuccess m 1   error "BANG2" -- the exception is propagated even if we have already                 -- put the result with putSuccess+fetch1 (BlockedFetch (CountAardvarks "BANG3") _) = do+  hPutStr stderr "BANG3"+  killThread =<< myThreadId -- an asynchronous exception+fetch1 (BlockedFetch (CountAardvarks "BANG4") r) = do+  putFailure r $ NotFound "BANG4" 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..]+  if a > 999999+    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 :: String -> GenHaxl u w Int countAardvarks str = dataFetch (CountAardvarks str) -listWombats :: Id -> GenHaxl () [Id]-listWombats id = dataFetch (ListWombats id)+listWombats :: Id -> GenHaxl u w [Id]+listWombats i = dataFetch (ListWombats i)
+ tests/ExceptionStackTests.hs view
@@ -0,0 +1,73 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module ExceptionStackTests (tests) where++import Prelude ()+import Haxl.Core+import Haxl.Prelude++import Test.HUnit++import qualified ExampleDataSource++testEnv :: ReportFlags -> IO (Env () ())+testEnv report = do+  exstate <- ExampleDataSource.initGlobalState+  let st = stateSet exstate stateEmpty+  env <- initEnv st ()+  return env{ flags = (flags env){ report = report } }++reportFlags :: ReportFlags+reportFlags = setReportFlag ReportExceptionLabelStack defaultReportFlags++runHaxlTest+  :: ReportFlags+  -> String+  -> (Int -> Int -> GenHaxl () () Int)+  -> IO (Maybe [Text])+runHaxlTest report str func = do+  env <- testEnv report+  result <- runHaxl env $+    withLabel "try" $ tryToHaxlException $ withLabel "test" $ do+      x <- withLabel "dummy" $ pure 1+      y <- withLabel "fetch" $ ExampleDataSource.countAardvarks str+      withLabel "func" $ func x y+  case result of+    Left (HaxlException stk _) -> return stk+    Right{} -> assertFailure "expected: HaxlException"++fetchException :: Test+fetchException = TestCase $ do+  result <- runHaxlTest reportFlags "BANG4" $ \i j -> return $ i + j+  assertEqual "stack" (Just ["fetch", "test", "try", "MAIN"]) result++userException :: Test+userException = TestCase $ do+  result <- runHaxlTest reportFlags "aaa" $ \_ _ -> withLabel "throw" $+    throw $ InvalidParameter "throw"+  assertEqual "stack" (Just ["throw", "func", "test", "try", "MAIN"]) result++#ifndef PROFILING+disabledExceptionStack :: Test+disabledExceptionStack = TestCase $ do+  result <- runHaxlTest defaultReportFlags "BANG4" $ \i j -> return $ i + j+  assertEqual "stack" Nothing result+#endif++tests :: Test+tests = TestList+  [ TestLabel "FetchException" fetchException+  , TestLabel "UserException" userException+#ifndef PROFILING+  , TestLabel "DisabledExceptionStack"  disabledExceptionStack+#endif+  ]
+ tests/FullyAsyncTest.hs view
@@ -0,0 +1,67 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module FullyAsyncTest where++import Haxl.Prelude as Haxl+import Prelude()++import SleepDataSource+import Haxl.DataSource.ConcurrentIO++import Haxl.Core+import Test.HUnit+import Data.IORef+import Haxl.Core.Monad (unsafeLiftIO)++tests :: Test+tests = sleepTest++testEnv :: IO (Env () ())+testEnv = do+  st <- mkConcurrentIOState+  env <- initEnv (stateSet st stateEmpty) ()+  return env { flags = (flags env) {+    report = setReportFlag ReportFetchStats defaultReportFlags } }++sleepTest :: Test+sleepTest = TestCase $ do+  env <- testEnv++  ref <- newIORef ([] :: [Int])+  let tick n = unsafeLiftIO (modifyIORef ref (n:))++  -- simulate running a selection of data fetches that complete at+  -- different times, overlapping them as much as possible.+  runHaxl env $+    sequence_+       [ sequence_ [sleep 100, sleep 400] `andThen` tick 5     -- A+       , sleep 100 `andThen` tick 2 `andThen` sleep 200 `andThen` tick 4    -- B+       , sleep 50 `andThen` tick 1 `andThen` sleep 150 `andThen` tick 3     -- C+       ]++  ys <- readIORef ref+  assertEqual "FullyAsyncTest: ordering" [1,2,3,4,5] (reverse ys)++  stats <- readIORef (statsRef env)+  print stats+  assertEqual "FullyAsyncTest: stats" 5 (numFetches stats)++{-+           A         B         C+50          |        |       tick 1+100         |     tick 2       |+150         |        |         |+200         |        |       tick 3+250         |        |+300         |     tick 4+350         |+400         |+450         |+500      tick 5+-}
tests/LoadCache.hs view
@@ -1,3 +1,11 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE CPP, OverloadedStrings #-} module LoadCache where
tests/LoadCache.txt view
@@ -1,4 +1,4 @@-loadCache :: GenHaxl u ()+loadCache :: GenHaxl u w () loadCache = do   cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy")))   cacheRequest (CountAardvarks "xxx") (Right (3))
− tests/Main.hs 
@@ -1,20 +0,0 @@-{-# 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/MemoizationTests.hs view
@@ -0,0 +1,78 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module MemoizationTests (tests) where++import Data.IORef++import Test.HUnit++import Haxl.Core+import Haxl.Core.Monad (unsafeLiftIO)++import ExampleDataSource++memoSoundness :: Test+memoSoundness = TestCase $ do+  iEnv <- do+    exState <- ExampleDataSource.initGlobalState+    initEnv (stateSet exState stateEmpty) () :: IO (Env () ())++  unMemoizedWombats <- runHaxl iEnv $ listWombats 100++  (initialGet, subsequentGet) <- runHaxl iEnv $ do+    wombatsMemo <- newMemoWith (listWombats 100)+    let memoizedWombats = runMemo wombatsMemo++    initialGet <- memoizedWombats+    subsequentGet <- memoizedWombats++    return (initialGet, subsequentGet)++  assertBool "Memo Soundness 1" $ initialGet == unMemoizedWombats+  assertBool "Memo Soundness 2" $ subsequentGet == unMemoizedWombats++  let impure runCounterRef = unsafeLiftIO $ do+        modifyIORef runCounterRef succ+        readIORef runCounterRef++      initialRunCounter = 0 :: Int++  runCounterRef <- newIORef initialRunCounter++  (initialImpureGet, subsequentImpureGet) <- runHaxl iEnv $ do+    impureMemo <- newMemoWith (impure runCounterRef)+    let memoizedImpure = runMemo impureMemo++    initialImpureGet <- memoizedImpure+    subsequentImpureGet <- memoizedImpure++    return (initialImpureGet, subsequentImpureGet)++  assertBool "Memo Soundness 3" $ initialImpureGet == succ initialRunCounter+  assertBool "Memo Soundness 4" $ subsequentImpureGet == initialImpureGet++  let fMemoVal = 42 :: Int++  dependentResult <- runHaxl iEnv $ do+    fMemoRef <- newMemo+    gMemoRef <- newMemo++    let f = runMemo fMemoRef+        g = runMemo gMemoRef++    prepareMemo fMemoRef $ return fMemoVal+    prepareMemo gMemoRef $ succ <$> f++    a <- f+    b <- g+    return (a + b)++  assertBool "Memo Soundness 5" $ dependentResult == fMemoVal + succ fMemoVal++tests = TestList [TestLabel "Memo Soundness" memoSoundness]
tests/MockTAO.hs view
@@ -1,3 +1,11 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -6,12 +14,14 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}  module MockTAO (     Id(..),     initGlobalState,     assocRangeId2s,     friendsAssoc,+    friendsOf,   ) where  import Data.Hashable@@ -20,7 +30,11 @@ import Prelude () import qualified Data.Map as Map import qualified Data.Text as Text+import Control.Concurrent+import Control.Exception+import Control.Monad (void) + import Haxl.Prelude import Haxl.Core @@ -36,29 +50,34 @@ deriving instance Show (TAOReq a) deriving instance Eq (TAOReq a) -instance Show1 TAOReq where show1 = show+instance ShowP TAOReq where showp = show  instance Hashable (TAOReq a) where   hashWithSalt s (AssocRangeId2s a b) = hashWithSalt s (a,b)  instance StateKey TAOReq where-  data State TAOReq = TAOState {}+  data State TAOReq = TAOState { future :: Bool }  instance DataSourceName TAOReq where   dataSourceName _ = "MockTAO"  instance DataSource UserEnv TAOReq where-  fetch _state _flags _user bfs = SyncFetch $ mapM_ doFetch bfs+  fetch TAOState{..} _flags _user+    | future = BackgroundFetch $ \f -> do+        mask_ $ void . forkIO $  mapM_ (doFetch True) f+    | otherwise = SyncFetch $ mapM_ (doFetch False) -initGlobalState :: IO (State TAOReq)-initGlobalState = return TAOState {}+initGlobalState :: Bool -> IO (State TAOReq)+initGlobalState future = return TAOState { future=future } -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+doFetch ::  Bool -> BlockedFetch TAOReq -> IO ()+doFetch bg (BlockedFetch req@(AssocRangeId2s a b) r) = put result+  where put = if bg then putResultFromChildThread r else putResult r+        result = case Map.lookup (a, b) assocs of+          Nothing -> except . NotFound . Text.pack $ show req+          Just result -> Right result + assocs :: Map (Id,Id) [Id] assocs = Map.fromList [   ((friendsAssoc, 1), [5..10]),@@ -72,3 +91,6 @@  assocRangeId2s :: Id -> Id -> Haxl [Id] assocRangeId2s a b = dataFetch (AssocRangeId2s a b)++friendsOf :: Id -> Haxl [Id]+friendsOf = assocRangeId2s friendsAssoc
+ tests/MonadAsyncTest.hs view
@@ -0,0 +1,130 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module MonadAsyncTest (tests) where+import Haxl.Core+import Test.HUnit hiding (State)+import Control.Concurrent+import Control.Exception as Exception+import Control.Monad+import Haxl.Core.Monad (unsafeLiftIO, WriteTree)+import System.IO.Unsafe+import Data.Hashable+import Data.IORef+import Data.Text (Text)++newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show)++{-# NOINLINE shouldThrowRef #-}+shouldThrowRef :: IORef Bool+shouldThrowRef = unsafePerformIO (newIORef False)++-- | This datasource contains "bad" code which can throw at the wrong+-- moment.+data ThrowableSleep a where+  Sleep :: Int -> ThrowableSleep Int++deriving instance Eq (ThrowableSleep a)+deriving instance Show (ThrowableSleep a)++instance ShowP ThrowableSleep where showp = show++instance Hashable (ThrowableSleep a) where+  hashWithSalt s (Sleep n) = hashWithSalt s n++instance StateKey ThrowableSleep where+  data State ThrowableSleep = ThrowableSleepState++initDataSource :: IO (State ThrowableSleep)+initDataSource = return ThrowableSleepState++instance DataSourceName ThrowableSleep where+  dataSourceName _ = "ThrowableSleep"++instance DataSource u ThrowableSleep where+  fetch _state _flags _u = BackgroundFetch $ \bfs -> forM_ bfs fill+    where+    fill :: BlockedFetch ThrowableSleep -> IO ()+    fill (BlockedFetch (Sleep n) rv) = do+      _ <- forkFinally+        (do+          threadDelay (n*1000)+          return n+        )+        (\res -> do+          shouldThrow <- atomicModifyIORef' shouldThrowRef (\s -> (False, s))+          -- Simulate case when datasource throws before putting Result into+          -- completions queue.+          when shouldThrow $ do+            throwIO $ ErrorCall "datasource threw an exception"+          -- In case the datasource throws before this point, there'll be+          -- nothing to put the result to the queue of 'completions', and+          -- therefore Haxl would block indefinitely.+          --+          -- Note that Haxl tries to catch datasource exceptions and put the+          -- "exception result" into `completions` using `wrapFetchInCatch`+          -- function. However that doesn't work in this case because the+          -- datasource throws in a separate thread.+          putResultFromChildThread rv res+        )+      return ()++tests :: Test+tests = TestList+  [ TestLabel "exceptionTest" exceptionTest+  ]++mkTestEnv :: IO (Env () (WriteTree SimpleWrite))+mkTestEnv = do+  st <- initDataSource+  initEnv (stateSet st stateEmpty) ()++exceptionTest :: Test+exceptionTest = TestCase $ do+  e <- mkTestEnv++  let+      fet (n :: Int) (st :: Bool )= do+        x <- dataFetch (Sleep (fromIntegral n))+        unsafeLiftIO $ writeIORef shouldThrowRef st+        y <- dataFetch (Sleep (fromIntegral x*2))+        return (x+y)++  r1 :: (Either Exception.SomeException Int)+    <- Exception.try $ runHaxl e $ fet 10 True++  -- Datasources are responsible for putting the fetched result into the+  -- completions queue. If for some reason they fail to do so, Haxl throws a+  -- LogicBug since the scheduler is still expecting some request(s) to+  -- be completed.+  case r1 of+    Left ex | Just (LogicBug _) <- Exception.fromException ex -> return ()+    _ -> assertFailure "r1 computation did not fail with Logic Bug!"++  -- Sanitize the env to get rid of all empty IVars+  -- While this test examines the case when there's an exception in the Haxl+  -- datasource itself, a similar behavior will occur in case an async+  -- exception is thrown to the Haxl scheduler thread.+  e' <- sanitizeEnv e++  r2 :: (Either Exception.SomeException Int)+    <- Exception.try $ runHaxl e' $ fet 10 False+  case r2 of+    Right _ -> return ()+    Left ex | Just (LogicBug _) <- Exception.fromException ex -> do+                assertFailure $ "bad exception in r2: " ++ show ex+    Left _ -> return ()
+ tests/MonadBench.hs view
@@ -0,0 +1,173 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++-- | Benchmarking tool for core performance characteristics of the Haxl monad.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo, RecordWildCards #-}+module MonadBench (main) where++import Control.Monad+import Data.List as List+import Data.Maybe+import Data.Time.Clock+import Options.Applicative+import System.Exit+import System.IO+import Text.Printf++import Haxl.Prelude as Haxl+import Prelude()++import Haxl.Core+import Haxl.Core.Monad (WriteTree)+import Haxl.Core.Util++import ExampleDataSource++newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show)++testEnv :: ReportFlags -> IO (Env () (WriteTree SimpleWrite))+testEnv report = do+  exstate <- ExampleDataSource.initGlobalState+  let st = stateSet exstate stateEmpty+  env <- initEnv st ()+  return env { flags = (flags env) { report = report } }++type Test = (String, Int, Int -> GenHaxl () (WriteTree SimpleWrite) ())++testName :: Test -> String+testName (t,_,_) = t++allTests :: [Test]+allTests =+    -- parallel, identical queries+  [ ("par1", large, \n -> Haxl.sequence_ (replicate n (listWombats 3)))+    -- parallel, distinct queries+  , ("par2", medium, \n ->+        Haxl.sequence_ (map listWombats [1..fromIntegral n]))+    -- sequential, identical queries+  , ("seqr", huge, \n ->+        foldr andThen (return ()) (replicate n (listWombats 3)))+    -- sequential, left-associated, distinct queries+  , ("seql", medium, \n -> do+       _ <- foldl andThen (return []) (map listWombats [1.. fromIntegral n])+       return ())+    -- No memoization+  , ("memo0", small, \n -> Haxl.sequence_ [unionWombats | _ <- [1..n]])+    -- One put, N gets.+  , ("memo1", medium_large, \n ->+        Haxl.sequence_ [memo (42 :: Int) unionWombats | _ <- [1..n]])+    -- N puts, N gets.+  , ("memo2", small, \n ->+        Haxl.sequence_ [memo (i :: Int) unionWombats | i <- [1..n]])+  , ("memo3", medium_large, \n -> do+        ref <- newMemoWith unionWombats+        let c = runMemo ref+        Haxl.sequence_ [c | _ <- [1..n]])+  , ("memo4", small, \n -> do+        let f = unionWombatsTo+        Haxl.sequence_ [f x | x <- take n $ cycle [100, 200 .. 1000]])+  , ("memo5", medium_large, \n -> do+        f <- memoize1 unionWombatsTo+        Haxl.sequence_ [f x | x <- take n $ cycle [100, 200 .. 1000]])+  , ("memo6", small, \n -> do+        let f = unionWombatsFromTo+        Haxl.sequence_ [ f x y+                       | x <- take n $ cycle [100, 200 .. 1000]+                       , let y = x + 1000+                       ])+  , ("memo7", medium_large, \n -> do+        f <- memoize2 unionWombatsFromTo+        Haxl.sequence_ [ f x y+                       | x <- take n $ cycle [100, 200 .. 1000]+                       , let y = x + 1000+                       ])+  , ("cc1", medium_large, \n ->+        Haxl.sequence_ [ cachedComputation (ListWombats 1000) unionWombats+                       | _ <- [1..n]+                       ])+  , ("tree", 20, \n -> void $ tree n (\_ act -> act))+  , ("tree_labels", 20, \n -> void $+      tree n (\n act -> withLabel (textShow n) act))+    -- parallel writes+  , ("write1", large, \n ->+        Haxl.sequence_ (replicate n (tellWrite (SimpleWrite "haha"))))+    -- sequential writes+  , ("write2", huge, \n -> foldr+        andThen+        (return ())+        (replicate n (tellWrite (SimpleWrite "haha"))))+  ]+  where+    huge = large * 10+    large =  medium * 10+    medium_large =  medium * 4+    medium = 200000+    small = 1000++data Options = Options+  { test :: String+  , nOverride :: Maybe Int+  , reportFlag :: ReportFlags+  }++runTest :: Options -> Test -> IO ()+runTest Options{..} (t, nDef, act) = do+  let n = fromMaybe nDef nOverride+  env <- testEnv reportFlag+  t0 <- getCurrentTime+  runHaxl env $ act n+  t1 <- getCurrentTime+  printf "%12s: %10d reqs: %.2fs\n"+    t n (realToFrac (t1 `diffUTCTime` t0) :: Double)++optionsParser :: Parser Options+optionsParser = do+  test <- argument str (metavar "TEST")+  reportFlag <- reportFlagParser+  nOverride <- optional $ argument auto (metavar "NUM")+  return Options{..}+  where+    reportFlagParser = foldl' (flip ($)) defaultReportFlags <$> sequenceA+      [ flag id (setReportFlag i) $ long $ show i+      | i <- enumFrom minBound+      ]++main :: IO ()+main = do+  opts@Options{..} <- execParser $ info optionsParser mempty+  let tests = if test == "all"+        then allTests+        else filter ((==) test . testName) allTests+  when+    (null tests)+    (do+        hPutStrLn stderr $ "syntax: monadbench [all|" +++          intercalate "|" (map testName allTests) ++ "]"+        exitWith (ExitFailure 1))+  Control.Monad.mapM_ (runTest opts) tests++tree+  :: Int+  -> (Int -> GenHaxl () (WriteTree SimpleWrite) [Id]+  -> GenHaxl () (WriteTree SimpleWrite) [Id])+  -> GenHaxl () (WriteTree SimpleWrite) [Id]+tree 0 wrap = wrap 0 $ listWombats 0+tree n wrap = wrap n $ concat <$> Haxl.sequence+  [ tree (n-1) wrap+  , listWombats (fromIntegral n), tree (n-1) wrap+  ]++unionWombats :: GenHaxl () (WriteTree SimpleWrite) [Id]+unionWombats = foldl List.union [] <$> Haxl.mapM listWombats [1..1000]++unionWombatsTo :: Id -> GenHaxl () (WriteTree SimpleWrite) [Id]+unionWombatsTo x = foldl List.union [] <$> Haxl.mapM listWombats [1..x]++unionWombatsFromTo :: Id -> Id -> GenHaxl () (WriteTree SimpleWrite) [Id]+unionWombatsFromTo x y = foldl List.union [] <$> Haxl.mapM listWombats [x..y]
+ tests/OutgoneFetchesTests.hs view
@@ -0,0 +1,82 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}+module OutgoneFetchesTests (tests) where++import Haxl.Prelude as Haxl+import Prelude()++import Haxl.Core+import Haxl.DataSource.ConcurrentIO++import Data.IORef+import qualified Data.Map as Map+import Data.Typeable+import Test.HUnit+import System.Timeout++import ExampleDataSource+import SleepDataSource++testEnv :: IO (Env () ())+testEnv = do+  exstate <- ExampleDataSource.initGlobalState+  sleepState <- mkConcurrentIOState+  let st = stateSet exstate $ stateSet sleepState stateEmpty+  e <- initEnv st ()+  return e { flags = (flags e) {+    report = setReportFlag ReportOutgoneFetches defaultReportFlags } }+    -- report=1 to enable fetches tracking++-- A cheap haxl computation we interleave b/w the @sleep@ fetches.+wombats :: GenHaxl () () Int+wombats = length <$> listWombats 3++outgoneFetchesTest :: String -> Int -> GenHaxl () () a -> Test+outgoneFetchesTest label unfinished haxl = TestLabel label $ TestCase $ do+  env <- testEnv+  _ <- timeout (100*1000) $ runHaxl env haxl -- 100ms+  actual <- getMapFromRCMap <$> readIORef (submittedReqsRef env)+  assertEqual "fetchesMap" expected actual+  where+  expected = if unfinished == 0 then Map.empty else+    Map.singleton (dataSourceName (Proxy :: Proxy (ConcurrentIOReq Sleep))) $+      Map.singleton (typeOf1 (undefined :: ConcurrentIOReq Sleep a)) unfinished++tests :: Test+tests = TestList+  [ outgoneFetchesTest "finished" 0 $ do+      -- test that a completed datasource fetch doesn't show up in Env+      _ <- sleep 1  -- finished+      _ <- sleep 1  -- cached/finished+      _ <- sleep 1  -- cached/finished+      wombats+  , outgoneFetchesTest "unfinished" 2 $ do+      -- test that unfinished datasource fetches shows up in Env+      _ <- sleep 200 -- unfinished+      _ <- wombats+      _ <- sleep 300 -- unfinished+      _  <- wombats+      return ()+  , outgoneFetchesTest "mixed" 2 $ do+      -- test for finished/unfinished fetches from the same datasource+      _ <- sleep 1   -- finished+      _ <- sleep 200  -- unfinished+      _ <- sleep 300  -- unfinished+      return ()+  , outgoneFetchesTest "cached" 1 $ do+      -- test for cached requests not showing up twice in ReqCountMap+      _ <- sleep 200  -- unfinished+      _ <- sleep 200  -- cached/unfinished+      return ()+  , outgoneFetchesTest "unsent" 1 $+      -- test for unsent requests not showing up in ReqCountMap+      sleep 200 `andThen` sleep 300 -- second req should never be sent+  ]
+ tests/ParallelTests.hs view
@@ -0,0 +1,81 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++module ParallelTests where++import Haxl.Prelude+import Haxl.Core++import Haxl.DataSource.ConcurrentIO+import SleepDataSource++import Data.Time.Clock++import Test.HUnit++testEnv :: IO (Env () ())+testEnv = do+  sleepState <- mkConcurrentIOState+  let st = stateSet sleepState stateEmpty+  initEnv st ()++sync_test :: IO ()+sync_test = do+  env <- testEnv+  -- This computation tests that the two arguments of the pOr can fire+  -- without causing an error. The reason we test for this is that the+  -- synchronization involved in this case is a little fragile.+  False <- runHaxl env $ do+    (fmap (const False) (sleep 50)+      `pOr` fmap (const False) (sleep 100))+      `pOr` fmap (const False) (sleep 200)+  return ()++semantics_when_computation_is_blocked_test :: IO ()+semantics_when_computation_is_blocked_test = do+  env <- testEnv+    -- Test semantics of blocking+  let sleepReturn bool t = do+        _ <- sleep t+        return bool+  r <- runHaxl env $ do+        -- All sleep times are different so that they're not cached+        a <- sleepReturn False 10 `pOr` sleepReturn False 11+        b <- sleepReturn False 12 `pOr` sleepReturn True 13+        c <- sleepReturn True 14 `pOr` sleepReturn False 15+        d <- sleepReturn True 16 `pOr` sleepReturn True 17+        return (not a && b && c && d)+  assertBool "pOr blocked semantics" r+++timing_test = do+  env <- testEnv+  t0 <- getCurrentTime+  True <- runHaxl env $+    fmap (const True) (sleep 200) `pOr` fmap (const True) (sleep 100)+  t1 <- getCurrentTime+  True <- runHaxl env $+    fmap (const True) (sleep 100) `pOr` fmap (const True) (sleep 200)+  t2 <- getCurrentTime+  False <- runHaxl env $+    fmap (const False) (sleep 200) `pOr` fmap (const False) (sleep 100)+  t3 <- getCurrentTime+  False <- runHaxl env $+    fmap (const False) (sleep 100) `pOr` fmap (const False) (sleep 200)+  t4 <- getCurrentTime+  -- diffUTCTime returns the difference in seconds,+  -- while sleep expects milliseconds+  assert (t4 `diffUTCTime` t3 < 0.2)+  assert (t3 `diffUTCTime` t2 < 0.2)+  assert (t2 `diffUTCTime` t1 < 0.2)+  assert (t1 `diffUTCTime` t0 < 0.2)++tests = TestList [TestLabel "sync_test" (TestCase sync_test)+                 ,TestLabel "timing_test" (TestCase timing_test)+                 ,TestLabel "semantics_when_computation_is_blocked_test" (TestCase semantics_when_computation_is_blocked_test)+                 ]
+ tests/ProfileTests.hs view
@@ -0,0 +1,218 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module ProfileTests where++import Haxl.Prelude++import Haxl.Core+import Haxl.Core.Monad+import Haxl.Core.Stats++import Test.HUnit++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Aeson+import Data.IORef+import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif+import Data.Int++import TestTypes+import TestUtils+import WorkDataSource+import SleepDataSource++mkProfilingEnv :: IO HaxlEnv+mkProfilingEnv = do+  env <- makeTestEnv False+  return env { flags = (flags env) { report = profilingReportFlags } }++-- expects only one label to be shown+labelToDataMap :: Profile -> HashMap.HashMap ProfileLabel ProfileData+labelToDataMap Profile{..} = HashMap.fromList hashKeys+  where+    labelKeys = HashMap.fromList [+      (k, l) | ((l, _), k) <- HashMap.toList profileTree]+    hashKeys = [ (l, v)+      | (k, v) <- HashMap.toList profile+      , Just l <- [HashMap.lookup k labelKeys]]++collectsdata :: Assertion+collectsdata = do+  e <- mkProfilingEnv+  _x <- runHaxl e $+          withLabel "bar" $+            withLabel "foo" $ do+              u <- env userEnv+              slp <- sum <$> mapM (\x -> withLabel "baz" $ return x) [1..5]+              -- do some non-trivial work that can't be lifted out+              -- first sleep though in order to force a Blocked result+              sleep slp `andThen` case fromJSON <$> KeyMap.lookup "A" u of+                Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5+                _otherwise -> return (4::Int)+  profCopy <- readIORef (profRef e)+  let+    profData = profile profCopy+    labelKeys = HashMap.fromList [+      (l, k) | ((l, _), k) <- HashMap.toList (profileTree profCopy)]+    getData k = do+      k2 <- HashMap.lookup k labelKeys+      HashMap.lookup k2 profData+  assertEqual "has data" 4 $ HashMap.size profData+  assertBool "foo allocates" $+    case profileAllocs <$> getData "foo" of+      Just x -> x > 10000+      Nothing -> False+  assertEqual "foo is only called once" (Just 1) $+    profileLabelHits <$> getData "foo"+  assertEqual "baz is called 5 times" (Just 5) $+    profileLabelHits <$> getData "baz"+  assertBool "bar does not allocate (much)" $+    case profileAllocs <$> getData "bar" of+      Just n -> n < 5000  -- getAllocationCounter can be off by +/- 4K+      _otherwise -> False+  let fooParents = case HashMap.lookup "foo" labelKeys of+        Nothing -> []+        Just kfoo ->+          [ kparent+          | ((_, kparent), k) <- HashMap.toList (profileTree profCopy)+          , k == kfoo]+  assertEqual "foo's parent" 1 (length fooParents)+  assertEqual "foo's parent is bar" (Just (head fooParents)) $+    HashMap.lookup ("bar", 0) (profileTree profCopy)+++collectsLazyData :: Assertion+collectsLazyData = do+  e <- mkProfilingEnv+  _x <- runHaxl e $ withLabel "bar" $ do+          u <- env userEnv+          withLabel "foo" $ do+             let start = if KeyMap.member "A" u+                         then 10+                         else 1+             return $ sum [start..10000::Integer]+  profCopy <- readIORef (profRef e)+  -- check the allocations are attributed to foo+  assertBool "foo has allocations" $+    case profileAllocs <$> HashMap.lookup "foo" (labelToDataMap profCopy) of+      Just x -> x > 10000+      Nothing -> False++exceptions :: Assertion+exceptions = do+  env <- mkProfilingEnv+  _x <- runHaxl env $+          withLabel "outer" $+            tryToHaxlException $ withLabel "inner" $+              unsafeLiftIO $ evaluate $ force (error "pure exception" :: Int)+  profData <- labelToDataMap <$> readIORef (profRef env)+  assertBool "inner label not added" $+    not $ HashMap.member "inner" profData++  env2 <- mkProfilingEnv+  _x <- runHaxl env2 $+          withLabel "outer" $+            tryToHaxlException $ withLabel "inner" $+              throw $ NotFound "haxl exception"+  profData <- labelToDataMap <$> readIORef (profRef env2)+  assertBool "inner label added" $+    HashMap.member "inner" profData+++-- Test that we correctly attribute work done in child threads when+-- using BackgroundFetch to the caller of runHaxl. This is important+-- for correct accounting when relying on allocation limits.+threadAlloc :: Integer -> Assertion+threadAlloc batches = do+  env' <- initEnv (stateSet mkWorkState stateEmpty) () :: IO (Env () ())+  let env = env'  { flags = (flags env') {+    report = setReportFlag ReportFetchStats defaultReportFlags } }+  a0 <- getAllocationCounter+  let+    wsize = 100000+    w = forM [wsize..(wsize+batches-1)] work+  _x <- runHaxl env $ sum <$> w+  a1 <- getAllocationCounter+  let+    lower = fromIntegral $ 1000000 * batches+    upper = fromIntegral $ 25000000 * batches+  assertBool "threadAlloc lower bound" $ (a0 - a1) > lower+  assertBool "threadAlloc upper bound" $ (a0 - a1) < upper+    -- the result was 16MB on 64-bit, or around 25KB if we miss the allocs+    -- in the child thread. For batched it should be similarly scaled.+    -- When we do not reset the counter for each batch was+    -- scaled again by number of batches.++  stats <- readIORef (statsRef env)+  assertEqual+    "threadAlloc: batches"+    [fromIntegral batches]+    (aggregateFetchBatches length stats)+  -- if we actually do more than 1 batch then the above test is not useful++data MemoType = Global | Local++-- Test that we correctly attribute memo work+memos:: MemoType -> Assertion+memos memoType = do+  env <- mkProfilingEnv+  let+    memoAllocs = 10000000 :: Int64+    doWork = unsafeLiftIO $ do+      a0 <- getAllocationCounter+      setAllocationCounter $ a0 - memoAllocs+      return (5 :: Int)+    mkWork+      | Global <- memoType = return (memo (1 :: Int) doWork)+      | Local <- memoType = memoize doWork+  _ <- runHaxl env $ do+    work <- mkWork+    andThen+      (withLabel "do" work)+      (withLabel "cached" work)+  profData <- labelToDataMap <$> readIORef (profRef env)+  case HashMap.lookup "do" profData of+    Nothing -> assertFailure "do not in data"+    Just ProfileData{..} -> do+      assertEqual "has correct memo id" profileMemos [ProfileMemo 1 False]+      assertBool "allocs are included in 'do'" (profileAllocs >= memoAllocs)+  case HashMap.lookup "cached" profData of+    Nothing -> assertFailure "cached not in data"+    Just ProfileData{..} -> do+      assertEqual "has correct memo id" profileMemos [ProfileMemo 1 True]+      assertBool "allocs are *not* included in 'cached'" (profileAllocs < 50000)+  (Stats memoStats) <- readIORef (statsRef env)+  assertEqual "exactly 1 memo/fetch" 1 (length memoStats)+  let memoStat = head memoStats+  putStrLn $ "memoStat=" ++ show memoStat+  assertEqual "correct call id" 1 (memoStatId memoStat)+  assertBool "allocs are big enough" $ memoSpace memoStat >= memoAllocs+  assertBool "allocs are not too big" $ memoSpace memoStat < memoAllocs + 100000+++tests = TestList+  [ TestLabel "collectsdata" $ TestCase collectsdata+  , TestLabel "collectsdata - lazy" $ TestCase collectsLazyData+  , TestLabel "exceptions" $ TestCase exceptions+  , TestLabel "threads" $ TestCase (threadAlloc 1)+  , TestLabel "threads with batch" $ TestCase (threadAlloc 50)+  , TestLabel "memos - Global" $ TestCase (memos Global)+  , TestLabel "memos - Local" $ TestCase (memos Local)+  ]
+ tests/SleepDataSource.hs view
@@ -0,0 +1,48 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}++module SleepDataSource (+    Sleep, sleep,+  ) where++import Haxl.Prelude+import Prelude ()++import Haxl.Core+import Haxl.DataSource.ConcurrentIO++import Control.Concurrent+import Data.Hashable+import Data.Typeable++sleep :: Int -> GenHaxl u w Int+sleep n = dataFetch (Sleep n)++data Sleep deriving Typeable+instance ConcurrentIO Sleep where+  data ConcurrentIOReq Sleep a where+    Sleep :: Int -> ConcurrentIOReq Sleep Int++  performIO (Sleep n) = threadDelay (n*1000) >> return n++deriving instance Eq (ConcurrentIOReq Sleep a)+deriving instance Show (ConcurrentIOReq Sleep a)++instance ShowP (ConcurrentIOReq Sleep) where showp = show++instance Hashable (ConcurrentIOReq Sleep a) where+  hashWithSalt s (Sleep n) = hashWithSalt s n
+ tests/StatsTests.hs view
@@ -0,0 +1,195 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module StatsTests (tests) where++import Test.HUnit+import Data.List+import Data.Maybe++import Haxl.Prelude+import Haxl.Core+import Prelude()++import ExampleDataSource+import SleepDataSource+import Haxl.DataSource.ConcurrentIO++import Control.Monad (void)+import Data.IORef+import qualified Data.HashMap.Strict as HashMap++aggregateBatches :: Test+aggregateBatches = TestCase $ do+  let+    statsNoBatches = [ FetchStats { fetchDataSource = "foo"+                                  , fetchBatchSize = 7+                                  , fetchStart = 0+                                  , fetchDuration = 10+                                  , fetchSpace = 1+                                  , fetchFailures = 2+                                  , fetchIgnoredFailures = 0+                                  , fetchBatchId = n+                                  , fetchIds = [1,2] }+                                  | n <- reverse [1..10] ++ [11..20] ]+                     ++ [ FetchCall "A" ["B"] 1, FetchCall "C" ["D"] 2 ]+    fetchBatch = [ FetchStats { fetchDataSource = "batch"+                              , fetchBatchSize = 1+                              , fetchStart = 100+                              , fetchDuration = 1000 * n+                              , fetchSpace = 3+                              , fetchFailures = if n <= 3 then 1 else 0+                              , fetchIgnoredFailures = 0+                              , fetchBatchId = 123+                              , fetchIds = [fromIntegral n] } | n <- [1..50] ]+    agg (sz,bids) FetchStats{..} = (sz + fetchBatchSize, fetchBatchId:bids)+    agg _ _ = error "unexpected"+    agg' = foldl' agg (0,[])+    aggNoBatch = aggregateFetchBatches agg' (Stats statsNoBatches)+    expectedNoBatch = [(7, [n]) | n <- reverse [1..20] :: [Int]]+    aggBatch = aggregateFetchBatches agg' (Stats fetchBatch)+    expectedResultBatch = (50, [123 | _ <- [1..50] :: [Int]])+    aggInterspersedBatch =+      aggregateFetchBatches agg'+      (Stats $ intersperse (head fetchBatch) statsNoBatches)+    expectedResultInterspersed =+      (21, [123 | _ <- [1..21] :: [Int]]) : expectedNoBatch+  assertEqual "No batch has no change" expectedNoBatch aggNoBatch+  assertEqual "Batch is combined" [expectedResultBatch] aggBatch+  assertEqual+    "Grouping works as expected" expectedResultInterspersed aggInterspersedBatch++testEnv :: IO (Env () ())+testEnv = do+  -- To use a data source, we need to initialize its state:+  exstate <- ExampleDataSource.initGlobalState+  sleepState <- mkConcurrentIOState++  -- And create a StateStore object containing the states we need:+  let st = stateSet exstate (stateSet sleepState stateEmpty)++  -- Create the Env:+  env <- initEnv st ()+  return env{ flags = (flags env){+    report = setReportFlag ReportFetchStack profilingReportFlags } }+++fetchIdsSync :: Test+fetchIdsSync = TestCase $ do+  env <- testEnv+  _ <- runHaxl  env $+       sequence_+       [ void $ countAardvarks "abcabc" + (length <$> listWombats 3)+       , void $ listWombats 100+       , void $ listWombats 99+       , void $ countAardvarks "BANG4" `catch` \NotFound{} -> return 123+       ]+  -- expect a single DS stat+  (Stats stats) <- readIORef (statsRef env)+  let+    fetchStats = [x | x@FetchStats{} <- stats]+  assertEqual "Only 1 batch" 1 (length fetchStats)+  let+    [stat] = fetchStats+  assertEqual "No real failures" 0 (fetchFailures stat)+  assertEqual "1 ignored failure" 1 (fetchIgnoredFailures stat)++fetchIdsBackground :: Test+fetchIdsBackground = TestCase $ do+  env <- testEnv+  _ <- runHaxl  env $+       sequence_+       [ withLabel "short" $ sleep 1+       , withLabel "long" $ sleep 500 ]++  -- make sure that with memo'ing we still preserve the stack+  _ <- runHaxl  env $ withLabel "base"+    (memo (1 :: Int) $ withLabel "child" $ sleep 102)++  _ <- runHaxl env $ withLabel "short_cached" $ sleep 1++  -- expect a single DS stat+  (Stats stats) <- readIORef (statsRef env)+  (Profile p pt _) <- readIORef (profRef env)+  let+    keyMap =+      HashMap.fromList [ (label, k) | ((label,_), k) <- HashMap.toList pt]+    revMap = HashMap.fromList [(v,k) | (k,v) <- HashMap.toList pt]+    parentMap =+      HashMap.fromList $+      catMaybes+      [ case HashMap.lookup kp revMap of+          Just (lp,_) -> Just (label, lp)+          Nothing -> Nothing+      | ((label,kp), _) <- HashMap.toList pt]+    fetchMap =  HashMap.fromList [ (fid, x) | x@FetchStats{} <- stats+                                   , fid <- fetchIds x]+    get l = [ (prof, wasCached, fetchStat)+            | Just key <- [HashMap.lookup l keyMap]+            , Just prof <- [HashMap.lookup key p]+            , ProfileFetch fid _ wasCached <- profileFetches prof+            , Just fetchStat <- [HashMap.lookup fid fetchMap]]+    [(short, shortWC, shortFetch)] = get "short"+    [(long, longWC, longFetch)] = get "long"+    [(shortCached, shortCachedWC, shortCachedFetch)] = get "short_cached"++  assertEqual "3 batches" 3 (HashMap.size fetchMap)+  assertEqual "6 labels (inc MAIN)" 6 (HashMap.size keyMap)++  assertEqual "child parent is base"+    (Just "base")+    (HashMap.lookup "child" parentMap)++  assertEqual "base parent is MAIN"+    (Just "MAIN")+    (HashMap.lookup "base" parentMap)++  assertEqual "long parent is MAIN"+    (Just "MAIN")+    (HashMap.lookup "long" parentMap)++  assertBool "original fetches not cached (short)" (not shortWC)+  assertBool "original fetches not cached (long)" (not longWC)+  assertBool "was cached short" shortCachedWC++  assertEqual "one fetch short" 1 (length $ profileFetches short)+  assertEqual "one fetch long" 1 (length $ profileFetches long)+  assertEqual "one fetch short_cached" 1 (length $ profileFetches shortCached)++  assertBool "short fetch mapped properly" (fetchDuration shortFetch < 100000)+  assertEqual+    "short cached fetch mapped properly"+    (fetchDuration shortFetch)+    (fetchDuration shortCachedFetch)+  assertBool "long fetch was mapped properly" (fetchDuration longFetch > 100000)+++ppStatsTest :: Test+ppStatsTest = TestCase $ do+  let+    r = ppStats (Stats [])+    mc = ppStats (Stats [MemoCall 0 0])+    fc = ppStats (Stats [FetchCall "" [] 0])+    fw = ppStats (Stats [FetchWait HashMap.empty 0 1])+    fs = ppStats (Stats [FetchStats "" 0 0 0 0 0 0 0 []])+  assertEqual "empty stats -> empty string" r ""+  assertEqual "memo call stats -> empty string" mc ""+  assertEqual "fetch call stats -> empty string" fc ""+  assertBool "fetch wait stats -> some data" (not $ null fw)+  assertBool "fetch stats -> some data" (not $ null fs)+++tests = TestList [ TestLabel "Aggregate Batches" aggregateBatches+                 , TestLabel "Fetch IDs Sync" fetchIdsSync+                 , TestLabel "Fetch IDs Background" fetchIdsBackground+                 , TestLabel "ppStats" ppStatsTest ]
+ tests/TestBadDataSource.hs view
@@ -0,0 +1,130 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+module TestBadDataSource (tests) where++import Haxl.Prelude as Haxl+import Prelude()++import Haxl.Core++import Data.IORef+import Test.HUnit+import Control.Exception+import System.Mem++import ExampleDataSource+import BadDataSource++testEnv impl fn = do+  -- Use allocation limits, just to make sure haxl properly behaves and+  -- doesn't reset this internally somewhere.+  -- `go` will disable this+  setAllocationCounter 5000000 -- 5 meg should be enough, uses ~100k atm+  enableAllocationLimit+  exstate <- ExampleDataSource.initGlobalState+  badstate <- BadDataSource.initGlobalState impl+  let st = stateSet exstate $ stateSet (fn badstate) stateEmpty+  initEnv st ()++wombats :: GenHaxl () () Int+wombats = length <$> listWombats 3++wombatsMany :: GenHaxl () () Int+wombatsMany = length <$> listWombats 7++go :: FetchImpl -> Test+go impl = TestCase $ flip finally disableAllocationLimit $ do+  -- test that a failed acquire doesn't fail the other requests+  ref <- newIORef False+  env <- testEnv impl $ \st ->+    st { failAcquire = throwIO (DataSourceError "acquire")+       , failRelease = writeIORef ref True }++  x <- runHaxl env $+        (dataFetch (FailAfter 0) + wombatsMany)+          `Haxl.catch` \DataSourceError{} -> wombats++  assertEqual "badDataSourceTest1" 3 x++  -- We should *not* have called release+  assertEqual "badDataSourceTest2" False =<< readIORef ref++  -- test that a failed dispatch doesn't fail the other requests+  ref <- newIORef False+  env <- testEnv impl $ \st ->+    st { failDispatch = throwIO (DataSourceError "dispatch")+       , failRelease = writeIORef ref True }++  x <- runHaxl env $+        (dataFetch (FailAfter 0) + wombatsMany)+          `Haxl.catch` \DataSourceError{} -> wombats++  assertEqual "badDataSourceTest3" x 3++  -- We *should* have called release+  assertEqual "badDataSourceTest4" True =<< readIORef ref++  -- test that a failed wait is a DataSourceError+  env <- testEnv impl $ \st ->+    st { failWait = throwIO (DataSourceError "wait") }++  x <- runHaxl env $+        (dataFetch (FailAfter 0) + wombatsMany)+          `Haxl.catch` \DataSourceError{} -> wombats++  assertEqual "badDataSourceTest5" x 3++  -- We *should* have called release+  assertEqual "badDataSourceTest6" True =<< readIORef ref++  -- test that a failed release is still a DataSourceError, even+  -- though the request will have completed successfully+  env <- testEnv impl $ \st ->+    st { failRelease = throwIO (DataSourceError "release") }++  let+    -- In background fetches the scheduler might happen to process the data+    -- source result (FetchError in this case) before it processes the exception+    -- from release. So we have to allow both cases.+    isBg = case impl of+      Background -> True+      BackgroundMVar -> True+      _ -> False+    releaseCatcher e+      | Just DataSourceError{} <- fromException e = wombats+      | Just FetchError{} <- fromException e =+          if isBg then wombats else Haxl.throw e+      | otherwise = Haxl.throw e++  x <- runHaxl env $+        (dataFetch (FailAfter 0) + wombatsMany)+          `Haxl.catch` releaseCatcher++  assertEqual "badDataSourceTest7" x 3++  -- test that if we don't throw anything we get the result+  -- (which is a fetch error for this source)+  env <- testEnv impl id+  x <- runHaxl env $+        (dataFetch (FailAfter 0) + wombatsMany)+          `Haxl.catch` \FetchError{} -> wombats++  assertEqual "badDataSourceTest8" x 3+++++tests = TestList+  [ TestLabel "badDataSourceTest async" (go Async)+  , TestLabel "badDataSourceTest background" (go Background)+  , TestLabel "badDataSourceTest backgroundMVar" (go BackgroundMVar)+  , TestLabel "badDataSourceTest backgroundFetchSeq" (go BackgroundSeq)+  , TestLabel "badDataSourceTest backgroundFetchPar" (go BackgroundPar)+  ]
tests/TestExampleDataSource.hs view
@@ -1,4 +1,13 @@-{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP, OverloadedStrings, RebindableSyntax, MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-} module TestExampleDataSource (tests) where  import Haxl.Prelude as Haxl@@ -7,14 +16,17 @@ import Haxl.Core.Monad (unsafeLiftIO) import Haxl.Core -import qualified Data.HashMap.Strict as HashMap import Test.HUnit import Data.IORef+import Data.Maybe import Control.Exception+import System.Environment+import System.FilePath  import ExampleDataSource import LoadCache +testEnv :: IO (Env () ()) testEnv = do   -- To use a data source, we need to initialize its state:   exstate <- ExampleDataSource.initGlobalState@@ -23,7 +35,9 @@   let st = stateSet exstate stateEmpty    -- Create the Env:-  initEnv st ()+  env <- initEnv st ()+  return env{ flags = (flags env){+    report = setReportFlag ReportFetchStats defaultReportFlags } }   tests = TestList [@@ -31,8 +45,12 @@   TestLabel "orderTest" orderTest,   TestLabel "preCacheTest" preCacheTest,   TestLabel "cachedComputationTest" cachedComputationTest,+  TestLabel "cacheResultTest" cacheResultTest,+  TestLabel "memoTest" memoTest,   TestLabel "dataSourceExceptionTest" dataSourceExceptionTest,-  TestLabel "dumpCacheAsHaskell" dumpCacheTest]+  TestLabel "dumpCacheAsHaskell" dumpCacheTest,+  TestLabel "fetchError" fetchError+  ]  -- Let's test ExampleDataSource. @@ -47,12 +65,16 @@   assertEqual "runTests" x (2 + 3)    -- Should be just one fetching round:-  Stats s <- readIORef (statsRef env)-  assertEqual "rounds" 1 (length s)+  Stats stats <- readIORef (statsRef env)+  putStrLn (ppStats (Stats stats))+  assertEqual "rounds" 1 (length stats)    -- With two fetches:-  let reqs = case head s of RoundStats m -> HashMap.lookup "ExampleDataSource" m-  assertEqual "reqs" (Just 2) reqs+  assertBool "reqs" $+    case stats of+       [FetchStats{..}] ->+         fetchDataSource == "ExampleDataSource" && fetchBatchSize == 2+       _otherwise -> False  -- Test side-effect ordering @@ -90,8 +112,8 @@    x <- runHaxl env $ do     cacheRequest (CountAardvarks "xxx") (Right 3)-    cacheRequest (ListWombats 100) (Right [1,2,3])-    countAardvarks "xxx" + (length <$> listWombats 100)+    cacheRequest (ListWombats 1000000) (Right [1,2,3])+    countAardvarks "xxx" + (length <$> listWombats 1000000)   assertEqual "preCacheTest1" x (3 + 3)    y <- Control.Exception.try $ runHaxl env $ do@@ -119,24 +141,84 @@   stats <- readIORef (statsRef env)   assertEqual "fetches" 3 (numFetches stats) +cacheResultTest = TestCase $ do+  env <- testEnv+  ref <- newIORef 0+  let request = cacheResult (CountAardvarks "ababa") $ do+         modifyIORef ref (+1)+         readIORef ref+  r <- runHaxl env $ (+) <$> request <*> request+  assertEqual "cacheResult" 2 r+++-- Pretend CountAardvarks is a request computed by some Haxl code+memoTest = TestCase $ do+  env <- testEnv+  let env' = env { flags = (flags env){trace = 3} }++  let x = memo (CountAardvarks "ababa") $ do+        a <- length <$> listWombats 10+        b <- length <$> listWombats 20+        return (a + b)++  r <- runHaxl env' $ x + x + countAardvarks "baba"++  assertEqual "memoTest1" 62 r++  stats <- readIORef (statsRef env)+  assertEqual "fetches" 3 (numFetches stats)++-- Test that the FetchError gets returned properly, and that we have+-- a failure logged in the stats.+fetchError = TestCase $ do+  env <- testEnv+  r <- runHaxl env $ Haxl.try $+    (++) <$> listWombats 1000000 <*> listWombats 1000001+  assertBool "fetchError1" $ case r of+    Left FetchError{} -> True+    Right _ -> False+  Stats stats <- readIORef (statsRef env)+  assertEqual "fetchError2" 2 (sum [ fetchFailures | FetchStats{..} <- stats ])+ dataSourceExceptionTest = TestCase $ do   env <- testEnv+   r <- runHaxl env $ Haxl.try $ countAardvarks "BANG"-  assertBool "exception" $+  assertBool "exception1" $     case r of       Left (ErrorCall "BANG") -> True       _ -> False   r <- runHaxl env $ Haxl.try $ countAardvarks "BANG2"-  assertBool "exception" $+  assertBool "exception2" $     case r of       Left (ErrorCall "BANG2") -> True       _ -> False +  -- In this test, BANG3 is an asynchronous exception (ThreadKilled),+  -- so we should see that instead of the exception on the left.+  -- Furthermore, it doesn't get caught by Haxl.try, and we have to+  -- catch it outside of runHaxl.+  env <- testEnv+  r <- Control.Exception.try $ runHaxl env $ Haxl.try $+          (length <$> listWombats 100) + countAardvarks "BANG3"+  print r+  assertBool "exception3" $+    case (r :: Either AsyncException (Either SomeException Int)) of+       Left ThreadKilled -> 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+  lcPath <-loadCachePath+  loadcache <- readFile lcPath+  -- The order of 'cacheRequest ...' calls is nondeterministic and+  -- differs among GHC versions, so we sort the lines for comparison.+  assertEqual "dumpCacheAsHaskell" (sort $ lines loadcache) (sort $ lines str)+  where+    loadCachePath = do+      lcEnv <- lookupEnv "LOADCACHE"+      return $ fromMaybe (dropFileName __FILE__ </> "LoadCache.txt") lcEnv
+ tests/TestMain.hs view
@@ -0,0 +1,17 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP, OverloadedStrings #-}+module Main where++import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import AllTests++main :: IO ()+main = defaultMain $ hUnitTestToTests allTests
tests/TestTypes.hs view
@@ -1,42 +1,65 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  module TestTypes    ( UserEnv    , Haxl+   , HaxlEnv    , lookupInput    , Id(..)    ) where  import Data.Aeson-import Data.Text (Text)+import Data.Binary (Binary) import qualified Data.Text as Text-import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.Key (toText)+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import Data.Hashable import Data.Typeable  import Haxl.Core +#if !MIN_VERSION_aeson(2,0,0)+type Key = Text.Text++toText :: Key -> Text.Text+toText = id+#endif+ type UserEnv = Object-type Haxl a = GenHaxl UserEnv a+type Haxl a = GenHaxl UserEnv () a+type HaxlEnv = Env UserEnv () -lookupInput :: FromJSON a => Text -> Haxl a+lookupInput :: FromJSON a => Key -> Haxl a lookupInput field = do-  mb_val <- env (HashMap.lookup field . userEnv)+  mb_val <- env (KeyMap.lookup field . userEnv)   case mb_val of     Nothing ->-      throw (NotFound (Text.concat ["field ", field, " was not found."]))+      throw (NotFound (Text.concat ["field ", toText field, " was not found."]))     Just val ->       case fromJSON val of         Error str ->           throw (UnexpectedType (Text.concat-            ["field ", field, ": ", Text.pack str]))+            ["field ", toText field, ": ", Text.pack str]))         Success a -> return a   newtype Id = Id Int-  deriving (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable,+  deriving (Eq, Ord, Binary, Enum, Num, Integral, Real, Hashable, Typeable,             ToJSON, FromJSON)  instance Show Id where
+ tests/TestUtils.hs view
@@ -0,0 +1,82 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module TestUtils+  ( makeTestEnv+  , expectResultWithEnv+  , expectResult+  , expectFetches+  , testinput+  , id1, id2, id3, id4+  ) where++import TestTypes+import MockTAO+import Haxl.DataSource.ConcurrentIO++import Data.IORef+import Data.Aeson+import Test.HUnit+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif++import Haxl.Core++import Prelude()+import Haxl.Prelude++testinput :: Object+testinput = KeyMap.fromList [+  "A" .= (1 :: Int),+  "B" .= (2 :: Int),+  "C" .= (3 :: Int),+  "D" .= (4 :: Int) ]++id1 :: Haxl Id+id1 = lookupInput "A"++id2 :: Haxl Id+id2 = lookupInput "B"++id3 :: Haxl Id+id3 = lookupInput "C"++id4 :: Haxl Id+id4 = lookupInput "D"++makeTestEnv :: Bool -> IO HaxlEnv+makeTestEnv future = do+  tao <- MockTAO.initGlobalState future+  stio <- mkConcurrentIOState+  let st = stateSet stio $ stateSet tao stateEmpty+  env <- initEnv st testinput+  return env { flags = (flags env) {+    report = setReportFlag ReportFetchStats defaultReportFlags } }++expectResultWithEnv+  :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion+expectResultWithEnv result haxl env = do+  a <- runHaxl env haxl+  assertEqual "result" result a++expectResult :: (Eq a, Show a) => a -> Haxl a -> Bool -> Assertion+expectResult result haxl future = do+  env <- makeTestEnv future+  expectResultWithEnv result haxl env++expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Bool -> Assertion+expectFetches n haxl future = do+  env <- makeTestEnv future+  _ <- runHaxl env haxl+  stats <- readIORef (statsRef env)+  assertEqual "fetches" n (numFetches stats)
+ tests/WorkDataSource.hs view
@@ -0,0 +1,87 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module WorkDataSource (+    mkWorkState,+    work,+  ) where++import Haxl.Prelude+import Prelude ()++import Haxl.Core++import Control.Exception+import Data.Hashable+import Data.Typeable+import Control.Monad (void)+import Control.Concurrent.MVar+++data Work a where+  Work :: Integer -> Work Integer+  deriving Typeable++deriving instance Eq (Work a)+deriving instance Show (Work a)+instance ShowP Work where showp = show++instance Hashable (Work a) where+   hashWithSalt s (Work a) = hashWithSalt s (0::Int,a)++instance DataSourceName Work where+  dataSourceName _ = "Work"++instance StateKey Work where+  data State Work = WorkState++newtype Service = Service (MVar [IO ()])++run :: Work a -> IO a+run (Work n) = evaluate (sum [1..n]) >> return n++mkService :: IO Service+mkService = Service <$> newMVar []++process :: Service -> IO ()+process (Service q) = do+  r <- swapMVar q []+  sequence_ r++enqueue :: Service -> Work a -> IO (IO (Either SomeException a))+enqueue (Service q) w = do+  res <- newEmptyMVar+  let r = do+        v <- Control.Exception.try $ run w+        putMVar res v+  modifyMVar_ q (return . (:) r)+  return (takeMVar res)++instance DataSource u Work where+  fetch = backgroundFetchAcquireReleaseMVar+    mkService+    (\_ -> return ())+    -- pretend we are ready so that process does the work+    (\_ _ m -> void $ tryPutMVar m ())+    process+    enqueue+++mkWorkState :: State Work+mkWorkState = WorkState++work :: Integer -> GenHaxl u w Integer+work n = dataFetch (Work n)
+ tests/WriteTests.hs view
@@ -0,0 +1,300 @@+{-+  Copyright (c) Meta Platforms, Inc. and affiliates.+  All rights reserved.++  This source code is licensed under the BSD-style license found in the+  LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+module WriteTests (tests) where++import Test.HUnit++import Control.Arrow+import Control.Concurrent+import Data.Either+import Data.Foldable+import Data.Hashable+import Data.IORef+import qualified Data.Text as Text++import Haxl.Core.Monad (mapWrites, mapWriteTree, flattenWT, WriteTree)+import Haxl.Core+import Haxl.Prelude as Haxl++-- A fake data source+data SimpleDataSource a where+  GetNumber :: SimpleDataSource Int++deriving instance Eq (SimpleDataSource a)+deriving instance Show (SimpleDataSource a)+instance ShowP SimpleDataSource where showp = show++instance Hashable (SimpleDataSource a) where+  hashWithSalt s GetNumber = hashWithSalt s (0 :: Int)++instance StateKey SimpleDataSource where+  data State SimpleDataSource = DSState++instance DataSourceName SimpleDataSource where+  dataSourceName _ = "SimpleDataSource"++instance DataSource u SimpleDataSource where+  fetch _st _flags _usr  = SyncFetch $ Haxl.mapM_ fetch1+    where+    fetch1 :: BlockedFetch SimpleDataSource -> IO ()+    fetch1 (BlockedFetch GetNumber m) =+      threadDelay 1000 >> putSuccess m 37++newtype SimpleWrite = SimpleWrite Text+  deriving (Eq, Show, Ord)++assertEqualIgnoreOrder ::+  (Eq a, Show a, Ord a) => String -> [a] -> [a] -> Assertion+assertEqualIgnoreOrder msg lhs rhs =+  assertEqual msg (sort lhs) (sort rhs)++doInnerWrite :: GenHaxl u (WriteTree SimpleWrite) Int+doInnerWrite = do+  tellWrite $ SimpleWrite "inner"+  return 0++doOuterWrite :: GenHaxl u (WriteTree SimpleWrite) Int+doOuterWrite = do+  tellWrite $ SimpleWrite "outer1"++  doWriteMemo <- newMemoWith doInnerWrite+  let doMemoizedWrite = runMemo doWriteMemo+  _ <- doMemoizedWrite+  _ <- doMemoizedWrite++  tellWrite $ SimpleWrite "outer2"++  return 1++doNonMemoWrites :: GenHaxl u (WriteTree SimpleWrite) Int+doNonMemoWrites = do+  tellWrite $ SimpleWrite "inner"+  tellWriteNoMemo $ SimpleWrite "inner not memo"+  return 0++runHaxlWithWriteList :: Env u (WriteTree w) -> GenHaxl u (WriteTree w) a -> IO (a, [w])+runHaxlWithWriteList env haxl = second flattenWT <$> runHaxlWithWrites env haxl++writeSoundness :: Test+writeSoundness = TestCase $ do+  let numReps = 4++  -- do writes without memoization+  env1 <- emptyEnv ()+  (allRes, allWrites) <- runHaxlWithWriteList env1 $+    Haxl.sequence (replicate numReps doInnerWrite)++  assertBool "Write Soundness 1" $+    allWrites == replicate numReps (SimpleWrite "inner")+  assertBool "Write Soundness 2" $ allRes == replicate numReps 0++  -- do writes with memoization+  env2 <- emptyEnv ()++  (memoRes, memoWrites) <- runHaxlWithWriteList env2 $ do+    doWriteMemo <- newMemoWith doInnerWrite+    let memoizedWrite = runMemo doWriteMemo++    Haxl.sequence (replicate numReps memoizedWrite)++  assertBool "Write Soundness 3" $+    memoWrites == replicate numReps (SimpleWrite "inner")+  assertBool "Write Soundness 4" $ memoRes == replicate numReps 0++  -- do writes with interleaved memo+  env3 <- emptyEnv ()++  (ilRes, ilWrites) <- runHaxlWithWriteList env3 $ do+    doWriteMemo <- newMemoWith doInnerWrite+    let memoizedWrite = runMemo doWriteMemo++    Haxl.sequence $ replicate numReps (doInnerWrite *> memoizedWrite)++  assertBool "Write Soundness 5" $+    ilWrites == replicate (2*numReps) (SimpleWrite "inner")+  assertBool "Write Soundness 6" $ ilRes == replicate numReps 0++  -- do writes with nested memo+  env4 <- emptyEnv ()++  (nestRes, nestWrites) <- runHaxlWithWriteList env4 $ do+    doWriteMemo' <- newMemoWith doOuterWrite+    let memoizedWrite' = runMemo doWriteMemo'++    Haxl.sequence (replicate numReps memoizedWrite')++  let expWrites =+        [ SimpleWrite "outer1"+        , SimpleWrite "inner"+        , SimpleWrite "inner"+        , SimpleWrite "outer2"+        ]+  assertBool "Write Soundness 7" $+    nestWrites == fold (replicate numReps expWrites)+  assertBool "Write Soundness 8" $ nestRes == replicate numReps 1++  -- do both kinds of writes without memoization+  env5 <- emptyEnv ()+  (allRes, allWrites) <- runHaxlWithWriteList env5 $+    Haxl.sequence (replicate numReps doNonMemoWrites)++  assertBool "Write Soundness 9" $+    allWrites == replicate numReps (SimpleWrite "inner") +++      replicate numReps (SimpleWrite "inner not memo")+  assertBool "Write Soundness 10" $ allRes == replicate numReps 0++  -- do both kinds of writes with memoization+  env6 <- emptyEnv ()++  (memoRes, memoWrites) <- runHaxlWithWriteList env6 $ do+    doWriteMemo <- newMemoWith doNonMemoWrites+    let memoizedWrite = runMemo doWriteMemo++    Haxl.sequence (replicate numReps memoizedWrite)++  -- "inner not memo" only appears once in this test+  assertBool "Write Soundness 11" $+    memoWrites == replicate numReps (SimpleWrite "inner") +++      [SimpleWrite "inner not memo"]+  assertBool "Write Soundness 12" $ memoRes == replicate numReps 0++writeLogsCorrectnessTest :: Test+writeLogsCorrectnessTest = TestLabel "writeLogs_correctness" $ TestCase $ do+  e <- emptyEnv ()+  (_ , wrts) <- runHaxlWithWriteList e doNonMemoWrites+  assertEqualIgnoreOrder "Expected writes" [SimpleWrite "inner",+    SimpleWrite "inner not memo"] wrts+  wrtsNoMemo <- readIORef $ writeLogsRefNoMemo e+  wrtsMemo <- readIORef $ writeLogsRef e+  assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsNoMemo+  assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsMemo++mapWritesTest :: Test+mapWritesTest = TestLabel "mapWrites" $ TestCase $ do+  let funcSingle (SimpleWrite s) = SimpleWrite $ Text.toUpper s+      func = mapWriteTree funcSingle+  env0 <- emptyEnv ()+  (res0, wrts0) <- runHaxlWithWriteList env0 $ mapWrites func doNonMemoWrites+  assertEqual "Expected computation result" 0 res0+  assertEqualIgnoreOrder "Writes correctly transformed" [SimpleWrite "INNER",+    SimpleWrite "INNER NOT MEMO"] wrts0++  -- Writes should behave the same inside and outside mapWrites+  env1 <- emptyEnv ()+  (res1, wrts1) <- runHaxlWithWriteList env1 $ do+    outer <- doOuterWrite+    outerMapped <- mapWrites func doOuterWrite+    return $ outer == outerMapped+  assertBool "Results are identical" res1+  assertEqualIgnoreOrder+    "Writes correctly transformed, non-transformed writes preserved"+    [ SimpleWrite "outer1", SimpleWrite "inner"+    , SimpleWrite "inner", SimpleWrite "outer2"+    , SimpleWrite "OUTER1", SimpleWrite "INNER"+    , SimpleWrite "INNER", SimpleWrite "OUTER2"+    ]+    wrts1++  -- Memoization behaviour should be unaffected+  env2 <- emptyEnv ()+  (_res2, wrts2) <- runHaxlWithWriteList env2 $ do+    writeMemo <- newMemoWith doNonMemoWrites+    let doWriteMemo = runMemo writeMemo+    _ <- mapWrites func doWriteMemo+    _ <- doWriteMemo+    return ()+  -- "inner not memo" should appear only once+  assertEqualIgnoreOrder+    "Write correctly transformed under memoization"+    [ SimpleWrite "INNER"+    , SimpleWrite "inner"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts2++  -- Same as previous, but the non-mapped computation is run first+  env3 <- emptyEnv ()+  (_res3, wrts3) <- runHaxlWithWriteList env3 $ do+    writeMemo <- newMemoWith doNonMemoWrites+    let doWriteMemo = runMemo writeMemo+    _ <- doWriteMemo+    _ <- mapWrites func doWriteMemo+    return ()+  -- "inner not memo" should appear only once+  assertEqualIgnoreOrder+    "Flipped: Write correctly transformed under memoization"+    [ SimpleWrite "inner"+    , SimpleWrite "INNER"+    , SimpleWrite "inner not memo"+    ]+    wrts3++  -- inner computation performs no writes+  env4 <- emptyEnv ()+  (res4, wrts4) <- runHaxlWithWriteList env4 $+    mapWrites func (return (0 :: Int))+  assertEqual "No Writes: Expected computation result" 0 res4+  assertEqualIgnoreOrder "No writes" [] wrts4++  -- inner computation throws an exception+  env5 <- emptyEnv ()+  (res5, wrts5) <- runHaxlWithWriteList env5 $ mapWrites func $ try $ do+    _ <- doNonMemoWrites+    _ <- throw (NotFound "exception")+    return 0+  assertBool "Throw: Expected Computation Result" $ isLeft+    (res5 :: Either HaxlException Int)+  assertEqualIgnoreOrder+    "Datasource writes correctly transformed"+    [ SimpleWrite "INNER"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts5++  -- inner computation calls a datasource+  env6 <- initEnv (stateSet DSState stateEmpty) ()+  (res6, wrts6) <- runHaxlWithWriteList env6 $ mapWrites func $ do+    _ <- doNonMemoWrites+    dataFetch GetNumber++  assertEqual "Datasource: Expected Computation Result" 37 res6+  assertEqualIgnoreOrder+    "Datasource writes correctly transformed"+    [ SimpleWrite "INNER"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts6++  -- inner computation calls a datasource, flipped calls+  env7 <- initEnv (stateSet DSState stateEmpty) ()+  (res7, wrts7) <- runHaxlWithWriteList env7 $ mapWrites func $ do+    df <- dataFetch GetNumber+    _ <- doNonMemoWrites+    return df++  assertEqual "Flipped Datasource: Expected Computation Result" 37 res7+  assertEqualIgnoreOrder+    "Flipped: Datasource writes correctly transformed"+    [ SimpleWrite "INNER"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts7++tests = TestList+  [ TestLabel "Write Soundness" writeSoundness,+    TestLabel "writeLogs_correctness" writeLogsCorrectnessTest,+    TestLabel "mapWrites" mapWritesTest+  ]