diff --git a/Haxl/Core.hs b/Haxl/Core.hs --- a/Haxl/Core.hs +++ b/Haxl/Core.hs @@ -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 diff --git a/Haxl/Core/CallGraph.hs b/Haxl/Core/CallGraph.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/CallGraph.hs @@ -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) diff --git a/Haxl/Core/DataCache.hs b/Haxl/Core/DataCache.hs --- a/Haxl/Core/DataCache.hs +++ b/Haxl/Core/DataCache.hs @@ -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 diff --git a/Haxl/Core/DataSource.hs b/Haxl/Core/DataSource.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/DataSource.hs @@ -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 +-- . +-- +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) diff --git a/Haxl/Core/Env.hs b/Haxl/Core/Env.hs deleted file mode 100644 --- a/Haxl/Core/Env.hs +++ /dev/null @@ -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 diff --git a/Haxl/Core/Exception.hs b/Haxl/Core/Exception.hs --- a/Haxl/Core/Exception.hs +++ b/Haxl/Core/Exception.hs @@ -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) diff --git a/Haxl/Core/Fetch.hs b/Haxl/Core/Fetch.hs --- a/Haxl/Core/Fetch.hs +++ b/Haxl/Core/Fetch.hs @@ -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 diff --git a/Haxl/Core/Flags.hs b/Haxl/Core/Flags.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Flags.hs @@ -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 diff --git a/Haxl/Core/Memo.hs b/Haxl/Core/Memo.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Memo.hs @@ -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 diff --git a/Haxl/Core/Monad.hs b/Haxl/Core/Monad.hs --- a/Haxl/Core/Monad.hs +++ b/Haxl/Core/Monad.hs @@ -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 diff --git a/Haxl/Core/Parallel.hs b/Haxl/Core/Parallel.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Parallel.hs @@ -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 ()'" diff --git a/Haxl/Core/Profile.hs b/Haxl/Core/Profile.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Profile.hs @@ -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 diff --git a/Haxl/Core/RequestStore.hs b/Haxl/Core/RequestStore.hs --- a/Haxl/Core/RequestStore.hs +++ b/Haxl/Core/RequestStore.hs @@ -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 + ] diff --git a/Haxl/Core/Run.hs b/Haxl/Core/Run.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Run.hs @@ -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 diff --git a/Haxl/Core/Show1.hs b/Haxl/Core/Show1.hs deleted file mode 100644 --- a/Haxl/Core/Show1.hs +++ /dev/null @@ -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 diff --git a/Haxl/Core/ShowP.hs b/Haxl/Core/ShowP.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/ShowP.hs @@ -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 diff --git a/Haxl/Core/StateStore.hs b/Haxl/Core/StateStore.hs --- a/Haxl/Core/StateStore.hs +++ b/Haxl/Core/StateStore.hs @@ -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) diff --git a/Haxl/Core/Stats.hs b/Haxl/Core/Stats.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Stats.hs @@ -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 diff --git a/Haxl/Core/Types.hs b/Haxl/Core/Types.hs deleted file mode 100644 --- a/Haxl/Core/Types.hs +++ /dev/null @@ -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 --- . --- -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 diff --git a/Haxl/Core/Util.hs b/Haxl/Core/Util.hs --- a/Haxl/Core/Util.hs +++ b/Haxl/Core/Util.hs @@ -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 diff --git a/Haxl/DataSource/ConcurrentIO.hs b/Haxl/DataSource/ConcurrentIO.hs new file mode 100644 --- /dev/null +++ b/Haxl/DataSource/ConcurrentIO.hs @@ -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) diff --git a/Haxl/Prelude.hs b/Haxl/Prelude.hs --- a/Haxl/Prelude.hs +++ b/Haxl/Prelude.hs @@ -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) || diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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, diff --git a/PATENTS b/PATENTS deleted file mode 100644 --- a/PATENTS +++ /dev/null @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 diff --git a/haxl.cabal b/haxl.cabal --- a/haxl.cabal +++ b/haxl.cabal @@ -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 -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 diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -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. diff --git a/tests/AdoTests.hs b/tests/AdoTests.hs new file mode 100644 --- /dev/null +++ b/tests/AdoTests.hs @@ -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) + ] diff --git a/tests/AllTests.hs b/tests/AllTests.hs new file mode 100644 --- /dev/null +++ b/tests/AllTests.hs @@ -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 + ] diff --git a/tests/BadDataSource.hs b/tests/BadDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/BadDataSource.hs @@ -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 + } diff --git a/tests/BatchTests.hs b/tests/BatchTests.hs --- a/tests/BatchTests.hs +++ b/tests/BatchTests.hs @@ -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) + ] diff --git a/tests/Bench.hs b/tests/Bench.hs new file mode 100644 --- /dev/null +++ b/tests/Bench.hs @@ -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) diff --git a/tests/CoreTests.hs b/tests/CoreTests.hs --- a/tests/CoreTests.hs +++ b/tests/CoreTests.hs @@ -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 ] diff --git a/tests/DataCacheTest.hs b/tests/DataCacheTest.hs --- a/tests/DataCacheTest.hs +++ b/tests/DataCacheTest.hs @@ -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 + ] diff --git a/tests/DataSourceDispatchTests.hs b/tests/DataSourceDispatchTests.hs new file mode 100644 --- /dev/null +++ b/tests/DataSourceDispatchTests.hs @@ -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 + ] diff --git a/tests/ExampleDataSource.hs b/tests/ExampleDataSource.hs --- a/tests/ExampleDataSource.hs +++ b/tests/ExampleDataSource.hs @@ -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) diff --git a/tests/ExceptionStackTests.hs b/tests/ExceptionStackTests.hs new file mode 100644 --- /dev/null +++ b/tests/ExceptionStackTests.hs @@ -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 + ] diff --git a/tests/FullyAsyncTest.hs b/tests/FullyAsyncTest.hs new file mode 100644 --- /dev/null +++ b/tests/FullyAsyncTest.hs @@ -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 +-} diff --git a/tests/LoadCache.hs b/tests/LoadCache.hs --- a/tests/LoadCache.hs +++ b/tests/LoadCache.hs @@ -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 diff --git a/tests/LoadCache.txt b/tests/LoadCache.txt --- a/tests/LoadCache.txt +++ b/tests/LoadCache.txt @@ -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)) diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -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 - ] diff --git a/tests/MemoizationTests.hs b/tests/MemoizationTests.hs new file mode 100644 --- /dev/null +++ b/tests/MemoizationTests.hs @@ -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] diff --git a/tests/MockTAO.hs b/tests/MockTAO.hs --- a/tests/MockTAO.hs +++ b/tests/MockTAO.hs @@ -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 diff --git a/tests/MonadAsyncTest.hs b/tests/MonadAsyncTest.hs new file mode 100644 --- /dev/null +++ b/tests/MonadAsyncTest.hs @@ -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 () diff --git a/tests/MonadBench.hs b/tests/MonadBench.hs new file mode 100644 --- /dev/null +++ b/tests/MonadBench.hs @@ -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] diff --git a/tests/OutgoneFetchesTests.hs b/tests/OutgoneFetchesTests.hs new file mode 100644 --- /dev/null +++ b/tests/OutgoneFetchesTests.hs @@ -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 + ] diff --git a/tests/ParallelTests.hs b/tests/ParallelTests.hs new file mode 100644 --- /dev/null +++ b/tests/ParallelTests.hs @@ -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) + ] diff --git a/tests/ProfileTests.hs b/tests/ProfileTests.hs new file mode 100644 --- /dev/null +++ b/tests/ProfileTests.hs @@ -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) + ] diff --git a/tests/SleepDataSource.hs b/tests/SleepDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/SleepDataSource.hs @@ -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 diff --git a/tests/StatsTests.hs b/tests/StatsTests.hs new file mode 100644 --- /dev/null +++ b/tests/StatsTests.hs @@ -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 ] diff --git a/tests/TestBadDataSource.hs b/tests/TestBadDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/TestBadDataSource.hs @@ -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) + ] diff --git a/tests/TestExampleDataSource.hs b/tests/TestExampleDataSource.hs --- a/tests/TestExampleDataSource.hs +++ b/tests/TestExampleDataSource.hs @@ -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 diff --git a/tests/TestMain.hs b/tests/TestMain.hs new file mode 100644 --- /dev/null +++ b/tests/TestMain.hs @@ -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 diff --git a/tests/TestTypes.hs b/tests/TestTypes.hs --- a/tests/TestTypes.hs +++ b/tests/TestTypes.hs @@ -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 diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/TestUtils.hs @@ -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) diff --git a/tests/WorkDataSource.hs b/tests/WorkDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/WorkDataSource.hs @@ -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) diff --git a/tests/WriteTests.hs b/tests/WriteTests.hs new file mode 100644 --- /dev/null +++ b/tests/WriteTests.hs @@ -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 + ]