diff --git a/Haxl/Core.hs b/Haxl/Core.hs --- a/Haxl/Core.hs +++ b/Haxl/Core.hs @@ -2,103 +2,107 @@ -- 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. +-- found in the LICENSE file. -- | Everything needed to define data sources and to invoke the -- engine. -- module Haxl.Core ( - -- * The monad and operations - GenHaxl (..), runHaxl, + -- * The monad and operations + GenHaxl (..), runHaxl - -- ** Env - Env(..), Caches, caches, - -- *** Operations in the monad - env, withEnv, withLabel, - -- *** Building the Env - initEnvWithData, initEnv, emptyEnv, - -- *** Building the StateStore - StateStore, stateGet, stateSet, stateEmpty, + -- ** Env + , Env(..), Caches, caches + -- *** Operations in the monad + , env, withEnv, withLabel + -- *** Building the Env + , initEnvWithData, initEnv, emptyEnv + -- *** Building the StateStore + , StateStore, stateGet, stateSet, stateEmpty - -- ** Exceptions - throw, catch, catchIf, try, tryToHaxlException, + -- ** Exceptions + , throw, catch, catchIf, try, tryToHaxlException - -- ** Data fetching and caching - dataFetch, uncachedRequest, - cacheRequest, cacheResult, cacheResultWithShow, cachedComputation, - dumpCacheAsHaskell, + -- ** Data fetching and caching + , dataFetch, uncachedRequest + , cacheRequest, cacheResult, cacheResultWithShow + , cachedComputation, preCacheComputation + , dumpCacheAsHaskell - -- ** Memoization - memo, memoize, memoize1, memoize2, - memoFingerprint, MemoFingerprintKey(..), + -- ** Memoization + , newMemo, newMemoWith, prepareMemo, runMemo + , memo, memoize, memoize1, memoize2 + , memoFingerprint, MemoFingerprintKey(..) - -- ** Conditionals - pAnd, pOr, + -- ** Conditionals + , pAnd, pOr - -- ** Statistics - Stats(..), - RoundStats(..), - DataSourceRoundStats(..), - Microseconds, - emptyStats, - numRounds, - numFetches, - ppStats, - ppRoundStats, - ppDataSourceRoundStats, - Profile, - emptyProfile, - profile, - profileRound, - profileCache, - ProfileLabel, - ProfileData(..), - emptyProfileData, + -- ** Statistics + , Stats(..) + , FetchStats(..) + , Microseconds + , Timestamp + , emptyStats + , numRounds + , numFetches + , ppStats + , ppFetchStats + , Profile + , emptyProfile + , profile + , ProfileLabel + , ProfileData(..) + , emptyProfileData + , AllocCount + , MemoHitCount - -- ** Tracing flags - Flags(..), - defaultFlags, - ifTrace, - ifReport, - ifProfiling, + -- ** Tracing flags + , Flags(..) + , defaultFlags + , ifTrace + , ifReport + , ifProfiling - -- * Building data sources - DataSource(..), - ShowP(..), - DataSourceName(..), - Request, - BlockedFetch(..), - PerformFetch(..), - StateKey(..), + -- * Building data sources + , DataSource(..) + , ShowP(..) + , DataSourceName(..) + , Request + , BlockedFetch(..) + , PerformFetch(..) + , StateKey(..) + , SchedulerHint(..) - -- ** Result variables - ResultVar(..), - newEmptyResult, - newResult, - putFailure, - putResult, - putSuccess, - takeResult, - tryReadResult, - tryTakeResult, + -- ** Result variables + , ResultVar(..) + , mkResultVar + , putFailure + , putResult + , putSuccess + , putResultFromChildThread - -- ** Default fetch implementations - asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease, - stubFetch, - syncFetch, + -- ** Default fetch implementations + , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease + , stubFetch + , syncFetch - -- ** Utilities - except, - setError, + -- ** Utilities + , except + , setError - -- * Exceptions - module Haxl.Core.Exception + -- * Exceptions + , module Haxl.Core.Exception ) where +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.ShowP (ShowP(..)) import Haxl.Core.StateStore diff --git a/Haxl/Core/DataCache.hs b/Haxl/Core/DataCache.hs --- a/Haxl/Core/DataCache.hs +++ b/Haxl/Core/DataCache.hs @@ -2,17 +2,19 @@ -- 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. +-- found in the LICENSE file. {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | A cache mapping data requests to their results. This module is +-- | +-- 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(..) , SubCache(..) @@ -24,19 +26,44 @@ , showCache ) where +import Control.Exception import Data.Hashable import Prelude hiding (lookup) import Unsafe.Coerce +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Typeable import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif -import Control.Exception -import Haxl.Core.Types +-- --------------------------------------------------------------------------- +-- DataCache +-- | 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. +-- +newtype DataCache res = DataCache (HashMap 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 res = + forall req a . (Hashable (req a), Eq (req a), Typeable (req a)) => + SubCache (req a -> String) (a -> String) ! (HashMap (req a) (res a)) + -- NB. the inner HashMap is strict, to avoid building up + -- a chain of thunks during repeated insertions. + +-- | A new, empty 'DataCache'. +emptyDataCache :: DataCache res +emptyDataCache = DataCache HashMap.empty + + -- | Inserts a request-result pair into the 'DataCache'. insert :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a) @@ -109,20 +136,22 @@ -- 'insertNotShowable' has been used to insert any entries. -- showCache - :: DataCache ResultVar + :: 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) +showCache (DataCache cache) readRes = mapM goSubCache (HashMap.toList cache) where goSubCache - :: (TypeRep,SubCache ResultVar) + :: (TypeRep, SubCache res) -> IO (TypeRep,[(String, Either SomeException String)]) goSubCache (ty, SubCache showReq showRes hmap) = do elems <- catMaybes <$> mapM go (HashMap.toList hmap) return (ty, elems) where go (req, rvar) = do - maybe_r <- tryReadResult rvar + maybe_r <- readRes rvar case maybe_r of Nothing -> return Nothing Just (Left e) -> return (Just (showReq req, Left e)) 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,390 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE CPP #-} +{-# 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(..) + + -- * Result variables + , ResultVar(..) + , mkResultVar + , putFailure + , putResult + , putResultFromChildThread + , putSuccess + + -- * Default fetch implementations + , asyncFetch, asyncFetchWithDispatch + , asyncFetchAcquireRelease + , stubFetch + , syncFetch + + -- * Utilities + , except + , setError + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Exception +import Data.Hashable +import Data.Text (Text) +#if __GLASGOW_HASKELL__ >= 802 +import Data.Typeable +#else +import Data.Typeable.Internal +#endif + +import Haxl.Core.Exception +import Haxl.Core.Flags +import Haxl.Core.ShowP +import Haxl.Core.StateStore + + +-- --------------------------------------------------------------------------- +-- 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 + +class DataSourceName (req :: * -> *) 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 :: * -> *) + = 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. + +-- | 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. + | FutureFetch ([BlockedFetch req] -> IO (IO ())) + -- ^ Returns an IO action that, when performed, waits for the data + -- to be received. This is the second-best type of fetch, because + -- the scheduler still has to perform the blocking wait at some + -- point in the future, and when it has multiple blocking waits to + -- perform, it can't know which one will return first. + -- + -- Why not just forkIO the IO action to make a FutureFetch into a + -- BackgroundFetch? The blocking wait will probably do a safe FFI + -- call, which means it needs its own OS thread. If we don't want + -- to create an arbitrary number of OS threads, then FutureFetch + -- enables all the blocking waits to be done on a single thread. + -- Also, you might have a data source that requires all calls to + -- be made in the same OS thread. + + +-- | 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 -> 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 -> 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 + +-- | 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 + -- 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 + + +{- | +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 fetch (BlockedFetch request result) + = (putResult result =<<) <$> fetch service request diff --git a/Haxl/Core/Exception.hs b/Haxl/Core/Exception.hs --- a/Haxl/Core/Exception.hs +++ b/Haxl/Core/Exception.hs @@ -2,8 +2,7 @@ -- 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. +-- found in the LICENSE file. {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -29,6 +28,7 @@ -- -- Most users should import "Haxl.Core" instead of importing this -- module directly. +-- module Haxl.Core.Exception ( HaxlException(..), @@ -53,6 +53,7 @@ -- ** Internal exceptions CriticalError(..), DataSourceError(..), + NonHaxlException(..), -- ** Logic exceptions NotFound(..), diff --git a/Haxl/Core/Fetch.hs b/Haxl/Core/Fetch.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Fetch.hs @@ -0,0 +1,538 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Implementation of data-fetching operations. Most users should +-- import "Haxl.Core" instead. +-- +module Haxl.Core.Fetch + ( dataFetch + , dataFetchWithShow + , uncachedRequest + , cacheResult + , 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 +import Data.Monoid +import Data.Typeable +import Data.Text (Text) +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.Exception +import Haxl.Core.Flags +import Haxl.Core.Monad +import Haxl.Core.Profile +import Haxl.Core.RequestStore +import Haxl.Core.ShowP +import Haxl.Core.Stats +import Haxl.Core.StateStore +import Haxl.Core.Util + +-- ----------------------------------------------------------------------------- +-- Data fetching and caching + +-- | Possible responses when checking the cache. +data CacheResult u a + -- | The request hadn't been seen until now. + = Uncached + (ResultVar a) + {-# UNPACK #-} !(IVar u a) + + -- | The request has been seen before, but its result has not yet been + -- fetched. + | CachedNotFetched + {-# UNPACK #-} !(IVar u a) + + -- | The request has been seen before, and its result has already been + -- fetched. + | Cached (ResultVal a) + + +-- | 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 . + Typeable (r a) + => (r a -> String) -- See Note [showFn] + -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u)) + -> Env u -> r a -> IO (CacheResult u a) +cachedWithInsert showFn insertFn Env{..} req = do + cache <- readIORef cacheRef + let + doFetch = do + ivar <- newIVar + let !rvar = stdResultVar ivar completions + writeIORef cacheRef $! insertFn req ivar cache + return (Uncached rvar ivar) + case DataCache.lookup req cache of + Nothing -> doFetch + Just (IVar cr) -> do + e <- readIORef cr + case e of + IVarEmpty _ -> return (CachedNotFetched (IVar cr)) + 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) + + +-- | Make a ResultVar with the standard function for sending a CompletionReq +-- to the scheduler. +stdResultVar :: IVar u a -> TVar [CompleteReq u] -> ResultVar a +stdResultVar ivar completions = 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 + atomically $ do + cs <- readTVar completions + writeTVar completions (CompleteReq r ivar allocs : cs) +{-# INLINE stdResultVar #-} + + +-- | Record the call stack for a data fetch in the Stats. Only useful +-- when profiling. +logFetch :: Env u -> (r a -> String) -> r a -> IO () +#ifdef PROFILING +logFetch env showFn req = do + ifReport (flags env) 5 $ do + stack <- currentCallStack + modifyIORef' (statsRef env) $ \(Stats s) -> + Stats (FetchCall (showFn req) stack : s) +#else +logFetch _ _ _ = return () +#endif + +-- | Performs actual fetching of data for a 'Request' from a 'DataSource'. +dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u 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 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 r a + . (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a)) + => (r a -> String) -- See Note [showFn] + -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u)) + -> r a + -> GenHaxl u a +dataFetchWithInsert showFn insertFn req = + GenHaxl $ \env@Env{..} -> do + -- First, check the cache + res <- cachedWithInsert showFn insertFn env req + ifProfiling flags $ addProfileFetch env req + case res of + -- This request has not been seen before + Uncached rvar ivar -> do + logFetch env showFn req + -- + -- Check whether the data source wants to submit requests + -- eagerly, or batch them up. + -- + case schedulerHint userEnv :: SchedulerHint r of + SubmitImmediately -> do + (_,ios) <- performFetches 0 env + [BlockedFetches [BlockedFetch req rvar]] + when (not (null ios)) $ + error "bad data source:SubmitImmediately but returns FutureFetch" + TryToBatch -> + -- add the request to the RequestStore and continue + modifyIORef' reqStoreRef $ \bs -> + addRequest (BlockedFetch req rvar) bs + -- + return $ Blocked ivar (Cont (getIVar ivar)) + + -- Seen before but not fetched yet. We're blocked, but we don't have + -- to add the request to the RequestStore. + CachedNotFetched ivar -> return $ Blocked ivar (Cont (getIVar ivar)) + + -- Cached: either a result, or an exception + Cached r -> done 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 :: (DataSource u r, Request r a) => r a -> GenHaxl u a +uncachedRequest req = do + isRecordingFlag <- env (recording . flags) + if isRecordingFlag /= 0 + then dataFetch req + else GenHaxl $ \Env{..} -> do + ivar <- newIVar + let !rvar = stdResultVar ivar completions + modifyIORef' reqStoreRef $ \bs -> + addRequest (BlockedFetch req rvar) bs + return $ Blocked ivar (Cont (getIVar 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 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 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 -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u)) -> r a + -> IO a -> GenHaxl u a +cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env -> do + let !ref = cacheRef env + cache <- readIORef ref + case DataCache.lookup req cache of + Nothing -> do + eitherResult <- Exception.try val + case eitherResult of + Left e -> rethrowAsyncExceptions e + _ -> return () + let result = eitherToResultThrowIO eitherResult + ivar <- newFullIVar result + writeIORef ref $! insertFn req ivar cache + done result + Just (IVar cr) -> do + e <- readIORef cr + case e of + IVarEmpty _ -> corruptCache + IVarFull r -> done r + where + corruptCache = raise . 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 () +cacheRequest request result = GenHaxl $ \env -> do + cache <- readIORef (cacheRef env) + case DataCache.lookup request cache of + Nothing -> do + cr <- newFullIVar (eitherToResult result) + writeIORef (cacheRef env) $! DataCache.insert request cr cache + 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" + +performRequestStore + :: forall u. Int -> Env u -> RequestStore u -> IO (Int, [IO ()]) +performRequestStore n env reqStore = + performFetches n 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. Int -> Env u -> [BlockedFetches u] -> IO (Int, [IO ()]) +performFetches n env@Env{flags=f, statsRef=sref} jobs = do + let !n' = n + length jobs + + t0 <- getTimestamp + + let + roundstats = + [ (dataSourceName (Proxy :: Proxy r), length reqs) + | BlockedFetches (reqs :: [BlockedFetch r]) <- jobs ] + + ifTrace f 1 $ + printf "Batch data fetch (%s)\n" $ + intercalate (", "::String) $ + map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats + + ifTrace f 3 $ + forM_ jobs $ \(BlockedFetches reqs) -> + forM_ reqs $ \(BlockedFetch r _) -> putStrLn (showp r) + + let + applyFetch i (BlockedFetches (reqs :: [BlockedFetch r])) = + case stateGet (states env) of + Nothing -> + 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 + $ FetchToDo reqs + $ (if report f >= 2 + then wrapFetchInStats sref dsName (length reqs) + else id) + $ wrapFetchInTrace i (length reqs) dsName + $ wrapFetchInCatch reqs + $ fetch state f (userEnv env) + where + dsName = dataSourceName (Proxy :: Proxy r) + + fetches <- zipWithM applyFetch [n..] jobs + + waits <- scheduleFetches fetches + + t1 <- getTimestamp + let roundtime = fromIntegral (t1 - t0) / 1000000 :: Double + + ifTrace f 1 $ + printf "Batch data fetch done (%.2fs)\n" (realToFrac roundtime :: Double) + + return (n', waits) + +data FetchToDo where + FetchToDo :: [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. +-- +wrapFetchInCatch :: [BlockedFetch req] -> PerformFetch req -> PerformFetch req +wrapFetchInCatch reqs fetch = + case fetch of + 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. + FutureFetch f -> + FutureFetch $ \reqs -> f reqs `Exception.catch` ( + \e -> handler e >> return (return ())) + BackgroundFetch f -> + BackgroundFetch $ \reqs -> f reqs `Exception.catch` handler + where + handler :: SomeException -> IO () + 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) = + putResult rvar (except e) + + +wrapFetchInStats + :: IORef Stats + -> Text + -> Int + -> PerformFetch req + -> PerformFetch req + +wrapFetchInStats !statsRef dataSource batchSize perform = do + case perform of + SyncFetch f -> + SyncFetch $ \reqs -> do + fail_ref <- newIORef 0 + (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount fail_ref) reqs)) + failures <- readIORef fail_ref + updateFetchStats t0 t alloc batchSize failures + AsyncFetch f -> do + AsyncFetch $ \reqs inner -> do + inner_r <- newIORef (0, 0) + fail_ref <- newIORef 0 + let inner' = do + (_,t,alloc,_) <- statsForIO inner + writeIORef inner_r (t,alloc) + reqs' = map (addFailureCount fail_ref) reqs + (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs' inner') + (innerTime, innerAlloc) <- readIORef inner_r + failures <- readIORef fail_ref + updateFetchStats t0 (totalTime - innerTime) (totalAlloc - innerAlloc) + batchSize failures + FutureFetch submit -> + FutureFetch $ \reqs -> do + fail_ref <- newIORef 0 + let reqs' = map (addFailureCount fail_ref) reqs + (t0, submitTime, submitAlloc, wait) <- statsForIO (submit reqs') + return $ do + (_, waitTime, waitAlloc, _) <- statsForIO wait + failures <- readIORef fail_ref + updateFetchStats t0 (submitTime + waitTime) (submitAlloc + waitAlloc) + batchSize failures + BackgroundFetch io -> do + BackgroundFetch $ \reqs -> do + startTime <- getTimestamp + io (map (addTimer startTime) reqs) + where + statsForIO io = do + prevAlloc <- getAllocationCounter + (t0,t,a) <- time io + postAlloc <- getAllocationCounter + return (t0,t, fromIntegral $ prevAlloc - postAlloc, a) + + addTimer t0 (BlockedFetch req (ResultVar fn)) = + BlockedFetch req $ ResultVar $ \result isChildThread -> do + t1 <- getTimestamp + updateFetchStats t0 (t1 - t0) + 0 -- allocs: we can't measure this easily for BackgroundFetch + 1 -- batch size: we don't know if this is a batch or not + (if isLeft result then 1 else 0) -- failures + fn result isChildThread + + updateFetchStats + :: Timestamp -> Microseconds -> Int64 -> Int -> Int -> IO () + updateFetchStats start time space batch failures = do + let this = FetchStats { fetchDataSource = dataSource + , fetchBatchSize = batch + , fetchStart = start + , fetchDuration = time + , fetchSpace = space + , fetchFailures = failures } + atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ()) + + addFailureCount :: IORef Int -> BlockedFetch r -> BlockedFetch r + addFailureCount ref (BlockedFetch req (ResultVar fn)) = + BlockedFetch req $ ResultVar $ \result isChildThread -> do + when (isLeft result) $ atomicModifyIORef' ref (\r -> (r+1,())) + fn result isChildThread + +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 :: [FetchToDo] -> IO [IO ()] +scheduleFetches fetches = do + fully_async_fetches + waits <- future_fetches + async_fetches sync_fetches + return waits + where + fully_async_fetches :: IO () + fully_async_fetches = + sequence_ [f reqs | FetchToDo reqs (BackgroundFetch f) <- fetches] + + future_fetches :: IO [IO ()] + future_fetches = sequence [f reqs | FetchToDo reqs (FutureFetch f) <- fetches] + + async_fetches :: IO () -> IO () + async_fetches = compose [f reqs | FetchToDo reqs (AsyncFetch f) <- fetches] + + sync_fetches :: IO () + sync_fetches = sequence_ [f reqs | FetchToDo reqs (SyncFetch f) <- fetches] 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,75 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE CPP #-} + +-- | +-- 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 + ( + -- * Tracing flags + Flags(..) + , defaultFlags + , ifTrace + , ifReport + , ifProfiling + ) where + +import Control.Monad + +-- --------------------------------------------------------------------------- +-- Flags + +-- | Flags that control the operation of the engine. +data Flags = Flags + { trace :: {-# UNPACK #-} !Int + -- ^ Tracing level (0 = quiet, 3 = very verbose). + , report :: {-# UNPACK #-} !Int + -- ^ Report level: + -- * 0 = quiet + -- * 1 = quiet (legacy, this used to do something) + -- * 2 = data fetch stats & errors + -- * 3 = (same as 2, this used to enable errors) + -- * 4 = profiling + -- * 5 = log stack traces of dataFetch calls + , 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 = 0 + , caching = 1 + , recording = 0 + } + +#if __GLASGOW_HASKELL__ >= 710 +#define FUNMONAD Monad m +#else +#define FUNMONAD (Functor m, Monad m) +#endif + +-- | Runs an action if the tracing level is above the given threshold. +ifTrace :: FUNMONAD => Flags -> Int -> m a -> m () +ifTrace flags i = when (trace flags >= i) . void + +-- | Runs an action if the report level is above the given threshold. +ifReport :: FUNMONAD => Flags -> Int -> m a -> m () +ifReport flags i = when (report flags >= i) . void + +ifProfiling :: FUNMONAD => Flags -> m a -> m () +ifProfiling flags = when (report flags >= 4) . void + +#undef FUNMONAD diff --git a/Haxl/Core/Memo.hs b/Haxl/Core/Memo.hs --- a/Haxl/Core/Memo.hs +++ b/Haxl/Core/Memo.hs @@ -2,28 +2,48 @@ -- 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. +-- found in the LICENSE file. +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} --- | Most users should import "Haxl.Core" instead of importing this --- module directly. -module Haxl.Core.Memo ( - memo, - memoFingerprint, - MemoFingerprintKey(..), - memoize, memoize1, memoize2 -) where +-- | +-- 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 + + -- * Local memoization + , newMemo + , newMemoWith + , prepareMemo + , runMemo + ) where + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif +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 @@ -31,9 +51,245 @@ 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.Profile -- ----------------------------------------------------------------------------- +-- 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 a. + ( Eq (req a) + , Hashable (req a) + , Typeable (req a)) + => req a -> GenHaxl u a -> GenHaxl u a + +cachedComputation req haxl = GenHaxl $ \env@Env{..} -> do + cache <- readIORef memoRef + ifProfiling flags $ + modifyIORef' profRef (incrementMemoHitCounterFor profLabel) + case DataCache.lookup req cache of + Just ivar -> unHaxl (getIVar ivar) env + Nothing -> do + ivar <- newIVar + writeIORef memoRef $! DataCache.insertNotShowable req ivar cache + unHaxl (execMemoNow haxl ivar) env + + +-- | 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 a. + ( Eq (req a) + , Hashable (req a) + , Typeable (req a)) + => req a -> GenHaxl u a -> GenHaxl u a +preCacheComputation req haxl = GenHaxl $ \env@Env{..} -> do + cache <- readIORef memoRef + ifProfiling flags $ + modifyIORef' profRef (incrementMemoHitCounterFor profLabel) + case DataCache.lookup req cache of + Just _ -> return $ Throw $ toException $ InvalidParameter + "preCacheComputation: key is already cached" + Nothing -> do + ivar <- newIVar + writeIORef memoRef $! DataCache.insertNotShowable req ivar cache + unHaxl (execMemoNow haxl ivar) env + +-- ----------------------------------------------------------------------------- +-- Memoization + +newtype MemoVar u a = MemoVar (IORef (MemoStatus u a)) + +data MemoStatus u a + = MemoEmpty + | MemoReady (GenHaxl u a) + | MemoRun {-# UNPACK #-} !(IVar u a) + +-- | 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 (MemoVar u 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 a -> GenHaxl u a -> GenHaxl u () +prepareMemo (MemoVar memoRef) memoCmp + = unsafeLiftIO $ writeIORef memoRef (MemoReady memoCmp) + +-- | Convenience function, combines @newMemo@ and @prepareMemo@. +newMemoWith :: GenHaxl u a -> GenHaxl u (MemoVar u 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 :: MemoVar u a -> GenHaxl u a +runMemo (MemoVar memoRef) = GenHaxl $ \env -> do + stored <- readIORef memoRef + case stored of + -- Memo was not prepared first; throw an exception. + MemoEmpty -> raise $ CriticalError "Attempting to run empty memo." + -- Memo has been prepared but not run yet + MemoReady cont -> do + ivar <- newIVar + writeIORef memoRef (MemoRun ivar) + unHaxl (execMemoNow cont ivar) env + -- The memo has already been run, get (or wait for) for the result + MemoRun ivar -> unHaxl (getIVar ivar) env + + +execMemoNow :: GenHaxl u a -> IVar u a -> GenHaxl u a +execMemoNow cont ivar = GenHaxl $ \env -> do + let !ienv = imperative env -- don't speculate under memoized things + r <- Exception.try $ unHaxl cont ienv + case r of + Left e -> do + rethrowAsyncExceptions e + putIVar ivar (ThrowIO e) env + throwIO e + Right (Done a) -> do + putIVar ivar (Ok a) env + return (Done a) + Right (Throw ex) -> do + putIVar ivar (ThrowHaxl ex) env + return (Throw ex) + Right (Blocked ivar' cont) -> do + addJob env (toHaxl cont) ivar ivar' + return (Blocked ivar (Cont (getIVar ivar))) + +-- ----------------------------------------------------------------------------- +-- 1-ary and 2-ary memo functions + +newtype MemoVar1 u a b = MemoVar1 (IORef (MemoStatus1 u a b)) +newtype MemoVar2 u a b c = MemoVar2 (IORef (MemoStatus2 u a b c)) + +data MemoStatus1 u a b + = MemoEmpty1 + | MemoTbl1 (a -> GenHaxl u b) (HashMap.HashMap a (MemoVar u b)) + +data MemoStatus2 u a b c + = MemoEmpty2 + | MemoTbl2 + (a -> b -> GenHaxl u c) + (HashMap.HashMap a (HashMap.HashMap b (MemoVar u c))) + +newMemo1 :: GenHaxl u (MemoVar1 u a b) +newMemo1 = unsafeLiftIO $ MemoVar1 <$> newIORef MemoEmpty1 + +newMemoWith1 :: (a -> GenHaxl u b) -> GenHaxl u (MemoVar1 u a b) +newMemoWith1 f = newMemo1 >>= \r -> prepareMemo1 r f >> return r + +prepareMemo1 :: MemoVar1 u a b -> (a -> GenHaxl u b) -> GenHaxl u () +prepareMemo1 (MemoVar1 r) f + = unsafeLiftIO $ writeIORef r (MemoTbl1 f HashMap.empty) + +runMemo1 :: (Eq a, Hashable a) => MemoVar1 u a b -> a -> GenHaxl u 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 (MemoVar2 u a b c) +newMemo2 = unsafeLiftIO $ MemoVar2 <$> newIORef MemoEmpty2 + +newMemoWith2 :: (a -> b -> GenHaxl u c) -> GenHaxl u (MemoVar2 u a b c) +newMemoWith2 f = newMemo2 >>= \r -> prepareMemo2 r f >> return r + +prepareMemo2 :: MemoVar2 u a b c -> (a -> b -> GenHaxl u c) -> GenHaxl u () +prepareMemo2 (MemoVar2 r) f + = unsafeLiftIO $ writeIORef r (MemoTbl2 f HashMap.empty) + +runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b) + => MemoVar2 u a b c + -> a -> b -> GenHaxl u 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 @@ -115,8 +371,8 @@ -- 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 :: GenHaxl u a -> GenHaxl u a -memoize a = newMemoWith a >>= runMemo +memoize :: GenHaxl u a -> GenHaxl u (GenHaxl u a) +memoize a = runMemo <$> newMemoWith a -- | Transform a 1-argument function returning a Haxl computation into a -- memoized version of itself. @@ -127,10 +383,10 @@ -- -- e.g.: -- --- allFriends :: [Int] -> GenHaxl u [Int] --- allFriends ids = do --- memoizedFriendsOf <- memoize1 friendsOf --- concat <$> mapM memoizeFriendsOf ids +-- > allFriends :: [Int] -> GenHaxl u [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@. diff --git a/Haxl/Core/Monad.hs b/Haxl/Core/Monad.hs --- a/Haxl/Core/Monad.hs +++ b/Haxl/Core/Monad.hs @@ -2,1260 +2,764 @@ -- 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 BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL >= 800 -{-# OPTIONS_GHC -Wno-name-shadowing #-} -#else -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - --- | 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 (..), runHaxl, - env, withEnv, withLabel, withFingerprintLabel, - - -- * Env - Env(..), Caches, caches, initEnvWithData, initEnv, emptyEnv, - - -- * Exceptions - throw, catch, catchIf, try, tryToHaxlException, - - -- * Data fetching and caching - ShowReq, dataFetch, dataFetchWithShow, uncachedRequest, cacheRequest, - cacheResult, cacheResultWithShow, cachedComputation, - dumpCacheAsHaskell, dumpCacheAsHaskellFn, - - -- * Memoization Machinery - newMemo, newMemoWith, prepareMemo, runMemo, - - newMemo1, newMemoWith1, prepareMemo1, runMemo1, - newMemo2, newMemoWith2, prepareMemo2, runMemo2, - - -- * Unsafe operations - unsafeLiftIO, unsafeToHaxlException, - - -- * Parallel operaitons - pAnd, pOr - ) where - -import Haxl.Core.Types -import Haxl.Core.ShowP -import Haxl.Core.StateStore -import Haxl.Core.Exception -import Haxl.Core.RequestStore -import Haxl.Core.Util -import Haxl.Core.DataCache as DataCache - -import qualified Data.Text as Text -import qualified Control.Monad.Catch as Catch -import Control.Exception (Exception(..), SomeException) -#if __GLASGOW_HASKELL__ >= 710 -import GHC.Conc (getAllocationCounter, setAllocationCounter) -#endif -import Control.Monad -import qualified Control.Exception as Exception -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative hiding (Const) -#endif -import Control.DeepSeq -import GHC.Exts (IsString(..), Addr#) -#if __GLASGOW_HASKELL__ < 706 -import Prelude hiding (catch) -#endif -import Data.Functor.Constant -import Data.Hashable -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import Data.IORef -import Data.List -import qualified Data.Map as Map -import Data.Monoid -import Data.Time -import Data.Typeable -import Text.Printf -import Text.PrettyPrint hiding ((<>)) -import Control.Arrow (left) - -#ifdef EVENTLOG -import Control.Exception (bracket_) -import Debug.Trace (traceEventIO) -#endif - -#ifdef PROFILING -import GHC.Stack -#endif - -#if __GLASGOW_HASKELL__ < 710 -import Data.Int (Int64) - -getAllocationCounter :: IO Int64 -getAllocationCounter = return 0 - -setAllocationCounter :: Int64 -> IO () -setAllocationCounter _ = return () -#endif - --- ----------------------------------------------------------------------------- --- The environment - --- | The data we carry around in the Haxl monad. -data Env u = Env - { cacheRef :: {-# UNPACK #-} !(IORef (DataCache ResultVar)) - -- cached data fetches - , memoRef :: {-# UNPACK #-} !(IORef (DataCache (MemoVar u))) - -- memoized computations - , flags :: !Flags - -- conservatively not unpacking, because this is passed - -- to 'fetch' and would need to be rebuilt. - , userEnv :: u - , statsRef :: {-# UNPACK #-} !(IORef Stats) - , profLabel :: ProfileLabel - , profRef :: {-# UNPACK #-} !(IORef Profile) - , states :: StateStore - -- ^ Data sources and other components can store their state in - -- here. Items in this store must be instances of 'StateKey'. - } - -type Caches u = (IORef (DataCache ResultVar), IORef (DataCache (MemoVar u))) - -caches :: Env u -> Caches u -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 u -> IO (Env u) -initEnvWithData states e (cref, mref) = do - sref <- newIORef emptyStats - pref <- newIORef emptyProfile - return Env - { cacheRef = cref - , memoRef = mref - , flags = defaultFlags - , userEnv = e - , states = states - , statsRef = sref - , profLabel = "MAIN" - , profRef = pref - } - --- | Initializes an environment with 'StateStore' and an input map. -initEnv :: StateStore -> u -> IO (Env u) -initEnv states e = do - cref <- newIORef emptyDataCache - mref <- newIORef emptyDataCache - initEnvWithData states e (cref,mref) - --- | A new, empty environment. -emptyEnv :: u -> IO (Env u) -emptyEnv = initEnv stateEmpty - --- ----------------------------------------------------------------------------- --- | 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 (Cont u a) - -data Cont u a - = Cont (GenHaxl u a) - | forall b. Cont u b :>>= (b -> GenHaxl u a) - | forall b. (Cont u (b -> a)) :<*> (Cont u b) - | forall b. (b -> a) :<$> (Cont u b) - -toHaxl :: Cont u a -> GenHaxl u a -toHaxl (Cont haxl) = haxl -toHaxl ((m :>>= k1) :>>= k2) = toHaxl (m :>>= (k1 >=> k2)) -- for seql -toHaxl (c :>>= k) = toHaxl c >>= k -toHaxl ((f :<$> i) :<*> (g :<$> j)) = - toHaxl (((\x y -> f x (g y)) :<$> i) :<*> j) -- See Note [Tree] -toHaxl (f :<*> x) = toHaxl f <*> toHaxl x -toHaxl (f :<$> (g :<$> x)) = toHaxl ((f . g) :<$> x) -- fmap fusion -toHaxl (f :<$> x) = fmap f (toHaxl x) - --- Note [Tree] --- This implements the following re-association: --- --- <*> --- / \ --- <$> <$> --- / \ / \ --- f i g j --- --- to: --- --- <*> --- / \ --- <$> j --- / \ where h = (\x y -> f x (g y)) --- h i --- --- I suspect this is mostly useful because it eliminates one :<$> constructor --- within the Blocked returned by `tree 1`, which is replicated a lot by the --- tree benchmark (tree 1 is near the leaves). So this rule might just be --- optimizing for a microbenchmark. - -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)) - fail msg = GenHaxl $ \_env _ref -> - return $ Throw $ toException $ MonadFail $ Text.pack msg - - -- We really want the Applicative version of >> - (>>) = (*>) - -instance Functor (GenHaxl u) where - fmap f (GenHaxl m) = GenHaxl $ \env ref -> do - r <- m env ref - case r of - Done a -> return (Done (f a)) - Throw e -> return (Throw e) - Blocked a' -> return (Blocked (f :<$> a')) - -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 (($ a') :<$> f')) - Throw e -> return (Blocked (f' :<*> Cont (throw e))) - Blocked a' -> return (Blocked (f' :<*> a')) - --- | Runs a 'Haxl' computation in an 'Env'. -runHaxl :: Env u -> GenHaxl u a -> IO a -#ifdef EVENTLOG -runHaxl env h = do - let go !n env c = do - traceEventIO "START computation" - ref <- newIORef noRequests - e <- (unHaxl $ toHaxl c) env ref - traceEventIO "STOP computation" - case e of - Done a -> return a - Throw e -> Exception.throw e - Blocked cont -> do - bs <- readIORef ref - writeIORef ref noRequests -- Note [RoundId] - traceEventIO "START performFetches" - n' <- performFetches n env bs - traceEventIO "STOP performFetches" - when (caching (flags env) == 0) $ - writeIORef (cacheRef env) emptyDataCache - go n' env cont - traceEventIO "START runHaxl" - r <- go 0 env (Cont h) - traceEventIO "STOP runHaxl" - return r -#else -runHaxl env (GenHaxl haxl) = do - ref <- newIORef noRequests - e <- haxl env ref - case e of - Done a -> return a - Throw e -> Exception.throw e - Blocked cont -> do - bs <- readIORef ref - writeIORef ref noRequests -- Note [RoundId] - void (performFetches 0 env bs) - when (caching (flags env) == 0) $ - writeIORef (cacheRef env) emptyDataCache - runHaxl env (toHaxl cont) -#endif - --- | Extracts data from the 'Env'. -env :: (Env u -> a) -> GenHaxl u a -env f = GenHaxl $ \env _ref -> 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 -> GenHaxl u a -> GenHaxl u a -withEnv newEnv (GenHaxl m) = GenHaxl $ \_env ref -> do - r <- m newEnv ref - case r of - Done a -> return (Done a) - Throw e -> return (Throw e) - Blocked k -> return (Blocked (Cont (withEnv newEnv (toHaxl k)))) - --- | Label a computation so profiling data is attributed to the label. -withLabel :: ProfileLabel -> GenHaxl u a -> GenHaxl u a -withLabel l (GenHaxl m) = GenHaxl $ \env ref -> - if report (flags env) < 4 - then m env ref - else collectProfileData l m env ref - --- | Label a computation so profiling data is attributed to the label. --- Intended only for internal use by 'memoFingerprint'. -withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u a -> GenHaxl u a -withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ref -> - if report (flags env) < 4 - then m env ref - else collectProfileData - (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr) - m env ref - --- | Collect profiling data and attribute it to given label. -collectProfileData - :: ProfileLabel - -> (Env u -> IORef (RequestStore u) -> IO (Result u a)) - -> Env u -> IORef (RequestStore u) - -> IO (Result u a) -collectProfileData l m env ref = do - a0 <- getAllocationCounter - r <- m env{profLabel=l} ref -- what if it throws? - a1 <- getAllocationCounter - modifyProfileData env l (a0 - a1) - -- So we do not count the allocation overhead of modifyProfileData - setAllocationCounter a1 - case r of - Done a -> return (Done a) - Throw e -> return (Throw e) - Blocked k -> return (Blocked (Cont (withLabel l (toHaxl k)))) -{-# INLINE collectProfileData #-} - -modifyProfileData :: Env u -> ProfileLabel -> AllocCount -> IO () -modifyProfileData env label allocs = - modifyIORef' (profRef env) $ \ p -> - p { profile = - HashMap.insertWith updEntry label newEntry . - HashMap.insertWith updCaller caller newCaller $ - profile p } - where caller = profLabel env - newEntry = - emptyProfileData - { profileAllocs = allocs - , profileDeps = HashSet.singleton caller } - updEntry _ old = - old { profileAllocs = profileAllocs old + allocs - , profileDeps = HashSet.insert caller (profileDeps old) } - -- subtract allocs 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 } - updCaller _ old = - old { profileAllocs = profileAllocs old - allocs } - -incrementMemoHitCounterFor :: ProfileLabel -> Profile -> Profile -incrementMemoHitCounterFor lbl p = - p { profile = HashMap.adjust incrementMemoHitCounter lbl (profile p) } - -incrementMemoHitCounter :: ProfileData -> ProfileData -incrementMemoHitCounter pd = pd { profileMemoHits = succ (profileMemoHits pd) } - --- ----------------------------------------------------------------------------- --- 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 e -#ifdef PROFILING - | Just (HaxlException Nothing h) <- fromException somex = do - stk <- currentCallStack - return (Throw (toException (HaxlException (Just stk) h))) - | otherwise -#endif - = return (Throw somex) - where - somex = toException e - --- | Catch an exception in the Haxl monad -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 (Cont (catch (toHaxl k) h))) - --- | Catch exceptions that satisfy a predicate -catchIf - :: Exception e => (e -> Bool) -> GenHaxl u a -> (e -> GenHaxl u a) - -> GenHaxl u 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 a -> GenHaxl u (Either e a) -try haxl = (Right <$> haxl) `catch` (return . Left) - --- | @since 0.3.1.0 -instance Catch.MonadThrow (GenHaxl u) where throwM = Haxl.Core.Monad.throw --- | @since 0.3.1.0 -instance Catch.MonadCatch (GenHaxl u) 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 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 `Exception.catch` \e -> return (Throw e) - case r of - Blocked c -> return (Blocked (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 a -> GenHaxl u (Either HaxlException a) -tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h) - - --- ----------------------------------------------------------------------------- --- Data fetching and caching - --- | Possible responses when checking the cache. -data CacheResult a - -- | The request hadn't been seen until now. - = Uncached (ResultVar a) - - -- | The request has been seen before, but its result has not yet been - -- fetched. - | CachedNotFetched (ResultVar a) - - -- | The request has been seen before, and its result has already been - -- fetched. - | Cached (Either SomeException a) - --- | Checks the data cache for the result of a request. -cached :: Request r a => Env u -> r a -> IO (CacheResult a) -cached = cachedWithInsert show DataCache.insert - --- | 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. - --- | Checks the data cache for the result of a request, inserting new results --- with the given function. -cachedWithInsert - :: Typeable (r a) - => (r a -> String) -- See Note [showFn] - -> (r a -> ResultVar a -> DataCache ResultVar -> DataCache ResultVar) -> Env u - -> r a -> IO (CacheResult a) -cachedWithInsert showFn insertFn env req = do - let - doFetch insertFn request cache = do - rvar <- newEmptyResult - writeIORef (cacheRef env) $! insertFn request rvar cache - return (Uncached rvar) - cache <- readIORef (cacheRef env) - case DataCache.lookup req cache of - Nothing -> doFetch insertFn req cache - 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 env) 3 $ putStrLn $ case r of - Left _ -> "Cached error: " ++ showFn req - Right _ -> "Cached request: " ++ showFn req - return (Cached r) - --- | Record the call stack for a data fetch in the Stats. Only useful --- when profiling. -logFetch :: Env u -> (r a -> String) -> r a -> IO () -#ifdef PROFILING -logFetch env showFn req = do - ifReport (flags env) 5 $ do - stack <- currentCallStack - modifyIORef' (statsRef env) $ \(Stats s) -> - Stats (FetchCall (showFn req) stack : s) -#else -logFetch _ _ _ = return () -#endif - --- | Performs actual fetching of data for a 'Request' from a 'DataSource'. -dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u 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 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 - :: (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a)) - => (r a -> String) -- See Note [showFn] - -> (r a -> ResultVar a -> DataCache ResultVar -> DataCache ResultVar) - -> r a - -> GenHaxl u a -dataFetchWithInsert showFn insertFn req = GenHaxl $ \env ref -> do - -- First, check the cache - res <- cachedWithInsert showFn insertFn env req - ifProfiling (flags env) $ addProfileFetch 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 - logFetch env showFn req - modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs - return $ Blocked (Cont (continueFetch showFn 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 (Cont (continueFetch showFn req rvar))) - - -- Cached: either a result, or an exception - Cached (Left ex) -> return (Throw ex) - Cached (Right a) -> return (Done a) - -{-# NOINLINE addProfileFetch #-} -addProfileFetch - :: (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a)) - => Env u -> r a -> IO () -addProfileFetch env req = do - c <- getAllocationCounter - modifyIORef' (profRef env) $ \ p -> - let - dsName :: Text.Text - dsName = dataSourceName req - - upd :: Round -> ProfileData -> ProfileData - upd round d = - d { profileFetches = Map.alter (Just . f) round (profileFetches d) } - - f Nothing = HashMap.singleton dsName 1 - f (Just hm) = HashMap.insertWith (+) dsName 1 hm - in case DataCache.lookup req (profileCache p) of - Nothing -> - let r = profileRound p - in p { profile = HashMap.adjust (upd r) (profLabel env) (profile p) - , profileCache = - DataCache.insertNotShowable req (Constant r) (profileCache p) - } - Just (Constant r) -> - p { profile = HashMap.adjust (upd r) (profLabel env) (profile p) } - -- So we do not count the allocation overhead of addProfileFetch - setAllocationCounter c - --- | 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, Show (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 (Cont (continueFetch show req rvar)) - -continueFetch - :: (r a -> String) -- See Note [showFn] - -> r a -> ResultVar a -> GenHaxl u a -continueFetch showFn req rvar = GenHaxl $ \_env _ref -> do - m <- tryReadResult rvar - case m of - Nothing -> raise . DataSourceError $ - Text.pack (showFn req) <> " did not set contents of result var" - Just r -> done r - --- | 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 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 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 -> ResultVar a -> DataCache ResultVar -> DataCache ResultVar) -> r a - -> IO a -> GenHaxl u a -cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env _ref -> do - cachedResult <- cachedWithInsert showFn insertFn env req - case cachedResult of - Uncached rvar -> do - result <- Exception.try val - putResult rvar result - case result of - Left e -> do rethrowAsyncExceptions e; done result - _other -> done result - Cached result -> done result - CachedNotFetched _ -> corruptCache - where - corruptCache = raise . 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 () -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) - --- | 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. Int -> Env u -> RequestStore u -> IO Int -performFetches n env reqs = do - let f = flags env - sref = statsRef env - jobs = contents reqs - !n' = n + length jobs - - t0 <- getCurrentTime - a0 <- getAllocationCounter - - let - roundstats = - [ (dataSourceName (getReq reqs), length reqs) - | BlockedFetches reqs <- jobs ] - where - getReq :: [BlockedFetch r] -> r a - getReq = undefined - - ifTrace f 1 $ - printf "Batch data fetch (%s)\n" $ - intercalate (", "::String) $ - map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats - - ifTrace f 3 $ - forM_ jobs $ \(BlockedFetches reqs) -> - forM_ reqs $ \(BlockedFetch r _) -> putStrLn (showp r) - - let - applyFetch (i, BlockedFetches (reqs :: [BlockedFetch r])) = - case stateGet (states env) of - Nothing -> - return (SyncFetch (mapM_ (setError e) reqs)) - where e req = DataSourceError $ - "data source not initialized: " <> - dataSourceName req <> - ": " <> - Text.pack (showp req) - Just state -> - return $ wrapFetchInTrace i (length reqs) - (dataSourceName (undefined :: r a)) - $ wrapFetchInCatch reqs - $ fetch state f (userEnv env) reqs - - fetches <- mapM applyFetch $ zip [n..] jobs - - deepStats <- - if report f >= 2 - then do - (refs, timedfetches) <- mapAndUnzipM wrapFetchInStats fetches - scheduleFetches timedfetches - mapM (fmap Just . readIORef) refs - else do - scheduleFetches fetches - return $ repeat Nothing - - failures <- - if report f >= 3 - then - forM jobs $ \(BlockedFetches reqs) -> - fmap (Just . length) . flip filterM reqs $ \(BlockedFetch _ rvar) -> do - mb <- tryReadResult rvar - return $ case mb of - Just (Right _) -> False - _ -> True - else return $ repeat Nothing - - let dsroundstats = HashMap.fromList - [ (name, DataSourceRoundStats { dataSourceFetches = dsfetch - , dataSourceTime = fst <$> dsStats - , dataSourceAllocation = snd <$> dsStats - , dataSourceFailures = dsfailure - }) - | ((name, dsfetch), dsStats, dsfailure) <- - zip3 roundstats deepStats failures] - - a1 <- getAllocationCounter - t1 <- getCurrentTime - let - roundtime = realToFrac (diffUTCTime t1 t0) :: Double - allocation = fromIntegral $ a0 - a1 - - ifReport f 1 $ - modifyIORef' sref $ \(Stats rounds) -> roundstats `deepseq` - Stats (RoundStats (microsecs roundtime) allocation dsroundstats: rounds) - - ifTrace f 1 $ - printf "Batch data fetch done (%.2fs)\n" (realToFrac roundtime :: Double) - - ifProfiling f $ - modifyIORef' (profRef env) $ \ p -> p { profileRound = 1 + profileRound p } - - return n' - --- 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. --- -wrapFetchInCatch :: [BlockedFetch req] -> PerformFetch -> PerformFetch -wrapFetchInCatch reqs fetch = - case fetch of - SyncFetch io -> - SyncFetch (io `Exception.catch` handler) - AsyncFetch fio -> - AsyncFetch (\io -> fio 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. - where - handler :: SomeException -> IO () - 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 - putResult rvar (except e) - -wrapFetchInStats :: PerformFetch -> IO (IORef (Microseconds, Int), PerformFetch) -wrapFetchInStats f = do - r <- newIORef (0, 0) - case f of - SyncFetch io -> return (r, SyncFetch (statsForIO io >>= writeIORef r)) - AsyncFetch f -> do - inner_r <- newIORef (0, 0) - return (r, AsyncFetch $ \inner -> do - (totalTime, totalAlloc) <- - statsForIO (f (statsForIO inner >>= writeIORef inner_r)) - (innerTime, innerAlloc) <- readIORef inner_r - writeIORef r (totalTime - innerTime, totalAlloc - innerAlloc)) - where - statsForIO io = do - prevAlloc <- getAllocationCounter - t <- time io - postAlloc <- getAllocationCounter - return (t, fromIntegral $ prevAlloc - postAlloc) - -wrapFetchInTrace :: Int -> Int -> Text.Text -> PerformFetch -> PerformFetch -#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 () -> IO Microseconds -time io = do - t0 <- getCurrentTime - io - t1 <- getCurrentTime - return . microsecs . realToFrac $ t1 `diffUTCTime` t0 - -microsecs :: Double -> Microseconds -microsecs t = round (t * 10^(6::Int)) - --- | Start all the async fetches first, then perform the sync fetches before --- getting the results of the async fetches. -scheduleFetches :: [PerformFetch] -> IO() -scheduleFetches fetches = async_fetches sync_fetches - where - async_fetches :: IO () -> IO () - async_fetches = compose [f | AsyncFetch f <- fetches] - - sync_fetches :: IO () - sync_fetches = sequence_ [io | SyncFetch io <- fetches] - - --- ----------------------------------------------------------------------------- --- Memoization - --- | Variables representing memoized computations. -newtype MemoVar u a = MemoVar (IORef (MemoStatus u a)) -newtype MemoVar1 u a b = MemoVar1 (IORef (MemoStatus1 u a b)) -newtype MemoVar2 u a b c = MemoVar2 (IORef (MemoStatus2 u a b c)) - --- | The state of a memoized computation -data MemoStatus u a - -- | Memoized computation under evaluation. The memo was last evaluated during - -- the given round, or never, if the given round is Nothing. The continuation - -- might be slightly out of date, but that's fine; the worst that can happen - -- is we do a little extra work. - = MemoInProgress (RoundId u) (GenHaxl u a) - - -- | A fully evaluated memo; here is the result. - | MemoDone (Either SomeException a) - - -- | A new memo, with a stored computation. Not empty, but has not been run - -- yet. - | MemoNew (GenHaxl u a) - - -- | An empty memo, should not be run before preparation. - | MemoEmpty - --- | The state of a memoized 1-argument function. -data MemoStatus1 u a b - -- | An unprepared memo. - = MemoEmpty1 - -- | A memo-table containing @MemoStatus@es for at least one in-progress memo. - | MemoTbl1 ( a -> GenHaxl u b - , HashMap.HashMap a - (MemoVar u b)) - -data MemoStatus2 u a b c - -- | An unprepared memo. - = MemoEmpty2 - -- | A memo-table containing @MemoStatus@es for at least one in-progress memo. - | MemoTbl2 ( a -> b -> GenHaxl u c - , HashMap.HashMap a - (HashMap.HashMap b - (MemoVar u c))) - -type RoundId u = IORef (RequestStore u) -{- -Note [RoundId] - -A token representing the round. This needs to be unique per round, -and it needs to support Eq. Fortunately the IORef RequestStore is -exactly what we need: IORef supports Eq, and we make a new one for -each round. There's a danger that storing this in the DataCache could -cause a space leak, so we stub out the contents after each round (see -runHaxl). --} - --- | '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. - ( Eq (req a) - , Hashable (req a) - , Typeable (req a)) - => req a -> GenHaxl u a -> GenHaxl u a -cachedComputation req haxl = do - env <- env id - cache <- unsafeLiftIO $ readIORef (memoRef env) - unsafeLiftIO $ ifProfiling (flags env) $ - modifyIORef' (profRef env) (incrementMemoHitCounterFor (profLabel env)) - memoVar <- case DataCache.lookup req cache of - Nothing -> do - memoVar <- newMemoWith haxl - unsafeLiftIO $ writeIORef (memoRef env) $! - DataCache.insertNotShowable req memoVar cache - return memoVar - Just memoVar -> return memoVar - runMemo memoVar - --- | 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 = dumpCacheAsHaskellFn "loadCache" "GenHaxl u ()" - --- | Dump the contents of the cache as Haskell code that, when --- compiled and run, will recreate the same cache contents. --- --- Takes the name and type for the resulting function as arguments. -dumpCacheAsHaskellFn :: String -> String -> GenHaxl u String -dumpCacheAsHaskellFn fnName fnType = 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 (fnName ++ " :: " ++ fnType) $$ - text (fnName ++ " = do") $$ - nest 2 (vcat (map mk_cr (concatMap snd entries))) $$ - text "" -- final newline - --- | 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 (MemoVar u 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 a -> GenHaxl u a -> GenHaxl u () -prepareMemo (MemoVar memoRef) memoCmp - = unsafeLiftIO $ writeIORef memoRef (MemoNew memoCmp) - --- | Convenience function, combines @newMemo@ and @prepareMemo@. -newMemoWith :: GenHaxl u a -> GenHaxl u (MemoVar u 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 :: MemoVar u a -> GenHaxl u a -runMemo memoVar@(MemoVar memoRef) = GenHaxl $ \env rID -> - readIORef memoRef >>= \case - -- Memo was not prepared first; throw an exception. - MemoEmpty -> raise $ CriticalError "Attempting to run empty memo." - -- The memo is complete. - MemoDone result -> done result - -- Memo has just been prepared, run it. - MemoNew cont -> runContToMemo cont env rID - -- The memo is in progress, there *may* be progress to be made. - MemoInProgress rID' cont - -- The last update was performed *this* round and is still in progress; - -- nothing further can be done this round. Wait until the next round. - | rID' == rID -> return (Blocked $ Cont retryMemo) - -- This is the first time this memo is being run during this round, or - -- at all. Enough progress may have been made to continue running the - -- memo. - | otherwise -> runContToMemo cont env rID - where - -- Continuation to retry an existing memo. It is not possible to *retry* an - -- empty memo; that will throw an exception during the next round. - retryMemo = runMemo memoVar - - -- Run a continuation, and store the result in the memo reference. Any - -- exceptions thrown during the running of the memo are thrown directly; they - -- are also stored in the memoVar just in case, but we shouldn't be looking at - -- the memoVar again anyway. - -- - -- If the memo is incomplete by the end of this round, update its progress - -- indicator and block. - runContToMemo cont env rID = do - result <- unHaxl cont env rID - case result of - Done a -> finalize (Right a) - Throw e -> finalize (Left e) - Blocked c -> do - writeIORef memoRef (MemoInProgress rID (toHaxl c)) - return (Blocked $ Cont retryMemo) - - finalize r = writeIORef memoRef (MemoDone r) >> done r - -newMemo1 :: GenHaxl u (MemoVar1 u a b) -newMemo1 = unsafeLiftIO $ MemoVar1 <$> newIORef MemoEmpty1 - -newMemoWith1 :: (a -> GenHaxl u b) -> GenHaxl u (MemoVar1 u a b) -newMemoWith1 f = newMemo1 >>= \r -> prepareMemo1 r f >> return r - -prepareMemo1 :: MemoVar1 u a b -> (a -> GenHaxl u b) -> GenHaxl u () -prepareMemo1 (MemoVar1 r) f - = unsafeLiftIO $ writeIORef r (MemoTbl1 (f, HashMap.empty)) - -runMemo1 :: (Eq a, Hashable a) => MemoVar1 u a b -> a -> GenHaxl u 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 (MemoVar2 u a b c) -newMemo2 = unsafeLiftIO $ MemoVar2 <$> newIORef MemoEmpty2 - -newMemoWith2 :: (a -> b -> GenHaxl u c) -> GenHaxl u (MemoVar2 u a b c) -newMemoWith2 f = newMemo2 >>= \r -> prepareMemo2 r f >> return r - -prepareMemo2 :: MemoVar2 u a b c -> (a -> b -> GenHaxl u c) -> GenHaxl u () -prepareMemo2 (MemoVar2 r) f - = unsafeLiftIO $ writeIORef r (MemoTbl2 (f, HashMap.empty)) - -runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b) - => MemoVar2 u a b c - -> a -> b -> GenHaxl u 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 - - --- ----------------------------------------------------------------------------- --- Parallel operations - --- Bind more tightly than .&&, .|| -infixr 5 `pAnd` -infixr 4 `pOr` - --- | 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 Bool -> GenHaxl u Bool -> GenHaxl u Bool -GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env ref -> do - ra <- a env ref - case ra of - Done True -> return (Done True) - Done False -> b env ref - Throw _ -> return ra - Blocked a' -> do - rb <- b env ref - case rb of - Done True -> return (Blocked (Cont (return True))) - -- Note [tricky pOr/pAnd] - Done False -> return ra - Throw e -> return (Blocked (Cont (throw e))) - Blocked b' -> return (Blocked (Cont (toHaxl a' `pOr` toHaxl b'))) - --- | 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 Bool -> GenHaxl u Bool -> GenHaxl u Bool -GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env ref -> do - ra <- a env ref - case ra of - Done False -> return (Done False) - Done True -> b env ref - Throw _ -> return ra - Blocked a' -> do - rb <- b env ref - case rb of - Done False -> return (Blocked (Cont (return False))) - -- Note [tricky pOr/pAnd] - Done True -> return ra - Throw _ -> return rb - Blocked b' -> return (Blocked (Cont (toHaxl a' `pAnd` toHaxl b'))) - -{- -Note [tricky pOr/pAnd] - -If one branch returns (Done True) and the other returns (Blocked _), -even though we know the result will be True (in the case of pOr), we -must return Blocked. This is because there are data fetches to -perform, and if we don't do this, the cache is left with an empty -ResultVar, and the next fetch for the same request will fail. - -Alternatives: - - * Test for a non-empty RequestStore in runHaxl when we get Done, but - that would penalise every runHaxl. - - * Try to abandon the fetches. This is hard: we've already stored the - requests and a ResultVars in the cache, and we don't know how to - find the right fetches to remove from the cache. Furthermore, we - might have partially computed some memoized computations. --} +-- found in the LICENSE file. + +{- 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 MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- 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(..) + + -- * Cont + , Cont(..) + , toHaxl + + -- * IVar + , IVar(..) + , IVarContents(..) + , newIVar + , newFullIVar + , getIVar + , putIVar + + -- * ResultVal + , ResultVal(..) + , done + , eitherToResult + , eitherToResultThrowIO + + -- * CompleteReq + , CompleteReq(..) + + -- * Env + , Env(..) + , Caches + , caches + , initEnvWithData + , initEnv + , emptyEnv + , env, withEnv + , speculate + , imperative + + -- * JobList + , JobList(..) + , appendJobList + , lengthJobList + , addJob + + -- * Exceptions + , throw + , raise + , catch + , catchIf + , try + , tryToHaxlException + + -- * Dumping the cache + , dumpCacheAsHaskell + , dumpCacheAsHaskellFn + + -- * 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 Control.Arrow (left) +import Control.Concurrent.STM +import qualified Data.Text as Text +import qualified Control.Monad.Catch as Catch +import Control.Exception (Exception(..), SomeException, throwIO) +import Control.Monad +import qualified Control.Exception as Exception +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative hiding (Const) +#endif +#if __GLASGOW_HASKELL__ < 706 +import Prelude hiding (catch) +#endif +import Data.IORef +import Data.Int +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 GHC.Stack +#endif + + +trace_ :: String -> a -> a +trace_ _ = id +--trace_ = Debug.Trace.trace + +-- ----------------------------------------------------------------------------- +-- The environment + +-- | The data we carry around in the Haxl monad. +data Env u = Env + { cacheRef :: {-# UNPACK #-} !(IORef (DataCache (IVar u))) + -- ^ cached data fetches + + , memoRef :: {-# UNPACK #-} !(IORef (DataCache (IVar u))) + -- ^ memoized computations + + , 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'. + + , profLabel :: ProfileLabel + -- ^ 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)) + -- ^ 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. + + , completions :: {-# UNPACK #-} !(TVar [CompleteReq u]) + -- ^ 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. + + , pendingWaits :: [IO ()] + -- ^ this is a list of IO actions returned by 'FutureFetch' + -- data sources. These do a blocking wait for the results of + -- some data fetch. + + , speculative :: {-# UNPACK #-} !Int + } + +type Caches u = (IORef (DataCache (IVar u)), IORef (DataCache (IVar u))) + +caches :: Env u -> Caches u +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 u -> IO (Env u) +initEnvWithData states e (cref, mref) = do + sref <- newIORef emptyStats + pref <- newIORef emptyProfile + rs <- newIORef noRequests -- RequestStore + rq <- newIORef JobNil + comps <- newTVarIO [] -- completion queue + return Env + { cacheRef = cref + , memoRef = mref + , flags = defaultFlags + , userEnv = e + , states = states + , statsRef = sref + , profLabel = "MAIN" + , profRef = pref + , reqStoreRef = rs + , runQueueRef = rq + , completions = comps + , pendingWaits = [] + , speculative = 0 + } + +-- | Initializes an environment with 'StateStore' and an input map. +initEnv :: StateStore -> u -> IO (Env u) +initEnv states e = do + cref <- newIORef emptyDataCache + mref <- newIORef emptyDataCache + initEnvWithData states e (cref,mref) + +-- | A new, empty environment. +emptyEnv :: u -> IO (Env u) +emptyEnv = initEnv stateEmpty + +speculate :: Env u -> Env u +speculate env@Env{..} + | speculative == 0 = env { speculative = 1 } + | otherwise = env + +imperative :: Env u -> Env u +imperative env@Env{..} + | speculative == 1 = env { speculative = 0 } + | otherwise = env + +-- ----------------------------------------------------------------------------- +-- | 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 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 -> IO (Result u a) } + + +instance IsString a => IsString (GenHaxl u 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 + = JobNil + | forall a . JobCons + (Env u) -- See Note [make withEnv work] below. + (GenHaxl u a) + {-# UNPACK #-} !(IVar u a) + (JobList u) + +-- 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 -> JobList u -> JobList u +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 -> 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. +newtype IVar u a = IVar (IORef (IVarContents u a)) + +data IVarContents u a + = IVarFull (ResultVal a) + | IVarEmpty (JobList u) + -- morally this is a list of @a -> GenHaxl u ()@, 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 a) +newIVar = IVar <$> newIORef (IVarEmpty JobNil) + +newFullIVar :: ResultVal a -> IO (IVar u a) +newFullIVar r = IVar <$> newIORef (IVarFull r) + +getIVar :: IVar u a -> GenHaxl u a +getIVar (IVar !ref) = GenHaxl $ \_env -> do + e <- readIORef ref + case e of + IVarFull (Ok a) -> return (Done a) + IVarFull (ThrowHaxl e) -> return (Throw e) + IVarFull (ThrowIO e) -> throwIO e + IVarEmpty _ -> return (Blocked (IVar ref) (Cont (getIVar (IVar ref)))) + +-- Just a specialised version of getIVar, for efficiency in <*> +getIVarApply :: IVar u (a -> b) -> a -> GenHaxl u b +getIVarApply (IVar !ref) a = GenHaxl $ \_env -> do + e <- readIORef ref + case e of + IVarFull (Ok f) -> return (Done (f a)) + IVarFull (ThrowHaxl e) -> return (Throw e) + IVarFull (ThrowIO e) -> throwIO e + IVarEmpty _ -> + return (Blocked (IVar ref) (Cont (getIVarApply (IVar ref) a))) + +putIVar :: IVar u a -> ResultVal a -> Env u -> IO () +putIVar (IVar ref) a Env{..} = do + e <- readIORef ref + case e of + IVarEmpty jobs -> do + writeIORef ref (IVarFull a) + modifyIORef' runQueueRef (appendJobList jobs) + IVarFull{} -> error "putIVar: multiple put" + +{-# INLINE addJob #-} +addJob :: Env u -> GenHaxl u b -> IVar u b -> IVar u a -> IO () +addJob env !haxl !resultIVar (IVar !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 + = Ok a + | ThrowHaxl SomeException + | ThrowIO SomeException + +done :: ResultVal a -> IO (Result u a) +done (Ok a) = return (Done a) +done (ThrowHaxl e) = return (Throw e) +done (ThrowIO e) = throwIO e + +eitherToResultThrowIO :: Either SomeException a -> ResultVal a +eitherToResultThrowIO (Right a) = Ok a +eitherToResultThrowIO (Left e) + | Just HaxlException{} <- fromException e = ThrowHaxl e + | otherwise = ThrowIO e + +eitherToResult :: Either SomeException a -> ResultVal a +eitherToResult (Right a) = Ok a +eitherToResult (Left e) = ThrowHaxl e + + +-- ----------------------------------------------------------------------------- +-- 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 + = forall a . CompleteReq + (Either SomeException a) + !(IVar u 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. + +(slight wrinkle here: runHaxl might not wait for the result of the +dataFetch in the case where we do some speculative execution in +pAnd/pOr) + +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 a + = Done a + | Throw SomeException + | forall b . Blocked + {-# UNPACK #-} !(IVar u b) + (Cont u 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 a@, but see + -- 'IVar', + +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" + +{- 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 a + = Cont (GenHaxl u a) + | forall b. Cont u b :>>= (b -> GenHaxl u a) + | forall b. (b -> a) :<$> (Cont u b) + +toHaxl :: Cont u a -> GenHaxl u a +toHaxl (Cont haxl) = haxl +toHaxl (m :>>= k) = toHaxlBind m k +toHaxl (f :<$> x) = toHaxlFmap f x + +toHaxlBind :: Cont u b -> (b -> GenHaxl u a) -> GenHaxl u a +toHaxlBind (m :>>= k) k2 = toHaxlBind m (k >=> k2) +toHaxlBind (Cont haxl) k = haxl >>= k +toHaxlBind (f :<$> x) k = toHaxlBind x (k . f) + +toHaxlFmap :: (a -> b) -> Cont u a -> GenHaxl u b +toHaxlFmap f (m :>>= k) = toHaxlBind m (k >=> return . f) +toHaxlFmap f (Cont haxl) = f <$> haxl +toHaxlFmap f (g :<$> x) = toHaxlFmap (f . g) x + + +-- ----------------------------------------------------------------------------- +-- Monad/Applicative instances + +instance Monad (GenHaxl u) where + return a = GenHaxl $ \_env -> return (Done a) + 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)) + fail msg = GenHaxl $ \_env -> + return $ Throw $ toException $ MonadFail $ Text.pack msg + + -- We really want the Applicative version of >> + (>>) = (*>) + +instance Functor (GenHaxl u) 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) where + pure = return + 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" $ do + -- Note [Blocked/Blocked] + if speculative env /= 0 + then + return (Blocked ivar1 + (Cont (toHaxl fcont <*> toHaxl acont))) + else 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 -> a) -> GenHaxl u 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 -> GenHaxl u a -> GenHaxl u 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)))) + + +-- ----------------------------------------------------------------------------- +-- Exceptions + +-- | Throw an exception in the Haxl monad +throw :: (Exception e) => e -> GenHaxl u a +throw e = GenHaxl $ \_env -> raise e + +raise :: (Exception e) => e -> IO (Result u a) +raise e +#ifdef PROFILING + | Just (HaxlException Nothing h) <- fromException somex = do + stk <- currentCallStack + return (Throw (toException (HaxlException (Just stk) h))) + | otherwise +#endif + = return (Throw somex) + where + somex = toException e + +-- | Catch an exception in the Haxl monad +catch :: Exception e => GenHaxl u a -> (e -> GenHaxl u a) -> GenHaxl u 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 a -> (e -> GenHaxl u a) + -> GenHaxl u 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 a -> GenHaxl u (Either e a) +try haxl = (Right <$> haxl) `catch` (return . Left) + +-- | @since 0.3.1.0 +instance Catch.MonadThrow (GenHaxl u) where throwM = Haxl.Core.Monad.throw +-- | @since 0.3.1.0 +instance Catch.MonadCatch (GenHaxl u) 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 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. +unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a +unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env -> do + r <- m env `Exception.catch` \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 a -> GenHaxl u (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 () +-- > loadCache = do +-- > cacheRequest (ListWombats 3) (Right ([1,2,3])) +-- > cacheRequest (CountAardvarks "abcabc") (Right (2)) +-- +dumpCacheAsHaskell :: GenHaxl u String +dumpCacheAsHaskell = dumpCacheAsHaskellFn "loadCache" "GenHaxl u ()" + +-- | Dump the contents of the cache as Haskell code that, when +-- compiled and run, will recreate the same cache contents. +-- +-- Takes the name and type for the resulting function as arguments. +dumpCacheAsHaskellFn :: String -> String -> GenHaxl u String +dumpCacheAsHaskellFn fnName fnType = do + ref <- env cacheRef -- NB. cacheRef, not memoRef. We ignore memoized + -- results when dumping the cache. + let + readIVar (IVar 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 "cacheRequest" <+> 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 + cache <- readIORef ref + showCache cache readIVar + + return $ show $ + text (fnName ++ " :: " ++ fnType) $$ + text (fnName ++ " = do") $$ + nest 2 (vcat (map mk_cr (concatMap snd entries))) $$ + 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,84 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Psuedo-parallel operations. Most users should import "Haxl.Core" +-- instead. +-- +module Haxl.Core.Parallel + ( -- * Parallel operations + pAnd + , pOr + ) where + +import Haxl.Core.Monad + +-- ----------------------------------------------------------------------------- +-- Parallel operations + +-- Bind more tightly than .&&, .|| +infixr 5 `pAnd` +infixr 4 `pOr` + +-- | 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 Bool -> GenHaxl u Bool -> GenHaxl u Bool +GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env@Env{..} -> do + let !senv = speculate env + ra <- a senv + case ra of + Done True -> return (Done True) + Done False -> b env -- not speculative + Throw _ -> return ra + Blocked ia a' -> do + rb <- b senv + case rb of + Done True -> return rb + Done False -> return ra + Throw _ -> return rb + Blocked _ b' -> return (Blocked ia (Cont (toHaxl a' `pOr` toHaxl b'))) + -- Note [pOr Blocked/Blocked] + -- This will only wake up when ia is filled, which + -- is whatever the left side was waiting for. This is + -- suboptimal because the right side might wake up first, + -- but handling this non-determinism would involve a much + -- more complicated implementation here. + +-- | 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 Bool -> GenHaxl u Bool -> GenHaxl u Bool +GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env@Env{..} -> do + let !senv = speculate env + ra <- a senv + case ra of + Done False -> return (Done False) + Done True -> b env + Throw _ -> return ra + Blocked ia a' -> do + rb <- b senv + case rb of + Done False -> return rb + Done True -> return ra + Throw _ -> return rb + Blocked _ b' -> return (Blocked ia (Cont (toHaxl a' `pAnd` toHaxl b'))) + -- See Note [pOr Blocked/Blocked] 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,158 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 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.Monoid +import Data.Text (Text) +import Data.Typeable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +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 a -> GenHaxl u a +withLabel l (GenHaxl m) = GenHaxl $ \env -> + if report (flags env) < 4 + 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 a -> GenHaxl u a +withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env -> + if report (flags env) < 4 + 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 -> IO (Result u a)) + -> Env u + -> IO (Result u a) +collectProfileData l m env = do + a0 <- getAllocationCounter + r <- m env{profLabel=l} -- what if it throws? + a1 <- getAllocationCounter + modifyProfileData env l (a0 - a1) + -- So we do not count the allocation overhead of modifyProfileData + setAllocationCounter a1 + case r of + Done a -> return (Done a) + Throw e -> return (Throw e) + Blocked ivar k -> return (Blocked ivar (Cont (withLabel l (toHaxl k)))) +{-# INLINE collectProfileData #-} + +modifyProfileData :: Env u -> ProfileLabel -> AllocCount -> IO () +modifyProfileData env label allocs = + modifyIORef' (profRef env) $ \ p -> + p { profile = + HashMap.insertWith updEntry label newEntry . + HashMap.insertWith updCaller caller newCaller $ + profile p } + where caller = profLabel env + newEntry = + emptyProfileData + { profileAllocs = allocs + , profileDeps = HashSet.singleton caller } + updEntry _ old = + old { profileAllocs = profileAllocs old + allocs + , profileDeps = HashSet.insert caller (profileDeps old) } + -- subtract allocs 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 } + updCaller _ old = + old { profileAllocs = profileAllocs old - allocs } + + +-- 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 -> IO (Result u a)) + -> Env u + -> IO (Result u a) +profileCont m env = do + a0 <- getAllocationCounter + r <- m env + a1 <- getAllocationCounter + let + allocs = a0 - a1 + newEntry = emptyProfileData { profileAllocs = allocs } + updEntry _ old = old { profileAllocs = profileAllocs old + allocs } + modifyIORef' (profRef env) $ \ p -> + p { profile = + HashMap.insertWith updEntry (profLabel env) newEntry $ + profile p } + -- So we do not count the allocation overhead of modifyProfileData + setAllocationCounter a1 + return r +{-# INLINE profileCont #-} + + +incrementMemoHitCounterFor :: ProfileLabel -> Profile -> Profile +incrementMemoHitCounterFor lbl p = + p { profile = HashMap.adjust incrementMemoHitCounter lbl (profile p) } + +incrementMemoHitCounter :: ProfileData -> ProfileData +incrementMemoHitCounter pd = pd { profileMemoHits = succ (profileMemoHits pd) } + +{-# NOINLINE addProfileFetch #-} +addProfileFetch + :: forall r u a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a)) + => Env u -> r a -> IO () +addProfileFetch env _req = do + c <- getAllocationCounter + modifyIORef' (profRef env) $ \ p -> + let + dsName :: Text + dsName = dataSourceName (Proxy :: Proxy r) + + upd :: ProfileData -> ProfileData + upd d = d { profileFetches = + HashMap.insertWith (+) dsName 1 (profileFetches d) } + + in p { profile = HashMap.adjust upd (profLabel env) (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 @@ -2,8 +2,7 @@ -- 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. +-- found in the LICENSE file. {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} @@ -18,12 +17,17 @@ -- -- This module is provided for access to Haxl internals only; most -- users should not need to import it. -module Haxl.Core.RequestStore ( - BlockedFetches(..), RequestStore, - noRequests, addRequest, contents +-- +module Haxl.Core.RequestStore + ( BlockedFetches(..) + , RequestStore + , isEmpty + , noRequests + , addRequest + , contents ) where -import Haxl.Core.Types +import Haxl.Core.DataSource import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Typeable @@ -38,6 +42,9 @@ -- | A batch of 'BlockedFetch' objects for a single 'DataSource' data BlockedFetches u = forall r. (DataSource u r) => BlockedFetches [BlockedFetch r] + +isEmpty :: RequestStore u -> Bool +isEmpty (RequestStore m) = Map.null m -- | A new empty 'RequestStore'. noRequests :: RequestStore u 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,220 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Defines 'runHaxl'. Most users should import "Haxl.Core" instead. +-- +module Haxl.Core.Run + ( runHaxl + ) where + +import Control.Concurrent.STM +import Control.Exception as Exception +import Control.Monad +import Data.IORef +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 + + +-- ----------------------------------------------------------------------------- +-- runHaxl + +-- | Runs a 'Haxl' computation in the given 'Env'. +runHaxl :: forall u a. Env u -> GenHaxl u a -> IO a +runHaxl env@Env{..} haxl = do + + result@(IVar resultRef) <- newIVar -- where to put the final result + let + -- Run a job, and put its result in the given IVar + schedule :: Env u -> JobList u -> GenHaxl u b -> IVar u b -> IO () + schedule env@Env{..} rq (GenHaxl run) (IVar !ref) = do + ifTrace flags 3 $ printf "schedule: %d\n" (1 + lengthJobList rq) + let {-# INLINE result #-} + result r = do + e <- readIORef ref + case e of + IVarFull _ -> error "multiple put" + 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 report flags >= 4 -- 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) -> result (Ok a) + Right (Throw ex) -> result (ThrowHaxl ex) + Right (Blocked ivar fn) -> do + addJob env (toHaxl fn) (IVar ref) ivar + 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 -> JobList u -> 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 -> IO () + emptyRunQueue env@Env{..} = do + ifTrace flags 3 $ printf "emptyRunQueue\n" + haxls <- checkCompletions env + case haxls of + JobNil -> do + case pendingWaits of + [] -> checkRequestStore env + wait:waits -> do + ifTrace flags 3 $ printf "invoking wait\n" + wait + emptyRunQueue env { pendingWaits = waits } -- check completions + _ -> reschedule env haxls + + checkRequestStore :: Env u -> IO () + checkRequestStore env@Env{..} = do + reqStore <- readIORef reqStoreRef + if RequestStore.isEmpty reqStore + then waitCompletions env + else do + writeIORef reqStoreRef noRequests + (_, waits) <- performRequestStore 0 env reqStore + ifTrace flags 3 $ printf "performFetches: %d waits\n" (length waits) + -- 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) $ + writeIORef cacheRef emptyDataCache + emptyRunQueue env{ pendingWaits = waits ++ pendingWaits } + + checkCompletions :: Env u -> IO (JobList u) + checkCompletions Env{..} = do + ifTrace flags 3 $ printf "checkCompletions\n" + comps <- atomically $ do + c <- readTVar completions + writeTVar completions [] + return c + case comps of + [] -> return JobNil + _ -> do + ifTrace flags 3 $ printf "%d complete\n" (length comps) + let + getComplete (CompleteReq a (IVar cr) allocs) = do + when (allocs < 0) $ do + cur <- getAllocationCounter + setAllocationCounter (cur + allocs) + r <- readIORef cr + case r of + IVarFull _ -> do + ifTrace flags 3 $ 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 (eitherToResult a)) + return cv + jobs <- mapM getComplete comps + return (foldr appendJobList JobNil jobs) + + waitCompletions :: Env u -> IO () + waitCompletions env@Env{..} = do + ifTrace flags 3 $ printf "waitCompletions\n" + atomically $ do + c <- readTVar completions + when (null c) retry + emptyRunQueue env + + -- + schedule env JobNil haxl result + r <- readIORef resultRef + case r of + IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result") + IVarFull (Ok a) -> return a + IVarFull (ThrowHaxl e) -> throwIO e + 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 computaiton +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 +-} diff --git a/Haxl/Core/ShowP.hs b/Haxl/Core/ShowP.hs --- a/Haxl/Core/ShowP.hs +++ b/Haxl/Core/ShowP.hs @@ -2,11 +2,12 @@ -- 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. +-- found in the LICENSE file. +-- | -- Most users should import "Haxl.Core" instead of importing this -- module directly. +-- module Haxl.Core.ShowP ( ShowP(..) ) where diff --git a/Haxl/Core/StateStore.hs b/Haxl/Core/StateStore.hs --- a/Haxl/Core/StateStore.hs +++ b/Haxl/Core/StateStore.hs @@ -2,8 +2,7 @@ -- 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. +-- found in the LICENSE file. {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} @@ -11,10 +10,16 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} --- | Most users should import "Haxl.Core" instead of importing this +-- | +-- Most users should import "Haxl.Core" instead of importing this -- module directly. -module Haxl.Core.StateStore ( - StateKey(..), StateStore, stateGet, stateSet, stateEmpty +-- +module Haxl.Core.StateStore + ( StateKey(..) + , StateStore + , stateGet + , stateSet + , stateEmpty ) where import Data.Map (Map) @@ -28,12 +33,17 @@ -- #if __GLASGOW_HASKELL__ >= 708 class Typeable f => StateKey (f :: * -> *) where - data State f #else class Typeable1 f => StateKey (f :: * -> *) where - data State f #endif + data State f + -- | 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) @@ -48,22 +58,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,209 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- 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(..) + , FetchStats(..) + , Microseconds + , Timestamp + , getTimestamp + , emptyStats + , numRounds + , numFetches + , ppStats + , ppFetchStats + + -- * Profiling + , Profile + , emptyProfile + , profile + , ProfileLabel + , ProfileData(..) + , emptyProfileData + , AllocCount + , MemoHitCount + + -- * Allocation + , getAllocationCounter + , setAllocationCounter + ) where + +import Data.Aeson +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Int +import Data.List (intercalate, maximumBy, minimumBy) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif +import Data.Semigroup (Semigroup) +import Data.Ord (comparing) +import Data.Text (Text) +import Data.Time.Clock.POSIX +import Text.Printf +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.Text as Text + +#if __GLASGOW_HASKELL__ >= 710 +import GHC.Conc (getAllocationCounter, setAllocationCounter) +#endif + +-- --------------------------------------------------------------------------- +-- 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 + +-- | 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 '*' + else '-' + | t <- [1..numDashes] + ] + ++ "] " ++ show i ++ " - " ++ ppFetchStats rs + | (i, rs) <- zip [(1::Int)..] validFetchStats ] + where + isFetchStats FetchStats{} = True + isFetchStats _ = False + validFetchStats = filter isFetchStats (reverse rss) + numDashes = 50 + minStartTime = fetchStart $ minimumBy (comparing fetchStart) validFetchStats + lastFs = maximumBy (comparing (\fs -> fetchStart fs + fetchDuration fs)) + validFetchStats + usPerDash = (fetchStart lastFs + fetchDuration lastFs - minStartTime) + `div` numDashes + fetchWasRunning :: FetchStats -> Timestamp -> Timestamp -> Bool + fetchWasRunning fs t1 t2 = + (fetchStart fs + fetchDuration fs) >= t1 && fetchStart fs < t2 + + +-- | 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 :: !Timestamp -- TODO should be something else + , fetchDuration :: {-# UNPACK #-} !Microseconds + , fetchSpace :: {-# UNPACK #-} !Int64 + , fetchFailures :: {-# UNPACK #-} !Int + } + + -- | 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] + } + deriving (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 + +instance ToJSON FetchStats where + toJSON FetchStats{..} = object + [ "datasource" .= fetchDataSource + , "fetches" .= fetchBatchSize + , "start" .= fetchStart + , "duration" .= fetchDuration + , "allocation" .= fetchSpace + , "failures" .= fetchFailures + ] + toJSON (FetchCall req strs) = object + [ "request" .= req + , "stack" .= strs + ] + +emptyStats :: Stats +emptyStats = Stats [] + +numRounds :: Stats -> Int +numRounds (Stats rs) = length rs -- not really + +numFetches :: Stats -> Int +numFetches (Stats rs) = sum [ fetchBatchSize | FetchStats{..} <- rs ] + + +-- --------------------------------------------------------------------------- +-- Profiling + +type ProfileLabel = Text +type AllocCount = Int64 +type MemoHitCount = Int64 + +newtype Profile = Profile + { profile :: HashMap ProfileLabel ProfileData + -- ^ Data on individual labels. + } + +emptyProfile :: Profile +emptyProfile = Profile HashMap.empty + +data ProfileData = ProfileData + { profileAllocs :: {-# UNPACK #-} !AllocCount + -- ^ allocations made by this label + , profileDeps :: HashSet ProfileLabel + -- ^ labels that this label depends on + , profileFetches :: HashMap Text Int + -- ^ map from datasource name => fetch count + , profileMemoHits :: {-# UNPACK #-} !MemoHitCount + -- ^ number of hits to memoized computation at this label + } + deriving Show + +emptyProfileData :: ProfileData +emptyProfileData = ProfileData 0 HashSet.empty HashMap.empty 0 + + +-- ----------------------------------------------------------------------------- +-- Allocation accounting + +#if __GLASGOW_HASKELL__ < 710 +getAllocationCounter :: IO Int64 +getAllocationCounter = return 0 + +setAllocationCounter :: Int64 -> IO () +setAllocationCounter _ = return () +#endif diff --git a/Haxl/Core/Types.hs b/Haxl/Core/Types.hs deleted file mode 100644 --- a/Haxl/Core/Types.hs +++ /dev/null @@ -1,636 +0,0 @@ --- Copyright (c) 2014-present, 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 RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL >= 800 -{-# OPTIONS_GHC -Wno-name-shadowing #-} -#else -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif - --- | Base types used by all of Haxl. Most users should import --- "Haxl.Core" instead of importing this module directly. -module Haxl.Core.Types ( - - -- * Tracing flags - Flags(..), - defaultFlags, - ifTrace, - ifReport, - ifProfiling, - - -- * Statistics - Stats(..), - RoundStats(..), - DataSourceRoundStats(..), - Microseconds, - Round, - emptyStats, - numRounds, - numFetches, - ppStats, - ppRoundStats, - ppDataSourceRoundStats, - Profile, - emptyProfile, - profile, - profileRound, - profileCache, - ProfileLabel, - ProfileData(..), - emptyProfileData, - AllocCount, - MemoHitCount, - - -- * Data fetching - DataSource(..), - DataSourceName(..), - Request, - BlockedFetch(..), - PerformFetch(..), - - -- * DataCache - DataCache(..), - SubCache(..), - emptyDataCache, - - -- * Result variables - ResultVar(..), - newEmptyResult, - newResult, - putFailure, - putResult, - putSuccess, - takeResult, - tryReadResult, - tryTakeResult, - - -- * Default fetch implementations - asyncFetch, asyncFetchWithDispatch, - asyncFetchAcquireRelease, - stubFetch, - syncFetch, - - -- * Utilities - except, - setError, - - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Concurrent.MVar -import Control.Exception -import Control.Monad -import Data.Aeson -import Data.Function (on) -import Data.Functor.Constant -import Data.Int -import Data.Hashable -import Data.HashMap.Strict (HashMap, toList) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.List (intercalate, sortBy) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text, unpack) -import Data.Typeable - -import Haxl.Core.Exception -#if __GLASGOW_HASKELL__ < 708 -import Haxl.Core.Util (tryReadMVar) -#endif -import Haxl.Core.ShowP -import Haxl.Core.StateStore - --- --------------------------------------------------------------------------- --- Flags - --- | Flags that control the operation of the engine. -data Flags = Flags - { trace :: {-# UNPACK #-} !Int - -- ^ Tracing level (0 = quiet, 3 = very verbose). - , report :: {-# UNPACK #-} !Int - -- ^ Report level (0 = quiet, 1 = # of requests, 2 = time, 3 = # of errors, - -- 4 = profiling, 5 = log stack traces of dataFetch calls) - , caching :: {-# UNPACK #-} !Int - -- ^ Non-zero if caching is enabled. If caching is disabled, then - -- we still do batching and de-duplication within a round, but do - -- not cache results between rounds. - } - -defaultFlags :: Flags -defaultFlags = Flags - { trace = 0 - , report = 1 - , caching = 1 - } - -#if __GLASGOW_HASKELL__ >= 710 -#define FUNMONAD Monad m -#else -#define FUNMONAD (Functor m, Monad m) -#endif - --- | Runs an action if the tracing level is above the given threshold. -ifTrace :: FUNMONAD => Flags -> Int -> m a -> m () -ifTrace flags i = when (trace flags >= i) . void - --- | Runs an action if the report level is above the given threshold. -ifReport :: FUNMONAD => Flags -> Int -> m a -> m () -ifReport flags i = when (report flags >= i) . void - -ifProfiling :: FUNMONAD => Flags -> m a -> m () -ifProfiling flags = when (report flags >= 4) . void - -#undef FUNMONAD - --- --------------------------------------------------------------------------- --- Stats - -type Microseconds = Int --- | Rounds are 1-indexed -type Round = Int - --- | Stats that we collect along the way. -newtype Stats = Stats [RoundStats] - deriving (Show, ToJSON) - --- | Pretty-print Stats. -ppStats :: Stats -> String -ppStats (Stats rss) = - intercalate "\n" - [ "Round: " ++ show i ++ " - " ++ ppRoundStats rs - | (i, rs) <- zip [(1::Int)..] (filter isRoundStats (reverse rss)) ] - where - isRoundStats RoundStats{} = True - isRoundStats _ = False - --- | 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 RoundStats - -- | Timing stats for a round of data fetching - = RoundStats - { roundTime :: Microseconds - , roundAllocation :: Int - , roundDataSources :: HashMap Text DataSourceRoundStats - } - -- | 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] - } - deriving (Show) - --- | Pretty-print RoundStats. -ppRoundStats :: RoundStats -> String -ppRoundStats (RoundStats t a dss) = - show t ++ "us " ++ show a ++ " bytes\n" - ++ unlines [ " " ++ unpack nm ++ ": " ++ ppDataSourceRoundStats dsrs - | (nm, dsrs) <- sortBy (compare `on` fst) (toList dss) ] -ppRoundStats (FetchCall r ss) = show r ++ '\n':show ss - -instance ToJSON RoundStats where - toJSON RoundStats{..} = object - [ "time" .= roundTime - , "allocation" .= roundAllocation - , "dataSources" .= roundDataSources - ] - toJSON (FetchCall req strs) = object - [ "request" .= req - , "stack" .= strs - ] - --- | Detailed stats of each data source in each round. -data DataSourceRoundStats = DataSourceRoundStats - { dataSourceFetches :: Int - , dataSourceTime :: Maybe Microseconds - , dataSourceFailures :: Maybe Int - , dataSourceAllocation :: Maybe Int - } deriving (Show) - --- | Pretty-print DataSourceRoundStats -ppDataSourceRoundStats :: DataSourceRoundStats -> String -ppDataSourceRoundStats (DataSourceRoundStats fetches time failures allocs) = - maybe id (\t s -> s ++ " (" ++ show t ++ "us)") time $ - maybe id (\a s -> s ++ " (" ++ show a ++ " bytes)") allocs $ - maybe id (\f s -> s ++ " " ++ show f ++ " failures") failures $ - show fetches ++ " fetches" - -instance ToJSON DataSourceRoundStats where - toJSON DataSourceRoundStats{..} = object [k .= v | (k, Just v) <- - [ ("fetches", Just dataSourceFetches) - , ("time", dataSourceTime) - , ("failures", dataSourceFailures) - , ("allocation", dataSourceAllocation) - ]] - -fetchesInRound :: RoundStats -> Int -fetchesInRound (RoundStats _ _ hm) = - sum $ map dataSourceFetches $ HashMap.elems hm -fetchesInRound _ = 0 - -emptyStats :: Stats -emptyStats = Stats [] - -numRounds :: Stats -> Int -numRounds (Stats rs) = length [ s | s@RoundStats{} <- rs ] - -numFetches :: Stats -> Int -numFetches (Stats rs) = sum (map fetchesInRound rs) - - --- --------------------------------------------------------------------------- --- Profiling - -type ProfileLabel = Text -type AllocCount = Int64 -type MemoHitCount = Int64 - -data Profile = Profile - { profileRound :: {-# UNPACK #-} !Round - -- ^ Keep track of what the current fetch round is. - , profile :: HashMap ProfileLabel ProfileData - -- ^ Data on individual labels. - , profileCache :: DataCache (Constant Round) - -- ^ Keep track of the round requests first appear in. - } - -emptyProfile :: Profile -emptyProfile = Profile 1 HashMap.empty emptyDataCache - -data ProfileData = ProfileData - { profileAllocs :: {-# UNPACK #-} !AllocCount - -- ^ allocations made by this label - , profileDeps :: HashSet ProfileLabel - -- ^ labels that this label depends on - , profileFetches :: Map Round (HashMap Text Int) - -- ^ map from round to {datasource name => fetch count} - , profileMemoHits :: {-# UNPACK #-} !MemoHitCount - -- ^ number of hits to memoized computation at this label - } - deriving Show - -emptyProfileData :: ProfileData -emptyProfileData = ProfileData 0 HashSet.empty Map.empty 0 - --- --------------------------------------------------------------------------- --- 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. --- --- See the definition of 'ResultVar' for more details. - -newtype DataCache res = DataCache (HashMap 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 res = - forall req a . (Hashable (req a), Eq (req a), Typeable (req a)) => - SubCache (req a -> String) (a -> String) ! (HashMap (req a) (res a)) - -- NB. the inner HashMap is strict, to avoid building up - -- a chain of thunks during repeated insertions. - --- | A new, empty 'DataCache'. -emptyDataCache :: DataCache res -emptyDataCache = DataCache HashMap.empty - --- --------------------------------------------------------------------------- --- 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. - -> [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 '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 - ) - --- | 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 ()) - --- Why does AsyncFetch contain a `IO () -> IO ()` rather than the --- alternative approach of returning the `IO` action to retrieve the --- results, which might seem better: `IO (IO ())`? The point is that --- this allows the data source to acquire resources for the purpose of --- this fetching round using the standard `bracket` pattern, so it can --- ensure that the resources acquired are properly released even if --- other data sources fail. - --- | 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) - --- | 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 in 'BlockedFetch' -newtype ResultVar a = ResultVar (MVar (Either SomeException a)) - --- 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. - -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 - - -{- | -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 $ \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. - - -> [BlockedFetch request] - -- ^ Requests to submit. - - -> PerformFetch - -asyncFetchAcquireRelease - acquire release dispatch wait enqueue _state _flags _si requests = - AsyncFetch $ \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 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 @@ -2,23 +2,15 @@ -- 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 #-} +-- found in the LICENSE file. +-- | Internal utilities only. +-- module Haxl.Core.Util ( compose , textShow - , tryReadMVar ) where -#if __GLASGOW_HASKELL__ >= 708 -import Control.Concurrent (tryReadMVar) -#else -import Control.Concurrent -#endif - import Data.Text (Text) import qualified Data.Text as Text @@ -26,15 +18,6 @@ -- | 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 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) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# 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 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.Exception as Exception +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) -> + mask $ \unmask -> + forkFinally (unmask (performIO req)) (putResultFromChildThread rv) diff --git a/Haxl/Prelude.hs b/Haxl/Prelude.hs --- a/Haxl/Prelude.hs +++ b/Haxl/Prelude.hs @@ -2,8 +2,7 @@ -- 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. +-- found in the LICENSE file. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} @@ -66,10 +65,12 @@ ) 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, void) diff --git a/PATENTS b/PATENTS deleted file mode 100644 --- a/PATENTS +++ /dev/null @@ -1,33 +0,0 @@ -Additional Grant of Patent Rights Version 2 - -"Software" means the Haxl software distributed by Facebook, Inc. - -Facebook, Inc. ("Facebook") hereby grants to each recipient of the Software -("you") a perpetual, worldwide, royalty-free, non-exclusive, irrevocable -(subject to the termination provision below) license under any Necessary -Claims, 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 any third party or (ii) the Software in -combination with any software or other technology. - -The license granted hereunder will terminate, automatically and without notice, -if you (or any of your subsidiaries, corporate affiliates or agents) initiate -directly or indirectly, or take a direct financial interest in, any Patent -Assertion: (i) against Facebook or any of its subsidiaries or corporate -affiliates, (ii) against any party if such Patent Assertion arises in whole or -in part from any software, technology, product or service of Facebook or any of -its subsidiaries or corporate affiliates, or (iii) against any party relating -to the Software. Notwithstanding the foregoing, if Facebook or any of its -subsidiaries or corporate affiliates files a lawsuit alleging patent -infringement against you in the first instance, and you respond by filing a -patent infringement counterclaim in that lawsuit against that party that is -unrelated to the Software, the license granted hereunder will not terminate -under section (i) of this paragraph due to such counterclaim. - -A "Necessary Claim" is a claim of a patent owned by Facebook that is -necessarily infringed by the Software standing alone. - -A "Patent Assertion" is any lawsuit or other action alleging direct, indirect, -or contributory infringement or inducement to infringe any patent, including a -cross-claim or counterclaim. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,26 @@ +# 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 diff --git a/haxl.cabal b/haxl.cabal --- a/haxl.cabal +++ b/haxl.cabal @@ -1,11 +1,11 @@ name: haxl -version: 0.5.1.0 +version: 2.0.0.0 synopsis: A Haskell library for efficient, concurrent, and concise data access. homepage: https://github.com/facebook/Haxl bug-reports: https://github.com/facebook/Haxl/issues -license: OtherLicense -license-files: LICENSE,PATENTS +license: BSD3 +license-files: LICENSE author: Facebook, Inc. maintainer: The Haxl Team copyright: Copyright (c) 2014-present, Facebook, Inc. @@ -17,7 +17,8 @@ GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, - GHC==8.2.1 + GHC==8.2.2, + GHC==8.4.1 description: Haxl is a library and EDSL for efficient scheduling of concurrent data @@ -36,21 +37,19 @@ extra-source-files: readme.md - PATENTS tests/LoadCache.txt changelog.md library build-depends: - HUnit >= 1.2 && < 1.7, - aeson >= 0.6 && < 1.3, + aeson >= 0.6 && < 1.4, base == 4.*, binary >= 0.7 && < 0.10, bytestring >= 0.9 && < 0.11, containers == 0.5.*, deepseq, - exceptions >=0.8 && <0.9, + exceptions >=0.8 && <0.11, filepath >= 1.3 && < 1.5, ghc-prim, hashable == 1.2.*, @@ -58,21 +57,33 @@ -- text 1.2.1.0 required for instance Binary Text text >= 1.2.1.0 && < 1.3, time >= 1.4 && < 1.9, + stm == 2.4.*, transformers, unordered-containers == 0.2.*, vector >= 0.10 && <0.13 + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.18.3 && <0.19 + exposed-modules: Haxl.Core, Haxl.Core.DataCache, + Haxl.Core.DataSource, Haxl.Core.Exception, + 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.StateStore, Haxl.Core.ShowP, - Haxl.Core.Types, + Haxl.Core.StateStore, + Haxl.Core.Stats, Haxl.Prelude + Haxl.DataSource.ConcurrentIO other-modules: Haxl.Core.Util @@ -80,14 +91,19 @@ default-language: Haskell2010 ghc-options: + -O2 -fprof-auto -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-name-shadowing + else + ghc-options: -fno-warn-name-shadowing test-suite test build-depends: - HUnit, - aeson, + aeson >= 0.6 && < 1.3, + HUnit >= 1.2 && < 1.7, base == 4.*, binary, bytestring, @@ -113,30 +129,40 @@ main-is: TestMain.hs + if impl(ghc >= 8.0) + other-modules: + AdoTests + other-modules: - AdoTests AllTests BadDataSource BatchTests - Bench CoreTests DataCacheTest ExampleDataSource + FullyAsyncTest LoadCache MemoizationTests MockTAO ProfileTests + SleepDataSource TestBadDataSource TestExampleDataSource TestTypes TestUtils + WorkDataSource type: exitcode-stdio-1.0 default-language: Haskell2010 +flag bench + default: False + executable monadbench + if !flag(bench) + buildable: False default-language: Haskell2010 hs-source-dirs: @@ -152,3 +178,20 @@ ExampleDataSource ghc-options: -O2 -main-is MonadBench -rtsopts + +executable cachebench + if !flag(bench) + buildable: False + default-language: + Haskell2010 + hs-source-dirs: + tests + build-depends: + base, + haxl, + hashable, + 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 @@ -22,6 +22,11 @@ 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. @@ -35,6 +40,10 @@ * [An example Facebook data source](example/facebook/readme.md) walks through building an example data source that queries the Facebook Graph API concurrently. + + * [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](example/sql/readme.md) explains how Haxl can address a common performance problem with SQL queries by diff --git a/tests/AdoTests.hs b/tests/AdoTests.hs --- a/tests/AdoTests.hs +++ b/tests/AdoTests.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE RebindableSyntax, OverloadedStrings, ApplicativeDo #-} module AdoTests (tests) where @@ -42,8 +48,8 @@ b' <- friendsOf =<< if null b then id4 else id3 return (length (a' ++ b')) -tests = TestList - [ TestLabel "ado1" $ TestCase ado1 - , TestLabel "ado2" $ TestCase ado2 - , TestLabel "ado3" $ TestCase ado3 +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 --- a/tests/AllTests.hs +++ b/tests/AllTests.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE CPP, OverloadedStrings #-} module AllTests (allTests) where @@ -13,21 +19,24 @@ #endif import MemoizationTests import TestBadDataSource +import FullyAsyncTest import Test.HUnit allTests :: Test allTests = TestList [ TestLabel "ExampleDataSource" TestExampleDataSource.tests - , TestLabel "BatchTests" BatchTests.tests + , TestLabel "BatchTests-future" $ BatchTests.tests True + , TestLabel "BatchTests-sync" $ BatchTests.tests False , TestLabel "CoreTests" CoreTests.tests , TestLabel "DataCacheTests" DataCacheTest.tests #if __GLASGOW_HASKELL__ >= 801 - , TestLabel "AdoTests" AdoTests.tests + , TestLabel "AdoTests" $ AdoTests.tests False #endif #if __GLASGOW_HASKELL__ >= 710 , TestLabel "ProfileTests" ProfileTests.tests #endif , TestLabel "MemoizationTests" MemoizationTests.tests , TestLabel "BadDataSourceTests" TestBadDataSource.tests + , TestLabel "FullyAsyncTest" FullyAsyncTest.tests ] diff --git a/tests/BadDataSource.hs b/tests/BadDataSource.hs --- a/tests/BadDataSource.hs +++ b/tests/BadDataSource.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/tests/BatchTests.hs b/tests/BatchTests.hs --- a/tests/BatchTests.hs +++ b/tests/BatchTests.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} module BatchTests (tests) where @@ -127,20 +133,20 @@ -- -- Basic sanity check on data-cache re-use -- -cacheReuse = do - env <- makeTestEnv +cacheReuse future = do + env <- makeTestEnv future expectRoundsWithEnv 2 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) -- ensure no more data fetching rounds needed expectRoundsWithEnv 0 12 batching7_ env2 -noCaching = do - env <- makeTestEnv +noCaching future = do + env <- makeTestEnv future let env' = env{ flags = (flags env){caching = 0} } result <- runHaxl env' caching3_ assertEqual "result" result 18 @@ -155,8 +161,8 @@ (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") @@ -176,8 +182,8 @@ Left (NotFound "xxx") -> True _ -> False -pOrTests = do - env <- makeTestEnv +pOrTests future = do + env <- makeTestEnv future -- Test semantics r <- runHaxl env $ do @@ -188,7 +194,7 @@ return (not a && b && c && d) assertBool "pOr0" r - -- pOr is left-biased with respsect to exceptions: + -- 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 @@ -224,8 +230,8 @@ Left (NotFound _) -> True _ -> False -pAndTests = do - env <- makeTestEnv +pAndTests future = do + env <- makeTestEnv future -- Test semantics r <- runHaxl env $ do @@ -236,7 +242,7 @@ return (not a && not b && not c && d) assertBool "pAnd0" r - -- pAnd is left-biased with respsect to exceptions: + -- 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 @@ -273,24 +279,26 @@ Left (NotFound _) -> True _ -> False -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 "batching9" $ TestCase batching9 - , TestLabel "caching1" $ TestCase caching1 - , TestLabel "caching2" $ TestCase caching2 - , TestLabel "caching3" $ TestCase caching3 - , TestLabel "CacheReuse" $ TestCase cacheReuse - , TestLabel "NoCaching" $ TestCase noCaching - , TestLabel "exceptionTest1" $ TestCase exceptionTest1 - , TestLabel "exceptionTest2" $ TestCase exceptionTest2 - , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions - , TestLabel "pOrTest" $ TestCase pOrTests - , TestLabel "pAndTest" $ TestCase pAndTests +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 --- a/tests/Bench.hs +++ b/tests/Bench.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE RankNTypes, GADTs, BangPatterns, DeriveDataTypeable, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-type-defaults #-} @@ -5,11 +11,11 @@ module Bench where import Haxl.Core.DataCache as DataCache -import Haxl.Core.Types import Prelude hiding (mapM) import Data.Hashable +import Data.IORef import Data.Time.Clock import Data.Traversable import Data.Typeable @@ -36,12 +42,12 @@ let f 0 !cache = return cache f !n !cache = do - m <- newResult 0 + m <- newIORef 0 f (n-1) (DataCache.insert (ReqInt n) m cache) -- cache <- f n emptyDataCache let m = DataCache.lookup (ReqInt (n `div` 2)) cache - print =<< mapM takeResult m + print =<< mapM readIORef m t1 <- getCurrentTime printf "insert: %.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,6 +1,13 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RebindableSyntax #-} + module CoreTests where import Haxl.Prelude @@ -12,17 +19,29 @@ import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BS +import Data.List import Control.Exception (Exception(..)) +import ExampleDataSource + +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 () + useless :: String -> GenHaxl u Bool useless _ = throw (NotFound "ha ha") -en = error "no env" - exceptions :: Assertion exceptions = do + en <- emptyEnv () a <- runHaxl en $ try (useless "input") assertBool "NotFound -> HaxlException" $ isLeft (a :: Either HaxlException Bool) @@ -72,6 +91,38 @@ 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 @@ -80,7 +131,9 @@ -- 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 () + runHaxl en $ throw e `catch` \x -> return x printing :: Assertion printing = do @@ -98,7 +151,35 @@ BS.putStrLn $ encode c +withEnvTest :: Test +withEnvTest = TestLabel "withEnvTest" $ TestCase $ do + exstate <- ExampleDataSource.initGlobalState + e <- initEnv (stateSet exstate stateEmpty) False + b <- runHaxl e $ withEnv e { userEnv = True } $ env userEnv + assertBool "withEnv1" b + e <- initEnv (stateSet exstate stateEmpty) False + b <- runHaxl e $ withEnv e { userEnv = True } $ do + _ <- countAardvarks "aaa" + env userEnv + assertBool "withEnv2" b + e <- initEnv (stateSet exstate stateEmpty) False + 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 + 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,26 @@ -{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-} -module DataCacheTest (tests) where +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. +{-# LANGUAGE CPP, StandaloneDeriving, GADTs, DeriveDataTypeable #-} +module DataCacheTest (tests, newResult, takeResult) where + import Haxl.Core.DataCache as DataCache +import Haxl.Core.Monad import Haxl.Core +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif import Control.Exception import Data.Hashable import Data.Traversable import Data.Typeable import Prelude hiding (mapM) import Test.HUnit +import Data.IORef data TestReq a where Req :: Int -> TestReq a -- polymorphic result @@ -21,7 +32,17 @@ instance Hashable (TestReq a) where hashWithSalt salt (Req i) = hashWithSalt salt i +newResult :: a -> IO (IVar u a) +newResult a = IVar <$> newIORef (IVarFull (Ok a)) +takeResult :: IVar u a -> IO (ResultVal a) +takeResult (IVar 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 @@ -35,25 +56,25 @@ -- with a result of type String, we should get Nothing, not a crash. r <- mapM takeResult $ DataCache.lookup (Req 1) cache assertBool "dcSoundness1" $ - case r :: Maybe (Either SomeException String) of + case r :: Maybe (ResultVal String) of Nothing -> True _something_else -> False r <- mapM takeResult $ DataCache.lookup (Req 1) cache assertBool "dcSoundness2" $ - case r :: Maybe (Either SomeException Int) of - Just (Right 1) -> True + case r :: Maybe (ResultVal Int) of + Just (Ok 1) -> True _something_else -> False r <- mapM takeResult $ DataCache.lookup (Req 2) cache assertBool "dcSoundness3" $ - case r :: Maybe (Either SomeException String) of - Just (Right "hello") -> True + case r :: Maybe (ResultVal String) of + Just (Ok "hello") -> True _something_else -> False 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 diff --git a/tests/ExampleDataSource.hs b/tests/ExampleDataSource.hs --- a/tests/ExampleDataSource.hs +++ b/tests/ExampleDataSource.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -117,10 +123,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 @@ -150,8 +155,8 @@ -- Normally a data source will provide some convenient wrappers for -- its requests: -countAardvarks :: String -> GenHaxl () Int +countAardvarks :: String -> GenHaxl u Int countAardvarks str = dataFetch (CountAardvarks str) -listWombats :: Id -> GenHaxl () [Id] +listWombats :: Id -> GenHaxl u [Id] listWombats i = dataFetch (ListWombats i) diff --git a/tests/FullyAsyncTest.hs b/tests/FullyAsyncTest.hs new file mode 100644 --- /dev/null +++ b/tests/FullyAsyncTest.hs @@ -0,0 +1,66 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +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 = do + st <- mkConcurrentIOState + env <- initEnv (stateSet st stateEmpty) () + return env { flags = (flags env) { report = 2 } } + +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) + +andThen :: GenHaxl u a -> GenHaxl u b -> GenHaxl u b +andThen a b = a >>= \_ -> b + +{- + 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,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE CPP, OverloadedStrings #-} module LoadCache where diff --git a/tests/MemoizationTests.hs b/tests/MemoizationTests.hs --- a/tests/MemoizationTests.hs +++ b/tests/MemoizationTests.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE CPP #-} module MemoizationTests (tests) where @@ -9,7 +15,7 @@ import Test.HUnit import Haxl.Core -import Haxl.Core.Monad +import Haxl.Core.Monad (unsafeLiftIO) import ExampleDataSource diff --git a/tests/MockTAO.hs b/tests/MockTAO.hs --- a/tests/MockTAO.hs +++ b/tests/MockTAO.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -6,6 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} module MockTAO ( Id(..), @@ -43,16 +50,18 @@ 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 = FutureFetch $ return . mapM_ doFetch + | otherwise = SyncFetch $ mapM_ doFetch -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) = diff --git a/tests/MonadBench.hs b/tests/MonadBench.hs --- a/tests/MonadBench.hs +++ b/tests/MonadBench.hs @@ -2,16 +2,10 @@ -- 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. +-- found in the LICENSE file. -- | Benchmarking tool for core performance characteristics of the Haxl monad. {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL >= 800 -{-# OPTIONS_GHC -Wno-name-shadowing #-} -#else -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif module MonadBench (main) where import Control.Monad @@ -25,7 +19,7 @@ import Haxl.Prelude as Haxl import Prelude() -import Haxl.Core.Monad (newMemoWith, runMemo) +import Haxl.Core.Memo (newMemoWith, runMemo) import Haxl.Core @@ -118,7 +112,8 @@ ] exitWith (ExitFailure 1) t1 <- getCurrentTime - printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double) + printf "%10s: %10d reqs: %.2fs\n" + test n (realToFrac (t1 `diffUTCTime` t0) :: Double) where -- can't use >>, it is aliased to *> and we want the real bind here andThen x y = x >>= const y diff --git a/tests/ProfileTests.hs b/tests/ProfileTests.hs --- a/tests/ProfileTests.hs +++ b/tests/ProfileTests.hs @@ -1,25 +1,35 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} + module ProfileTests where import Haxl.Prelude -import Data.List import Haxl.Core import Haxl.Core.Monad +import Haxl.Core.Stats +import Haxl.DataSource.ConcurrentIO import Test.HUnit import Control.DeepSeq (force) import Control.Exception (evaluate) +import Data.Aeson import Data.IORef import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import TestUtils +import WorkDataSource mkProfilingEnv = do - env <- makeTestEnv + env <- makeTestEnv False return env { flags = (flags env) { report = 4 } } collectsdata :: Assertion @@ -29,17 +39,20 @@ withLabel "bar" $ withLabel "foo" $ do u <- env userEnv - if length (intersect (HashMap.keys u) ["c"]) > 1 - then return 5 - else return (4::Int) + -- do some non-trivial work that can't be lifted out + case fromJSON <$> HashMap.lookup "A" u of + Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5 + _otherwise -> return (4::Int) profData <- profile <$> readIORef (profRef e) assertEqual "has data" 3 $ HashMap.size profData assertBool "foo allocates" $ case profileAllocs <$> HashMap.lookup "foo" profData of - Just x -> x > 0 + Just x -> x > 10000 Nothing -> False - assertEqual "bar does not allocate" (Just 0) $ - profileAllocs <$> HashMap.lookup "bar" profData + assertBool "bar does not allocate (much)" $ + case profileAllocs <$> HashMap.lookup "bar" profData of + Just n -> n < 5000 -- getAllocationCounter can be off by +/- 4K + _otherwise -> False assertEqual "foo's parent" (Just ["bar"]) $ HashSet.toList . profileDeps <$> HashMap.lookup "foo" profData @@ -63,7 +76,24 @@ 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 :: Assertion +threadAlloc = do + st <- mkConcurrentIOState + env <- initEnv (stateSet st stateEmpty) () + a0 <- getAllocationCounter + _x <- runHaxl env $ work 100000 + a1 <- getAllocationCounter + assertBool "threadAlloc" $ (a0 - a1) > 1000000 + -- the result was 16MB on 64-bit, or around 25KB if we miss the allocs + -- in the child thread. + + tests = TestList [ TestLabel "collectsdata" $ TestCase collectsdata , TestLabel "exceptions" $ TestCase exceptions + , TestLabel "threads" $ TestCase threadAlloc ] diff --git a/tests/SleepDataSource.hs b/tests/SleepDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/SleepDataSource.hs @@ -0,0 +1,46 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +module SleepDataSource ( + 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 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/TestBadDataSource.hs b/tests/TestBadDataSource.hs --- a/tests/TestBadDataSource.hs +++ b/tests/TestBadDataSource.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE OverloadedStrings #-} module TestBadDataSource (tests) where diff --git a/tests/TestExampleDataSource.hs b/tests/TestExampleDataSource.hs --- a/tests/TestExampleDataSource.hs +++ b/tests/TestExampleDataSource.hs @@ -1,4 +1,11 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE CPP, OverloadedStrings, RebindableSyntax, MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} module TestExampleDataSource (tests) where import Haxl.Prelude as Haxl @@ -7,7 +14,6 @@ import Haxl.Core.Monad (unsafeLiftIO) import Haxl.Core -import qualified Data.HashMap.Strict as HashMap import Test.HUnit import Data.IORef import Data.Maybe @@ -26,7 +32,8 @@ let st = stateSet exstate stateEmpty -- Create the Env: - initEnv st () + env <- initEnv st () + return env{ flags = (flags env){ report = 2 } } tests = TestList [ @@ -34,9 +41,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. @@ -52,14 +62,15 @@ -- Should be just one fetching round: Stats stats <- readIORef (statsRef env) + putStrLn (ppStats (Stats stats)) assertEqual "rounds" 1 (length stats) -- With two fetches: assertBool "reqs" $ - if | RoundStats { roundDataSources = m } : _ <- stats, - Just (DataSourceRoundStats { dataSourceFetches = 2 }) - <- HashMap.lookup "ExampleDataSource" m -> True - | otherwise -> False + case stats of + [FetchStats{..}] -> + fetchDataSource == "ExampleDataSource" && fetchBatchSize == 2 + _otherwise -> False -- Test side-effect ordering @@ -97,8 +108,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 @@ -126,6 +137,16 @@ 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 @@ -142,6 +163,18 @@ 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 diff --git a/tests/TestMain.hs b/tests/TestMain.hs --- a/tests/TestMain.hs +++ b/tests/TestMain.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE CPP, OverloadedStrings #-} module Main where diff --git a/tests/TestTypes.hs b/tests/TestTypes.hs --- a/tests/TestTypes.hs +++ b/tests/TestTypes.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,3 +1,9 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + {-# LANGUAGE OverloadedStrings #-} module TestUtils ( makeTestEnv @@ -40,11 +46,12 @@ id4 :: Haxl Id id4 = lookupInput "D" -makeTestEnv :: IO (Env UserEnv) -makeTestEnv = do - tao <- MockTAO.initGlobalState +makeTestEnv :: Bool -> IO (Env UserEnv) +makeTestEnv future = do + tao <- MockTAO.initGlobalState future let st = stateSet tao stateEmpty - initEnv st testinput + env <- initEnv st testinput + return env { flags = (flags env) { report = 2 } } expectRoundsWithEnv :: (Eq a, Show a) => Int -> a -> Haxl a -> Env UserEnv -> Assertion @@ -54,14 +61,14 @@ 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 +expectRounds :: (Eq a, Show a) => Int -> a -> Haxl a -> Bool -> Assertion +expectRounds n result haxl future = do + env <- makeTestEnv future expectRoundsWithEnv n result haxl env -expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Assertion -expectFetches n haxl = do - env <- makeTestEnv +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,44 @@ +-- Copyright (c) 2014-present, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + +module WorkDataSource ( + work, + ) where + +import Haxl.Prelude +import Prelude () + +import Haxl.Core +import Haxl.DataSource.ConcurrentIO + +import Control.Exception +import Data.Hashable +import Data.Typeable + +work :: Integer -> GenHaxl u Integer +work n = dataFetch (Work n) + +data Work deriving Typeable +instance ConcurrentIO Work where + data ConcurrentIOReq Work a where + Work :: Integer -> ConcurrentIOReq Work Integer + + performIO (Work n) = evaluate (sum [1..n]) >> return n + +deriving instance Eq (ConcurrentIOReq Work a) +deriving instance Show (ConcurrentIOReq Work a) + +instance ShowP (ConcurrentIOReq Work) where showp = show + +instance Hashable (ConcurrentIOReq Work a) where + hashWithSalt s (Work n) = hashWithSalt s n