haxl 2.3.0.0 → 2.5.1.1
raw patch · 51 files changed
Files
- Haxl/Core.hs +20/−6
- Haxl/Core/CallGraph.hs +8/−1
- Haxl/Core/DataCache.hs +9/−7
- Haxl/Core/DataSource.hs +31/−12
- Haxl/Core/Exception.hs +12/−11
- Haxl/Core/Fetch.hs +161/−62
- Haxl/Core/Flags.hs +82/−20
- Haxl/Core/Memo.hs +33/−27
- Haxl/Core/Monad.hs +148/−70
- Haxl/Core/Parallel.hs +8/−6
- Haxl/Core/Profile.hs +27/−18
- Haxl/Core/RequestStore.hs +11/−8
- Haxl/Core/Run.hs +20/−15
- Haxl/Core/ShowP.hs +7/−5
- Haxl/Core/StateStore.hs +13/−8
- Haxl/Core/Stats.hs +38/−5
- Haxl/Core/Util.hs +7/−5
- Haxl/DataSource/ConcurrentIO.hs +7/−5
- Haxl/Prelude.hs +7/−5
- Setup.hs +9/−0
- changelog.md +11/−1
- haxl.cabal +29/−14
- readme.md +2/−2
- tests/AdoTests.hs +7/−5
- tests/AllTests.hs +11/−5
- tests/BadDataSource.hs +7/−5
- tests/BatchTests.hs +7/−5
- tests/Bench.hs +7/−5
- tests/CoreTests.hs +14/−12
- tests/DataCacheTest.hs +125/−12
- tests/DataSourceDispatchTests.hs +83/−0
- tests/ExampleDataSource.hs +7/−5
- tests/ExceptionStackTests.hs +73/−0
- tests/FullyAsyncTest.hs +10/−6
- tests/LoadCache.hs +7/−5
- tests/MemoizationTests.hs +8/−6
- tests/MockTAO.hs +7/−5
- tests/MonadAsyncTest.hs +9/−7
- tests/MonadBench.hs +23/−16
- tests/OutgoneFetchesTests.hs +9/−8
- tests/ParallelTests.hs +9/−0
- tests/ProfileTests.hs +39/−9
- tests/SleepDataSource.hs +7/−5
- tests/StatsTests.hs +11/−7
- tests/TestBadDataSource.hs +7/−5
- tests/TestExampleDataSource.hs +10/−6
- tests/TestMain.hs +7/−5
- tests/TestTypes.hs +25/−11
- tests/TestUtils.hs +16/−8
- tests/WorkDataSource.hs +7/−5
- tests/WriteTests.hs +187/−16
Haxl/Core.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ -- | Everything needed to define data sources and to invoke the -- engine. --@@ -63,7 +65,16 @@ , AllocCount , LabelHitCount - -- ** Tracing flags+ -- * Report flags+ , ReportFlag(..)+ , ReportFlags+ , defaultReportFlags+ , profilingReportFlags+ , setReportFlag+ , clearReportFlag+ , testReportFlag++ -- ** Flags , Flags(..) , defaultFlags , ifTrace@@ -88,6 +99,9 @@ , putResult , putSuccess , putResultFromChildThread+ , putResultWithStats+ , putResultWithStatsFromChildThread+ , DataSourceStats(..) -- ** Default fetch implementations , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease
Haxl/Core/CallGraph.hs view
@@ -1,4 +1,11 @@--- Copyright 2004-present Facebook. All Rights Reserved.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}
Haxl/Core/DataCache.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -50,8 +52,8 @@ -- '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) ! (HashTable (req a) (res a))+ forall req a . (Hashable (req a), Eq (req a)) =>+ SubCache (req a -> String) (a -> String) !(HashTable (req a) (res a)) -- NB. the inner HashMap is strict, to avoid building up -- a chain of thunks during repeated insertions.
Haxl/Core/DataSource.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-}@@ -36,6 +38,8 @@ , putResult , putResultFromChildThread , putSuccess+ , putResultWithStats+ , putResultWithStatsFromChildThread -- * Default fetch implementations , asyncFetch, asyncFetchWithDispatch@@ -55,12 +59,14 @@ import Control.Monad import Data.Hashable import Data.Text (Text)+import Data.Kind (Type) import Data.Typeable import Haxl.Core.Exception import Haxl.Core.Flags import Haxl.Core.ShowP import Haxl.Core.StateStore+import Haxl.Core.Stats import GHC.Conc ( newStablePtrPrimMVar@@ -70,7 +76,6 @@ , myThreadId ) import Control.Concurrent.MVar import Foreign.StablePtr-import System.Mem (setAllocationCounter) -- --------------------------------------------------------------------------- -- DataSource class@@ -104,10 +109,13 @@ schedulerHint :: u -> SchedulerHint req schedulerHint _ = TryToBatch + schedulerHintState :: Maybe (State req) -> u -> SchedulerHint req+ schedulerHintState _ u = schedulerHint u+ classifyFailure :: u -> req a -> SomeException -> FailureClassification classifyFailure _ _ _ = StandardFailure -class DataSourceName (req :: * -> *) where+class DataSourceName (req :: Type -> Type) where -- | The name of this 'DataSource', used in tracing and stats. Must -- take a dummy request. dataSourceName :: Proxy req -> Text@@ -128,7 +136,7 @@ ) -- | Hints to the scheduler about this data source-data SchedulerHint (req :: * -> *)+data SchedulerHint (req :: Type -> Type) = TryToBatch -- ^ Hold data-source requests while we execute as much as we can, so -- that we can hopefully collect more requests to batch.@@ -183,12 +191,15 @@ -- ResultVar -- | A sink for the result of a data fetch in 'BlockedFetch'-newtype ResultVar a = ResultVar (Either SomeException a -> Bool -> IO ())+newtype ResultVar a =+ ResultVar (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ()) -- The Bool here is True if result was returned by a child thread, -- rather than the main runHaxl thread. see Note [tracking allocation in -- child threads] -mkResultVar :: (Either SomeException a -> Bool -> IO ()) -> ResultVar a+mkResultVar+ :: (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())+ -> ResultVar a mkResultVar = ResultVar putFailure :: (Exception e) => ResultVar a -> e -> IO ()@@ -198,8 +209,16 @@ putSuccess r = putResult r . Right putResult :: ResultVar a -> Either SomeException a -> IO ()-putResult (ResultVar io) res = io res False+putResult (ResultVar io) res = io res False Nothing +putResultWithStats+ :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()+putResultWithStats (ResultVar io) res st = io res False (Just st)++putResultWithStatsFromChildThread+ :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()+putResultWithStatsFromChildThread (ResultVar io) res st = io res True (Just st)+ -- | Like `putResult`, but used to get correct accounting when work is -- being done in child threads. This is particularly important for -- data sources that are using 'BackgroundFetch', The allocation performed@@ -216,7 +235,7 @@ -- 'putResultFromChildThread', so that allocation is not counted -- multiple times. putResultFromChildThread :: ResultVar a -> Either SomeException a -> IO ()-putResultFromChildThread (ResultVar io) res = io res True+putResultFromChildThread (ResultVar io) res = io res True Nothing -- see Note [tracking allocation in child threads] -- | Function for easily setting a fetch to a particular exception
Haxl/Core/Exception.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-}@@ -81,6 +83,7 @@ import Data.Binary (Binary) import Data.Typeable import Data.Text (Text)+import qualified Data.Text as Text import Haxl.Core.Util import GHC.Stack@@ -113,11 +116,12 @@ e deriving (Typeable) -type Stack = [String]+type Stack = [Text] -- hopefully this will get more informative in the future instance Show HaxlException where- show (HaxlException (Just stk@(_:_)) e) = show e ++ '\n' : renderStack stk+ show (HaxlException (Just stk@(_:_)) e) =+ show e ++ '\n' : renderStack (reverse $ map Text.unpack stk) show (HaxlException _ e) = show e instance Exception HaxlException@@ -126,7 +130,7 @@ instance ToJSON HaxlException where toJSON (HaxlException stk e) = object fields where- fields | Just s@(_:_) <- stk = ("stack" .= reverse s) : rest+ fields | Just s@(_:_) <- stk = ("stack" .= s) : rest | otherwise = rest rest = [ "type" .= show (typeOf e)@@ -362,9 +366,6 @@ rethrowAsyncExceptions :: SomeException -> IO () rethrowAsyncExceptions e | Just SomeAsyncException{} <- fromException e = Exception.throw e- | Just AllocationLimitExceeded{} <- fromException e = Exception.throw e- -- AllocationLimitExceeded is not a child of SomeAsyncException,- -- but it should be. | otherwise = return () tryWithRethrow :: IO a -> IO (Either SomeException a)
Haxl/Core/Fetch.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-}@@ -23,6 +25,7 @@ module Haxl.Core.Fetch ( dataFetch , dataFetchWithShow+ , dataFetchWithInsert , uncachedRequest , cacheResult , dupableCacheRequest@@ -47,6 +50,7 @@ import Data.Proxy import Data.Typeable import Data.Text (Text)+import Data.Kind (Type) import qualified Data.Text as Text import Text.Printf #ifdef PROFILING@@ -111,8 +115,7 @@ doFetch = do ivar <- newIVar k <- nextCallId env- let !rvar = stdResultVar ivar completions submittedReqsRef flags- (Proxy :: Proxy r)+ let !rvar = stdResultVar env ivar (Proxy :: Proxy r) insertFn req (DataCacheItem ivar k) dataCache return (Uncached rvar ivar k) mbRes <- DataCache.lookup req dataCache@@ -137,14 +140,12 @@ -- completes. stdResultVar :: forall r a u w. (DataSourceName r, Typeable r)- => IVar u w a- -> TVar [CompleteReq u w]- -> IORef ReqCountMap- -> Flags+ => Env u w+ -> IVar u w a -> Proxy r -> ResultVar a-stdResultVar ivar completions ref flags p =- mkResultVar $ \r isChildThread -> do+stdResultVar Env{..} ivar p =+ mkResultVar $ \r isChildThread _ -> do allocs <- if isChildThread then -- In a child thread, return the current allocation counter too,@@ -155,12 +156,12 @@ atomicallyOnBlocking (LogicBug (ReadingCompletionsFailedFetch (dataSourceName p))) $ do cs <- readTVar completions- writeTVar completions (CompleteReq r ivar allocs : cs)+ writeTVar completions (CompleteReq (eitherToResult r) ivar allocs : cs) -- Decrement the counter as request has finished. Do this after updating the -- completions TVar so that if the scheduler is tracking what was being -- waited on it gets a consistent view.- ifReport flags 1 $- atomicModifyIORef' ref (\m -> (subFromCountMap p 1 m, ()))+ ifReport flags ReportOutgoneFetches $+ atomicModifyIORef' submittedReqsRef (\m -> (subFromCountMap p 1 m, ())) {-# INLINE stdResultVar #-} @@ -169,7 +170,7 @@ logFetch :: Env u w -> (r a -> String) -> r a -> CallId -> IO () #ifdef PROFILING logFetch env showFn req fid = do- ifReport (flags env) 5 $ do+ ifReport (flags env) ReportFetchStack $ do stack <- currentCallStack modifyIORef' (statsRef env) $ \(Stats s) -> Stats (FetchCall (showFn req) stack fid : s)@@ -177,6 +178,55 @@ logFetch _ _ _ _ = return () #endif +calcFailure+ :: forall u req a . DataSource u req+ => u+ -> req a+ -> Either SomeException a+ -> FailureCount+calcFailure _u _r Right{} = mempty+calcFailure u r (Left e) = case classifyFailure u r e of+ StandardFailure -> mempty { failureCountStandard = 1 }+ IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }++addFallbackFetchStats+ :: forall u w req a . DataSource u req+ => Env u w+ -> CallId+ -> req a+ -> ResultVal a w+ -> IO ()+addFallbackFetchStats Env{..} fid req res = do+ bid <- atomicModifyIORef' statsBatchIdRef $ \x -> (x+1,x+1)+ start <- getTimestamp+ let+ dsName = dataSourceName (Proxy :: Proxy req)+ FailureCount{..} = case res of+ Ok{} -> mempty+ (ThrowHaxl e _) -> calcFailure userEnv req (Left e)+ (ThrowIO e) -> calcFailure userEnv req (Left e)+ this = FetchStats { fetchDataSource = dsName+ , fetchBatchSize = 1+ , fetchStart = start+ , fetchDuration = 0+ , fetchSpace = 0+ , fetchFailures = failureCountStandard+ , fetchIgnoredFailures = failureCountIgnored+ , fetchBatchId = bid+ , fetchIds = [fid] }+ atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ())++addFallbackResult+ :: Env u w+ -> ResultVal a w+ -> IVar u w a+ -> IO ()+addFallbackResult Env{..} res ivar = do+ atomicallyOnBlocking+ (LogicBug (ReadingCompletionsFailedFetch "addFallbackResult")) $ do+ cs <- readTVar completions+ writeTVar completions (CompleteReq res ivar 0 : cs)+ -- | Performs actual fetching of data for a 'Request' from a 'DataSource'. dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a dataFetch = dataFetchWithInsert show DataCache.insert@@ -212,18 +262,38 @@ -- Check whether the data source wants to submit requests -- eagerly, or batch them up. --- let blockedFetch = BlockedFetch req rvar- let blockedFetchI = BlockedFetchInternal fid- case schedulerHint userEnv :: SchedulerHint r of- SubmitImmediately ->- performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]- TryToBatch ->- -- add the request to the RequestStore and continue- modifyIORef' reqStoreRef $ \bs ->- addRequest blockedFetch blockedFetchI bs- --- return $ Blocked ivar (Return ivar)+ let+ blockedFetch = BlockedFetch req rvar+ blockedFetchI = BlockedFetchInternal fid+ submitFetch = do+ let hint :: SchedulerHint r+ hint = schedulerHintState (stateGet states) userEnv+ case hint of+ SubmitImmediately ->+ performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]+ TryToBatch ->+ -- add the request to the RequestStore and continue+ modifyIORef' reqStoreRef $ \bs ->+ addRequest blockedFetch blockedFetchI bs+ return $ Blocked ivar (Return ivar) + -- if there is a fallback configured try that,+ -- else dispatch the fetch+ case dataCacheFetchFallback of+ Nothing -> submitFetch+ Just (DataCacheLookup dcl) -> do+ mbFallbackRes <- dcl req+ case mbFallbackRes of+ Nothing -> submitFetch+ Just fallbackRes -> do+ addFallbackResult env fallbackRes ivar+ ifReport flags ReportFetchStats $ addFallbackFetchStats+ env+ fid+ req+ fallbackRes+ return $ Blocked ivar (Return ivar)+ -- Seen before but not fetched yet. We're blocked, but we don't have -- to add the request to the RequestStore. CachedNotFetched ivar fid -> do@@ -233,7 +303,7 @@ -- Cached: either a result, or an exception Cached r fid -> do ifProfiling flags $ addProfileFetch env req fid True- done r+ done env r -- | A data request that is not cached. This is not what you want for -- normal read requests, because then multiple identical requests may@@ -251,17 +321,16 @@ -- allows a transparent run afterwards. Without this, the test would try to -- call the datasource during testing and that would be an exception. uncachedRequest- :: forall a u w (r :: * -> *). (DataSource u r, Request r a)+ :: forall a u w (r :: Type -> Type). (DataSource u r, Request r a) => r a -> GenHaxl u w a uncachedRequest req = do flg <- env flags- subRef <- env submittedReqsRef if recording flg /= 0 then dataFetch req else GenHaxl $ \e@Env{..} -> do ivar <- newIVar k <- nextCallId e- let !rvar = stdResultVar ivar completions subRef flg (Proxy :: Proxy r)+ let !rvar = stdResultVar e ivar (Proxy :: Proxy r) modifyIORef' reqStoreRef $ \bs -> addRequest (BlockedFetch req rvar) (BlockedFetchInternal k) bs return $ Blocked ivar (Return ivar)@@ -292,26 +361,34 @@ -> r a -> IO a -> GenHaxl u w a-cacheResultWithInsert showFn insertFn req val = GenHaxl $ \e@Env{..} -> do+cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env@Env{..} -> do mbRes <- DataCache.lookup req dataCache case mbRes of Nothing -> do- eitherResult <- Exception.try val- case eitherResult of- Left e -> rethrowAsyncExceptions e- _ -> return ()- let result = eitherToResultThrowIO eitherResult+ let+ getResult = do+ eitherResult <- Exception.try val+ case eitherResult of+ Left e -> rethrowAsyncExceptions e+ _ -> return ()+ return $ eitherToResultThrowIO eitherResult+ -- if there is a fallback configured try that+ result <- case dataCacheFetchFallback of+ Nothing -> getResult+ Just (DataCacheLookup dcl) -> do+ mbFallbackRes <- dcl req+ maybe getResult return mbFallbackRes ivar <- newFullIVar result- k <- nextCallId e+ k <- nextCallId env insertFn req (DataCacheItem ivar k) dataCache- done result+ done env result Just (DataCacheItem IVar{ivarRef = cr} _) -> do e <- readIORef cr case e of- IVarEmpty _ -> corruptCache- IVarFull r -> done r+ IVarEmpty _ -> raise env corruptCache+ IVarFull r -> done env r where- corruptCache = raise . DataSourceError $ Text.concat+ corruptCache = DataSourceError $ Text.concat [ Text.pack (showFn req) , " has a corrupted cache value: these requests are meant to" , " return immediately without an intermediate value. Either"@@ -341,7 +418,7 @@ -- 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 $+ _other -> raise e $ DataSourceError "cacheRequest: request is already in the cache" -- | Similar to @cacheRequest@ but doesn't throw an exception if the key@@ -386,7 +463,7 @@ <> Text.pack (showp req) Just state -> return $ FetchToDo reqs- $ (if report f >= 2+ $ (if testReportFlag ReportFetchStats $ report f then wrapFetchInStats (userEnv env) sref@@ -413,7 +490,7 @@ data FetchToDo where FetchToDo- :: forall (req :: * -> *). (DataSourceName req, Typeable req)+ :: forall (req :: Type -> Type). (DataSourceName req, Typeable req) => [BlockedFetch req] -> PerformFetch req -> FetchToDo -- Catch exceptions arising from the data source and stuff them into@@ -459,13 +536,15 @@ #if __GLASGOW_HASKELL__ >= 804 instance Semigroup FailureCount where- (<>) = mappend+ FailureCount s1 i1 <> FailureCount s2 i2 = FailureCount (s1+s2) (i1+i2) #endif instance Monoid FailureCount where mempty = FailureCount 0 0+#if __GLASGOW_HASKELL__ < 804 mappend (FailureCount s1 i1) (FailureCount s2 i2) = FailureCount (s1+s2) (i1+i2)+#endif wrapFetchInStats :: DataSource u req@@ -490,7 +569,8 @@ SyncFetch $ \reqs -> do bid <- newBatchId fail_ref <- newIORef mempty- (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref) reqs))+ (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref)+ (reqsWithFetchDsStats bid reqs))) failures <- readIORef fail_ref updateFetchStats bid allFids t0 t alloc batchSize failures AsyncFetch f -> do@@ -502,7 +582,8 @@ (_,t,alloc,_) <- statsForIO inner writeIORef inner_r (t,alloc) reqs' = map (addFailureCount u fail_ref) reqs- (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs' inner')+ reqs'' = reqsWithFetchDsStats bid reqs'+ (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs'' inner') (innerTime, innerAlloc) <- readIORef inner_r failures <- readIORef fail_ref updateFetchStats bid allFids t0 (totalTime - innerTime)@@ -511,7 +592,8 @@ BackgroundFetch $ \reqs -> do bid <- newBatchId startTime <- getTimestamp- io (zipWith (addTimer u bid startTime) reqs reqsI)+ io (reqsWithFetchDsStats bid+ (zipWith (addTimer u bid startTime) reqs reqsI)) where allFids = map (\(BlockedFetchInternal k) -> k) reqsI newBatchId = atomicModifyIORef' batchIdRef $ \x -> (x+1,x+1)@@ -520,20 +602,15 @@ (t0,t,a) <- time io postAlloc <- getAllocationCounter return (t0,t, fromIntegral $ prevAlloc - postAlloc, a)-- calcFailure _u _r (Right _) = mempty- calcFailure u r (Left e) = case classifyFailure u r e of- StandardFailure -> mempty { failureCountStandard = 1 }- IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }--+ reqsWithFetchDsStats = \bid reqs+ -> zipWith (addFetchDatasourceStats bid) reqs reqsI addTimer u bid t0 (BlockedFetch req (ResultVar fn)) (BlockedFetchInternal fid) =- BlockedFetch req $ ResultVar $ \result isChildThread -> do+ BlockedFetch req $ ResultVar $ \result isChildThread stats -> do t1 <- getTimestamp -- We cannot measure allocation easily for BackgroundFetch. Here we -- just attribute all allocation to the last@@ -546,8 +623,30 @@ (negate allocs) 1 -- batch size: we don't know if this is a batch or not (calcFailure u req result) -- failures- fn result isChildThread+ fn result isChildThread stats + addFetchDatasourceStats+ :: Int+ -> BlockedFetch r+ -> BlockedFetchInternal+ -> BlockedFetch r+ addFetchDatasourceStats bid+ (BlockedFetch req (ResultVar fn))+ (BlockedFetchInternal fid) = BlockedFetch req $ ResultVar+ $ \result isChildThread stats -> do+ let mkStats dss = FetchDataSourceStats+ { fetchDsStatsCallId = fid+ , fetchDsStatsDataSource = dataSource+ , fetchDsStatsStats = dss+ , fetchBatchId = bid+ }+ case stats of+ Just dss -> atomicModifyIORef' statsRef+ $ \(Stats fs) -> (Stats (mkStats dss : fs), ())+ Nothing -> return ()+ fn result isChildThread stats++ updateFetchStats :: Int -> [CallId]@@ -572,10 +671,10 @@ addFailureCount :: DataSource u r => u -> IORef FailureCount -> BlockedFetch r -> BlockedFetch r addFailureCount u ref (BlockedFetch req (ResultVar fn)) =- BlockedFetch req $ ResultVar $ \result isChildThread -> do+ BlockedFetch req $ ResultVar $ \result isChildThread stats -> do let addFailures r = (r <> calcFailure u req result, ()) when (isLeft result) $ atomicModifyIORef' ref addFailures- fn result isChildThread+ fn result isChildThread stats wrapFetchInTrace :: Int@@ -612,7 +711,7 @@ scheduleFetches :: [FetchToDo] -> IORef ReqCountMap -> Flags -> IO () scheduleFetches fetches ref flags = do -- update ReqCountmap for these fetches- ifReport flags 1 $ sequence_+ ifReport flags ReportOutgoneFetches $ sequence_ [ atomicModifyIORef' ref $ \m -> (addToCountMap (Proxy :: Proxy r) (length reqs) m, ()) | FetchToDo (reqs :: [BlockedFetch r]) _f <- fetches
Haxl/Core/Flags.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE BangPatterns #-}+ -- | -- The 'Flags' type and related functions. This module is provided -- for access to Haxl internals only; most users should import@@ -11,8 +15,16 @@ -- module Haxl.Core.Flags (- -- * Tracing flags- Flags(..)+ -- * Report flags+ ReportFlag(..)+ , ReportFlags+ , defaultReportFlags+ , profilingReportFlags+ , setReportFlag+ , clearReportFlag+ , testReportFlag+ -- * Flags+ , Flags(..) , defaultFlags , ifTrace , ifReport@@ -20,22 +32,72 @@ ) where import Control.Monad+import Data.Bits+import Data.List (foldl')+import Text.Printf (printf) -- ---------------------------------------------------------------------------+-- ReportFlags+data ReportFlag+ = ReportOutgoneFetches -- ^ outgone fetches, for debugging eg: timeouts+ | ReportFetchStats -- ^ data fetch stats & errors+ | ReportProfiling -- ^ enabling label stack and profiling+ | ReportExceptionLabelStack -- ^ include label stack in HaxlException+ | ReportFetchStack -- ^ log cost-center stack traces of dataFetch calls+ deriving (Bounded, Enum, Eq, Show)++profilingDependents :: [ReportFlag]+profilingDependents =+ [ ReportExceptionLabelStack+ , ReportFetchStack+ ]++newtype ReportFlags = ReportFlags Int++instance Show ReportFlags where+ show (ReportFlags fs) = printf "%0*b" (fromEnum maxReportFlag + 1) fs+ where+ maxReportFlag = maxBound :: ReportFlag++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags 0++profilingReportFlags :: ReportFlags+profilingReportFlags = foldl' (flip setReportFlag) defaultReportFlags+ [ ReportOutgoneFetches+ , ReportFetchStats+ , ReportProfiling+ ]++setReportFlag :: ReportFlag -> ReportFlags -> ReportFlags+setReportFlag f (ReportFlags fs) =+ ReportFlags $ setDependencies $ setBit fs $ fromEnum f+ where+ setDependencies+ | f `elem` profilingDependents = flip setBit $ fromEnum ReportProfiling+ | otherwise = id++clearReportFlag :: ReportFlag -> ReportFlags -> ReportFlags+clearReportFlag f (ReportFlags fs) =+ ReportFlags $ clearDependents $ clearBit fs $ fromEnum f+ where+ clearDependents z = case f of+ ReportProfiling -> foldl' clearBit z $ map fromEnum profilingDependents+ _ -> z++{-# INLINE testReportFlag #-}+testReportFlag :: ReportFlag -> ReportFlags -> Bool+testReportFlag !f (ReportFlags !fs) = testBit fs $ fromEnum f++-- --------------------------------------------------------------------------- -- Flags -- | Flags that control the operation of the engine. data Flags = Flags { trace :: {-# UNPACK #-} !Int -- ^ Tracing level (0 = quiet, 3 = very verbose).- , report :: {-# UNPACK #-} !Int- -- ^ Report level:- -- * 0 = quiet- -- * 1 = outgone fetches, for debugging eg: timeouts- -- * 2 = data fetch stats & errors- -- * 3 = (same as 2, this used to enable errors)- -- * 4 = profiling- -- * 5 = log stack traces of dataFetch calls+ , report :: {-# UNPACK #-} !ReportFlags+ -- ^ Report flags , caching :: {-# UNPACK #-} !Int -- ^ Non-zero if caching is enabled. If caching is disabled, then -- we still do batching and de-duplication, but do not cache@@ -48,7 +110,7 @@ defaultFlags :: Flags defaultFlags = Flags { trace = 0- , report = 0+ , report = defaultReportFlags , caching = 1 , recording = 0 }@@ -57,9 +119,9 @@ ifTrace :: Monad m => 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 :: Monad m => Flags -> Int -> m a -> m ()-ifReport flags i = when (report flags >= i) . void+-- | Runs an action if the ReportFlag is set.+ifReport :: Monad m => Flags -> ReportFlag -> m a -> m ()+ifReport flags i = when (testReportFlag i $ report flags) . void ifProfiling :: Monad m => Flags -> m a -> m ()-ifProfiling flags = when (report flags >= 4) . void+ifProfiling flags = ifReport flags ReportProfiling
Haxl/Core/Memo.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}@@ -71,7 +73,8 @@ :: forall req u w a. ( Eq (req a) , Hashable (req a)- , Typeable (req a))+ , Typeable (req a)+ , Monoid w) => req a -> GenHaxl u w a -> GenHaxl u w a cachedComputation req haxl = GenHaxl $ \env@Env{..} -> do@@ -101,7 +104,8 @@ :: forall req u w a. ( Eq (req a) , Hashable (req a)- , Typeable (req a))+ , Typeable (req a)+ , Monoid w) => req a -> GenHaxl u w a -> GenHaxl u w a preCacheComputation req haxl = GenHaxl $ \env@Env{..} -> do mbRes <- DataCache.lookup req memoCache@@ -196,13 +200,13 @@ -- > b <- g -- > return (a + b) ---runMemo :: MemoVar u w a -> GenHaxl u w a+runMemo :: Monoid w => MemoVar u w a -> GenHaxl u w a runMemo (MemoVar memoRef) = GenHaxl $ \env -> do stored <- readIORef memoRef case stored of -- Memo was not prepared first; throw an exception. MemoEmpty -> trace_ "MemoEmpty " $- raise $ CriticalError "Attempting to run empty memo."+ raise env $ CriticalError "Attempting to run empty memo." -- Memo has been prepared but not run yet MemoReady cont k -> trace_ "MemoReady" $ do ivar <- newIVar@@ -215,12 +219,14 @@ unHaxl (getIVarWithWrites ivar) env execMemoNowProfiled- :: Env u w+ :: Monoid w+ => Env u w -> GenHaxl u w a -> IVar u w a -> CallId -> IO (Result u w a)-execMemoNowProfiled envOuter cont ivar cid = if report (flags envOuter) < 4+execMemoNowProfiled envOuter cont ivar cid =+ if not $ testReportFlag ReportProfiling $ report $ flags envOuter then execMemoNow envOuter cont ivar else do incrementMemoHitCounterFor envOuter cid False@@ -245,9 +251,9 @@ setAllocationCounter a1 return ret -execMemoNow :: Env u w -> GenHaxl u w a -> IVar u w a -> IO (Result u w a)+execMemoNow :: Monoid w => Env u w -> GenHaxl u w a -> IVar u w a -> IO (Result u w a) execMemoNow env cont ivar = do- wlogs <- newIORef NilWrites+ wlogs <- newIORef mempty let !menv = env { writeLogsRef = wlogs } -- use an env with empty writes, so we can memoize the extra@@ -261,13 +267,13 @@ throwIO e Right (Done a) -> trace_ "execMemoNow: Done" $ do wt <- readIORef wlogs- putIVar ivar (Ok a wt) env- mbModifyWLRef wt (writeLogsRef env)+ putIVar ivar (Ok a (Just wt)) env+ modifyIORef' (writeLogsRef env) (<> wt) return (Done a) Right (Throw ex) -> trace_ ("execMemoNow: Throw" ++ show ex) $ do wt <- readIORef wlogs- putIVar ivar (ThrowHaxl ex wt) env- mbModifyWLRef wt (writeLogsRef env)+ putIVar ivar (ThrowHaxl ex (Just wt)) env+ modifyIORef' (writeLogsRef env) (<> wt) return (Throw ex) Right (Blocked ivar' cont) -> trace_ "execMemoNow: Blocked" $ do -- We "block" this memoized computation in the new environment 'menv', so@@ -304,7 +310,7 @@ prepareMemo1 (MemoVar1 r) f = unsafeLiftIO $ writeIORef r (MemoTbl1 f HashMap.empty) -runMemo1 :: (Eq a, Hashable a) => MemoVar1 u w a b -> a -> GenHaxl u w b+runMemo1 :: (Eq a, Hashable a, Monoid w) => MemoVar1 u w a b -> a -> GenHaxl u w b runMemo1 (MemoVar1 r) k = unsafeLiftIO (readIORef r) >>= \case MemoEmpty1 -> throw $ CriticalError "Attempting to run empty memo." MemoTbl1 f h -> case HashMap.lookup k h of@@ -324,7 +330,7 @@ prepareMemo2 (MemoVar2 r) f = unsafeLiftIO $ writeIORef r (MemoTbl2 f HashMap.empty) -runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b)+runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b, Monoid w) => MemoVar2 u w a b c -> a -> b -> GenHaxl u w c runMemo2 (MemoVar2 r) k1 k2 = unsafeLiftIO (readIORef r) >>= \case@@ -352,12 +358,12 @@ -- every two calls @memo key haxl@, if they have the same @key@ then -- they compute the same result. memo- :: (Typeable a, Typeable k, Hashable k, Eq k)+ :: (Typeable a, Typeable k, Hashable k, Eq k, Monoid w) => k -> GenHaxl u w a -> GenHaxl u w a memo key = cachedComputation (MemoKey key) {-# RULES-"memo/Text" memo = memoText :: (Typeable a) =>+"memo/Text" memo = memoText :: (Typeable a, Monoid w) => Text -> GenHaxl u w a -> GenHaxl u w a #-} @@ -366,7 +372,7 @@ -- | Memoize a computation using its location and a Fingerprint. This ensures -- uniqueness across computations. memoUnique- :: (Typeable a, Typeable k, Hashable k, Eq k)+ :: (Typeable a, Typeable k, Hashable k, Eq k, Monoid w) => MemoFingerprintKey a -> Text -> k -> GenHaxl u w a -> GenHaxl u w a memoUnique fp label key = withLabel label . memo (fp, key) @@ -393,7 +399,7 @@ instance Hashable (MemoTextKey a) where hashWithSalt s (MemoText t) = hashWithSalt s t -memoText :: (Typeable a) => Text -> GenHaxl u w a -> GenHaxl u w a+memoText :: (Typeable a, Monoid w) => Text -> GenHaxl u w a -> GenHaxl u w a memoText key = withLabel key . cachedComputation (MemoText key) -- | A memo key derived from a 128-bit MD5 hash. Do not use this directly,@@ -423,7 +429,7 @@ -- {-# NOINLINE memoFingerprint #-} memoFingerprint- :: Typeable a => MemoFingerprintKey a -> GenHaxl u w a -> GenHaxl u w a+ :: (Typeable a, Monoid w) => MemoFingerprintKey a -> GenHaxl u w a -> GenHaxl u w a memoFingerprint key@(MemoFingerprintKey _ _ mnPtr nPtr) = withFingerprintLabel mnPtr nPtr . cachedComputation key @@ -435,7 +441,7 @@ -- 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 w a -> GenHaxl u w (GenHaxl u w a)+memoize :: Monoid w => GenHaxl u w a -> GenHaxl u w (GenHaxl u w a) memoize a = runMemo <$> newMemoWith a -- | Transform a 1-argument function returning a Haxl computation into a@@ -454,7 +460,7 @@ -- -- The above implementation will not invoke the underlying @friendsOf@ -- repeatedly for duplicate values in @ids@.-memoize1 :: (Eq a, Hashable a)+memoize1 :: (Eq a, Hashable a, Monoid w) => (a -> GenHaxl u w b) -> GenHaxl u w (a -> GenHaxl u w b) memoize1 f = runMemo1 <$> newMemoWith1 f@@ -463,7 +469,7 @@ -- memoized version of itself. -- -- The 2-ary version of @memoize1@, see its documentation for details.-memoize2 :: (Eq a, Hashable a, Eq b, Hashable b)+memoize2 :: (Eq a, Hashable a, Eq b, Hashable b, Monoid w) => (a -> b -> GenHaxl u w c) -> GenHaxl u w (a -> b -> GenHaxl u w c) memoize2 f = runMemo2 <$> newMemoWith2 f
Haxl/Core/Monad.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {- TODO - do EVENTLOG stuff, track the data fetch numbers for performFetch@@ -48,6 +50,8 @@ , flattenWT , appendWTs , mbModifyWLRef+ , mapWrites+ , mapWriteTree -- * Cont , Cont(..)@@ -75,6 +79,8 @@ -- * Env , Env(..) , DataCacheItem(..)+ , DataCacheLookup(..)+ , HaxlDataCache , Caches , caches , initEnvWithData@@ -125,7 +131,6 @@ import Control.Applicative (liftA2) 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) #if __GLASGOW_HASKELL__ >= 808@@ -135,12 +140,17 @@ import Control.Monad #endif import qualified Control.Exception as Exception+import Data.Either (rights) import Data.IORef import Data.Int-import Data.Either (rights)+import Data.Maybe+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif+import qualified Data.Text as Text+import Data.Typeable import GHC.Exts (IsString(..)) import Text.PrettyPrint hiding ((<>)) import Text.Printf@@ -152,7 +162,6 @@ #ifdef PROFILING import qualified Data.Map as Map import Data.Text (Text)-import Data.Typeable import Foreign.Ptr (Ptr) import GHC.Stack import Haxl.Core.CallGraph@@ -164,12 +173,18 @@ -- | The data we carry around in the Haxl monad. data DataCacheItem u w a = DataCacheItem (IVar u w a) {-# UNPACK #-} !CallId+type HaxlDataCache u w = DataCache (DataCacheItem u w)+newtype DataCacheLookup w =+ DataCacheLookup+ (forall req a . Typeable (req a)+ => req a+ -> IO (Maybe (ResultVal a w))) data Env u w = Env- { dataCache :: {-# UNPACK #-} !(DataCache (DataCacheItem u w))+ { dataCache :: {-# UNPACK #-} !(HaxlDataCache u w) -- ^ cached data fetches - , memoCache :: {-# UNPACK #-} !(DataCache (DataCacheItem u w))+ , memoCache :: {-# UNPACK #-} !(HaxlDataCache u w) -- ^ memoized computations , memoKey :: {-# UNPACK #-} !CallId@@ -224,15 +239,20 @@ -- become non-empty is how the scheduler blocks waiting for -- data fetches to return. - , writeLogsRef :: {-# UNPACK #-} !(IORef (WriteTree w))+ , writeLogsRef :: {-# UNPACK #-} !(IORef w) -- ^ A log of all writes done as part of this haxl computation. Any -- haxl computation that needs to be memoized runs in its own -- environment so that we can get a hold of those writes and put them -- in the IVar associated with the compuatation.- , writeLogsRefNoMemo :: {-# UNPACK #-} !(IORef (WriteTree w))+ , writeLogsRefNoMemo :: {-# UNPACK #-} !(IORef w) -- ^ This is just a specialized version of @writeLogsRef@, where we put -- logs that user doesn't want memoized. This is a better alternative to -- doing arbitrary IO from a (memoized) Haxl computation.++ , dataCacheFetchFallback :: !(Maybe (DataCacheLookup w))+ -- ^ Allows you to inject a DataCache lookup just before a dataFetch is+ -- dispatched. This is useful for injecting fetch results in testing.+ #ifdef PROFILING , callGraphRef :: Maybe (IORef CallGraph) -- ^ An edge list representing the current function call graph. The type@@ -245,15 +265,15 @@ data ProfileCurrent = ProfileCurrent { profCurrentKey :: {-# UNPACK #-} !ProfileKey- , profCurrentLabel :: {-# UNPACK #-} !ProfileLabel+ , profLabelStack :: {-# UNPACK #-} !(NonEmpty ProfileLabel) } -type Caches u w = (DataCache (DataCacheItem u w), DataCache (DataCacheItem u w))+type Caches u w = (HaxlDataCache u w, HaxlDataCache u w) caches :: Env u w -> Caches u w caches env = (dataCache env, memoCache env) -getMaxCallId :: DataCache (DataCacheItem u w) -> IO (Maybe Int)+getMaxCallId :: HaxlDataCache u w -> IO (Maybe Int) getMaxCallId c = do callIds <- rights . concatMap snd <$> DataCache.readCache c (\(DataCacheItem _ i) -> return i)@@ -264,7 +284,7 @@ -- | 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 w -> IO (Env u w)+initEnvWithData :: Monoid w => StateStore -> u -> Caches u w -> IO (Env u w) initEnvWithData states e (dcache, mcache) = do newCid <- max <$> (maybe 0 ((+) 1) <$> getMaxCallId dcache) <*>@@ -277,8 +297,8 @@ rq <- newIORef JobNil -- RunQueue sr <- newIORef emptyReqCounts -- SubmittedReqs comps <- newTVarIO [] -- completion queue- wl <- newIORef NilWrites- wlnm <- newIORef NilWrites+ wl <- newIORef mempty+ wlnm <- newIORef mempty return Env { dataCache = dcache , memoCache = mcache@@ -288,7 +308,7 @@ , states = states , statsRef = sref , statsBatchIdRef = sbref- , profCurrent = ProfileCurrent 0 "MAIN"+ , profCurrent = ProfileCurrent 0 $ "MAIN" :| [] , callIdRef = ciref , profRef = pref , reqStoreRef = rs@@ -297,6 +317,7 @@ , completions = comps , writeLogsRef = wl , writeLogsRefNoMemo = wlnm+ , dataCacheFetchFallback = Nothing #ifdef PROFILING , callGraphRef = Nothing , currFunction = mainFunction@@ -304,14 +325,14 @@ } -- | Initializes an environment with 'StateStore' and an input map.-initEnv :: StateStore -> u -> IO (Env u w)+initEnv :: Monoid w => StateStore -> u -> IO (Env u w) initEnv states e = do dcache <- emptyDataCache mcache <- emptyDataCache initEnvWithData states e (dcache, mcache) -- | A new, empty environment.-emptyEnv :: u -> IO (Env u w)+emptyEnv :: Monoid w => u -> IO (Env u w) emptyEnv = initEnv stateEmpty -- | If you're using the env from a failed Haxl computation in a second Haxl@@ -359,6 +380,12 @@ | MergeWrites (WriteTree w) (WriteTree w) deriving (Show) +instance Semigroup (WriteTree w) where+ (<>) = appendWTs++instance Monoid (WriteTree w) where+ mempty = NilWrites+ appendWTs :: WriteTree w -> WriteTree w -> WriteTree w appendWTs NilWrites w = w appendWTs w NilWrites = w@@ -380,6 +407,12 @@ mbModifyWLRef NilWrites _ = return () mbModifyWLRef !wt ref = modifyIORef' ref (`appendWTs` wt) +mapWriteTree :: (w -> w) -> WriteTree w -> WriteTree w+mapWriteTree _ NilWrites = NilWrites+mapWriteTree f (SomeWrite w) = SomeWrite (f w)+mapWriteTree f (MergeWrites wt1 wt2) =+ MergeWrites (mapWriteTree f wt1) (mapWriteTree f wt2)+ -- ----------------------------------------------------------------------------- -- | The Haxl monad, which does several things: --@@ -408,20 +441,20 @@ newtype GenHaxl u w a = GenHaxl { unHaxl :: Env u w -> IO (Result u w a) } -tellWrite :: w -> GenHaxl u w ()+tellWrite :: w -> GenHaxl u (WriteTree w) () tellWrite = write . SomeWrite -write :: WriteTree w -> GenHaxl u w ()+write :: Monoid w => w -> GenHaxl u w () write wt = GenHaxl $ \Env{..} -> do- mbModifyWLRef wt writeLogsRef+ modifyIORef' writeLogsRef (<> wt) return $ Done () -tellWriteNoMemo :: w -> GenHaxl u w ()+tellWriteNoMemo :: w -> GenHaxl u (WriteTree w) () tellWriteNoMemo = writeNoMemo . SomeWrite -writeNoMemo :: WriteTree w -> GenHaxl u w ()+writeNoMemo :: Monoid w => w -> GenHaxl u w () writeNoMemo wt = GenHaxl $ \Env{..} -> do- mbModifyWLRef wt writeLogsRefNoMemo+ modifyIORef' writeLogsRefNoMemo (<> wt) return $ Done () @@ -514,36 +547,36 @@ #endif getIVar :: IVar u w a -> GenHaxl u w a-getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \Env{..} -> do+getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \env -> do e <- readIORef ref case e of IVarFull (Ok a _wt) -> return (Done a)- IVarFull (ThrowHaxl e _wt) -> raiseFromIVar i e+ IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e IVarFull (ThrowIO e) -> throwIO e IVarEmpty _ -> return (Blocked i (Return i)) -- Just a specialised version of getIVar, for efficiency in <*> getIVarApply :: IVar u w (a -> b) -> a -> GenHaxl u w b-getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \Env{..} -> do+getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \env -> do e <- readIORef ref case e of IVarFull (Ok f _wt) -> return (Done (f a))- IVarFull (ThrowHaxl e _wt) -> raiseFromIVar i e+ IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e IVarFull (ThrowIO e) -> throwIO e IVarEmpty _ -> return (Blocked i (Cont (getIVarApply i a))) -- Another specialised version of getIVar, for efficiency in cachedComputation-getIVarWithWrites :: IVar u w a -> GenHaxl u w a-getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \Env{..} -> do+getIVarWithWrites :: Monoid w => IVar u w a -> GenHaxl u w a+getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \env@Env{..} -> do e <- readIORef ref case e of IVarFull (Ok a wt) -> do- mbModifyWLRef wt writeLogsRef+ modifyIORef' writeLogsRef (<> fromMaybe mempty wt) return (Done a) IVarFull (ThrowHaxl e wt) -> do- mbModifyWLRef wt writeLogsRef- raiseFromIVar i e+ modifyIORef' writeLogsRef (<> fromMaybe mempty wt)+ raiseFromIVar env i e IVarFull (ThrowIO e) -> throwIO e IVarEmpty _ -> return (Blocked i (Cont (getIVarWithWrites i)))@@ -581,25 +614,25 @@ -- that when the result is fetched using getIVar, we can throw the -- exception in the right way. data ResultVal a w- = Ok a (WriteTree w)- | ThrowHaxl SomeException (WriteTree w)+ = Ok a (Maybe w)+ | ThrowHaxl SomeException (Maybe w) | ThrowIO SomeException -- we get no write logs when an IO exception occurs -done :: ResultVal a w -> IO (Result u w a)-done (Ok a _) = return (Done a)-done (ThrowHaxl e _) = raise e-done (ThrowIO e) = throwIO e+done :: Env u w -> ResultVal a w -> IO (Result u w a)+done _ (Ok a _) = return (Done a)+done env (ThrowHaxl e _) = raise env e+done _ (ThrowIO e) = throwIO e eitherToResultThrowIO :: Either SomeException a -> ResultVal a w-eitherToResultThrowIO (Right a) = Ok a NilWrites+eitherToResultThrowIO (Right a) = Ok a Nothing eitherToResultThrowIO (Left e)- | Just HaxlException{} <- fromException e = ThrowHaxl e NilWrites+ | Just HaxlException{} <- fromException e = ThrowHaxl e Nothing | otherwise = ThrowIO e eitherToResult :: Either SomeException a -> ResultVal a w-eitherToResult (Right a) = Ok a NilWrites-eitherToResult (Left e) = ThrowHaxl e NilWrites+eitherToResult (Right a) = Ok a Nothing+eitherToResult (Left e) = ThrowHaxl e Nothing -- -----------------------------------------------------------------------------@@ -612,7 +645,7 @@ -- the relevant computations. data CompleteReq u w = forall a . CompleteReq- (Either SomeException a)+ (ResultVal a w) !(IVar u w a) -- IVar because the result is cached {-# UNPACK #-} !Int64 -- see Note [tracking allocation in child threads] @@ -675,6 +708,11 @@ show (Throw e) = printf "Throw(%s)" $ show e show Blocked{} = "Blocked" +instance Functor (Result u w) where+ fmap f (Done a) = Done (f a)+ fmap _ (Throw exc) = Throw exc+ fmap f (Blocked ivar cont) = Blocked ivar (f :<$> cont)+ {- Note [Exception] How do we want to represent Haxl exceptions (those that are thrown by@@ -752,7 +790,7 @@ -- Monad/Applicative instances instance Monad (GenHaxl u w) where- return a = GenHaxl $ \_env -> return (Done a)+ return = pure GenHaxl m >>= k = GenHaxl $ \env -> do e <- m env case e of@@ -780,7 +818,7 @@ return (Blocked ivar (f :<$> cont)) instance Applicative (GenHaxl u w) where- pure = return+ pure a = GenHaxl $ \_env -> pure (Done a) GenHaxl ff <*> GenHaxl aa = GenHaxl $ \env -> do rf <- ff env case rf of@@ -808,7 +846,9 @@ instance Monoid a => Monoid (GenHaxl u w a) where mempty = pure mempty+#if __GLASGOW_HASKELL__ < 804 mappend = liftA2 mappend+#endif blockedBlocked :: Env u w@@ -874,6 +914,36 @@ nextCallId :: Env u w -> IO CallId nextCallId env = atomicModifyIORef' (callIdRef env) $ \x -> (x+1,x+1) +-- | Runs the Haxl computation, transforming the writes within using the+-- provided function.+--+-- Memoization behavior is unchanged, meaning if a memoized computation is run+-- once inside @mapWrites@ and then once without, the writes from the second run+-- will NOT be transformed.+mapWrites :: Monoid w => (w -> w) -> GenHaxl u w a -> GenHaxl u w a+mapWrites f action = GenHaxl $ \curEnv -> do+ wlogs <- newIORef mempty+ wlogsNoMemo <- newIORef mempty+ let+ !newEnv = curEnv { writeLogsRef = wlogs, writeLogsRefNoMemo = wlogsNoMemo }+ unHaxl (mapWritesImpl curEnv newEnv action) newEnv+ where+ mapWritesImpl oldEnv curEnv (GenHaxl m) = GenHaxl $ \_ -> do+ let+ pushTransformedWrites = do+ wt <- readIORef $ writeLogsRef curEnv+ modifyIORef' (writeLogsRef oldEnv) (<> f wt)+ wtNoMemo <- readIORef $ writeLogsRefNoMemo curEnv+ modifyIORef' (writeLogsRefNoMemo oldEnv) (<> f wtNoMemo)++ r <- m curEnv++ case r of+ Done a -> pushTransformedWrites >> return (Done a)+ Throw e -> pushTransformedWrites >> return (Throw e)+ Blocked ivar k -> return+ (Blocked ivar (Cont (mapWritesImpl oldEnv curEnv (toHaxl k))))+ #ifdef PROFILING -- ----------------------------------------------------------------------------- -- CallGraph recording@@ -909,34 +979,42 @@ -- Exceptions -- | Throw an exception in the Haxl monad-throw :: (Exception e) => e -> GenHaxl u w a-throw e = GenHaxl $ \_env -> raise e+throw :: Exception e => e -> GenHaxl u w a+throw e = GenHaxl $ \env -> raise env e -raise :: (Exception e) => e -> IO (Result u w a)-raise e+raise :: Exception e => Env u w -> e -> IO (Result u w a)+raise env e = raiseImpl env (toException e) #ifdef PROFILING- | Just (HaxlException Nothing h) <- fromException somex = do- stk <- currentCallStack- return (Throw (toException (HaxlException (Just stk) h)))- | otherwise+ currentCallStack #endif- = return (Throw somex)- where- somex = toException e -raiseFromIVar :: Exception e => IVar u w a -> e -> IO (Result u w b)++raiseFromIVar :: Exception e => Env u w -> IVar u w a -> e -> IO (Result u w b) #ifdef PROFILING-raiseFromIVar ivar e- | Just (HaxlException Nothing h) <- fromException somex = do- stk <- ccsToStrings (ivarCCS ivar)- return (Throw (toException (HaxlException (Just stk) h)))- | otherwise+raiseFromIVar env IVar{..} e =+ raiseImpl env (toException e) (ccsToStrings ivarCCS) #else-raiseFromIVar _ivar e+raiseFromIVar env _ivar e = raiseImpl env (toException e) #endif- = return (Throw somex)- where- somex = toException e++{-# INLINE raiseImpl #-}+#ifdef PROFILING+raiseImpl :: Env u w -> SomeException -> IO [String] -> IO (Result u w b)+raiseImpl Env{..} e getCostCentreStack+#else+raiseImpl :: Env u w -> SomeException -> IO (Result u w b)+raiseImpl Env{..} e+#endif+ | testReportFlag ReportExceptionLabelStack $ report flags+ , Just (HaxlException Nothing h) <- fromException e = do+ let stk = NonEmpty.toList $ profLabelStack profCurrent+ return $ Throw $ toException $ HaxlException (Just stk) h+#ifdef PROFILING+ | Just (HaxlException Nothing h) <- fromException e = do+ stk <- reverse . map Text.pack <$> getCostCentreStack+ return $ Throw $ toException $ HaxlException (Just stk) h+#endif+ | otherwise = return $ Throw e -- | Catch an exception in the Haxl monad catch :: Exception e => GenHaxl u w a -> (e -> GenHaxl u w a) -> GenHaxl u w a
Haxl/Core/Parallel.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}@@ -47,7 +49,7 @@ -> GenHaxl u w r -> GenHaxl u w t biselect_opt discrimA discrimB left right haxla haxlb =- let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env@Env{..} -> do+ let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env -> do ra <- haxla env case ra of Done ea ->
Haxl/Core/Profile.hs view
@@ -1,9 +1,12 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}@@ -25,6 +28,7 @@ import Data.IORef import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..), (<|)) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -43,7 +47,7 @@ -- | Label a computation so profiling data is attributed to the label. withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a withLabel l (GenHaxl m) = GenHaxl $ \env ->- if report (flags env) < 4+ if not $ testReportFlag ReportProfiling $ report $ flags env then m env else collectProfileData l m env @@ -51,7 +55,7 @@ -- Intended only for internal use by 'memoFingerprint'. withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->- if report (flags env) < 4+ if not $ testReportFlag ReportProfiling $ report $ flags env then m env else collectProfileData (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)@@ -64,7 +68,7 @@ -> Env u w -> IO (Result u w a) collectProfileData l m env = do- let (ProfileCurrent prevProfKey prevProfLabel) = profCurrent env+ let ProfileCurrent prevProfKey (prevProfLabel :| _) = profCurrent env if prevProfLabel == l then -- do not add a new label if we are recursing@@ -93,12 +97,22 @@ t0 <- getTimestamp a0 <- getAllocationCounter let+ ProfileCurrent caller stack = profCurrent env nextCurrent = ProfileCurrent- { profCurrentKey = key- , profCurrentLabel = l }- caller = profCurrentKey (profCurrent env)+ { profCurrentKey = key+ , profLabelStack = l <| stack+ }+ runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True r <- m env{profCurrent=nextCurrent} -- what if it throws?++ -- Make the result strict in Done/Throw so that if the user code+ -- returns (force a), the force is evaluated *inside* the profile.+ result <- case r of+ Done !a -> return (Done a)+ Throw !e -> return (Throw e)+ Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k)))+ a1 <- getAllocationCounter t1 <- getTimestamp @@ -111,12 +125,7 @@ -- 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 $ runCont (toHaxl k)))- where- runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True+ return result {-# INLINE runProfileData #-} modifyProfileData@@ -180,7 +189,7 @@ t1 <- getTimestamp let allocs = a0 - a1- t = t0 - t1+ t = t1 - t0 newEntry = emptyProfileData { profileAllocs = allocs , profileTime = t
Haxl/Core/RequestStore.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -44,6 +46,7 @@ import qualified Data.Map.Strict as Map import Data.Proxy import Data.Text (Text)+import Data.Kind (Type) import Data.Typeable import Unsafe.Coerce @@ -110,7 +113,7 @@ emptyReqCounts = ReqCountMap Map.empty addToCountMap- :: forall (r :: * -> *). (DataSourceName r, Typeable r)+ :: forall (r :: Type -> Type). (DataSourceName r, Typeable r) => Proxy r -> Int -- type and number of requests -> ReqCountMap@@ -118,7 +121,7 @@ addToCountMap = updateCountMap (+) subFromCountMap- :: forall (r :: * -> *). (DataSourceName r, Typeable r)+ :: forall (r :: Type -> Type). (DataSourceName r, Typeable r) => Proxy r -> Int -- type and number of requests -> ReqCountMap@@ -126,7 +129,7 @@ subFromCountMap = updateCountMap (-) updateCountMap- :: forall (r :: * -> *). (DataSourceName r, Typeable r)+ :: forall (r :: Type -> Type). (DataSourceName r, Typeable r) => (Int -> Int -> Int) -> Proxy r -> Int -- type and number of requests
Haxl/Core/Run.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -22,6 +24,7 @@ import Control.Exception as Exception import Control.Monad import Data.IORef+import Data.Maybe import Text.Printf import Unsafe.Coerce @@ -49,10 +52,10 @@ -- -- However, multiple 'Env's may share a single 'StateStore', and thereby -- use the same set of datasources.-runHaxl:: forall u w a. Env u w -> GenHaxl u w a -> IO a+runHaxl:: forall u w a. Monoid w => Env u w -> GenHaxl u w a -> IO a runHaxl env haxl = fst <$> runHaxlWithWrites env haxl -runHaxlWithWrites :: forall u w a. Env u w -> GenHaxl u w a -> IO (a, [w])+runHaxlWithWrites :: forall u w a. Monoid w => Env u w -> GenHaxl u w a -> IO (a, w) runHaxlWithWrites env@Env{..} haxl = do result@IVar{ivarRef = resultRef} <- newIVar -- where to put the final result ifTraceLog <- do@@ -96,7 +99,7 @@ _ -> modifyIORef' runQueueRef (appendJobList rq) else reschedule env (appendJobList haxls rq) r <-- if report flags >= 4 -- withLabel unfolded+ if testReportFlag ReportProfiling $ report flags -- withLabel unfolded then Exception.try $ profileCont run env else Exception.try $ run env case r of@@ -105,10 +108,10 @@ result (ThrowIO e) Right (Done a) -> do wt <- readIORef writeLogsRef- result (Ok a wt)+ result $ Ok a (Just wt) Right (Throw ex) -> do wt <- readIORef writeLogsRef- result (ThrowHaxl ex wt)+ result $ ThrowHaxl ex (Just wt) Right (Blocked i fn) -> do addJob env (toHaxl fn) ivar i reschedule env rq@@ -142,7 +145,7 @@ schedule env' c a b emptyRunQueue :: Env u w -> IO ()- emptyRunQueue env@Env{..} = do+ emptyRunQueue env = do ifTraceLog $ printf "emptyRunQueue\n" haxls <- checkCompletions env case haxls of@@ -195,7 +198,7 @@ -- pushed on the front of the completions list) and -- therefore overrides it. IVarEmpty cv -> do- writeIORef cr (IVarFull (eitherToResult a))+ writeIORef cr (IVarFull a) return cv jobs <- mapM getComplete comps return (foldr appendJobList JobNil jobs)@@ -229,7 +232,7 @@ , fetchWaitDuration = (end-start) } modifyIORef' statsRef $ \(Stats s) -> Stats (fw:s)- if report flags >= 2+ if testReportFlag ReportFetchStats $ report flags then doWaitProfiled else doWait emptyRunQueue env@@ -237,11 +240,13 @@ -- schedule env JobNil haxl result r <- readIORef resultRef+ writeIORef writeLogsRef mempty+ wtNoMemo <- atomicModifyIORef' writeLogsRefNoMemo+ (\old_wrts -> (mempty, old_wrts)) case r of IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result") IVarFull (Ok a wt) -> do- wtNoMemo <- readIORef writeLogsRefNoMemo- return (a, flattenWT (wt `appendWTs` wtNoMemo))+ return (a, fromMaybe mempty wt <> wtNoMemo) IVarFull (ThrowHaxl e _wt) -> throwIO e -- The written logs are discarded when there's a Haxl exception. We -- can change this behavior if we need to get access to partial logs.
Haxl/Core/ShowP.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} -- | -- Most users should import "Haxl.Core" instead of importing this
Haxl/Core/StateStore.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -23,6 +25,7 @@ ) where import Data.Map (Map)+import Data.Kind (Type) import qualified Data.Map.Strict as Map #if __GLASGOW_HASKELL__ < 804 import Data.Monoid@@ -34,7 +37,7 @@ -- instance of 'StateKey' can store and retrieve information from a -- 'StateStore'. ---class Typeable f => StateKey (f :: * -> *) where+class Typeable f => StateKey (f :: Type -> Type) where data State f -- | We default this to typeOf1, but if f is itself a complex type that is@@ -48,13 +51,15 @@ #if __GLASGOW_HASKELL__ >= 804 instance Semigroup StateStore where- (<>) = mappend+ -- Left-biased union+ StateStore m1 <> StateStore m2 = StateStore $ m1 <> m2 #endif instance Monoid StateStore where mempty = stateEmpty- -- Left-biased union+#if __GLASGOW_HASKELL__ < 804 mappend (StateStore m1) (StateStore m2) = StateStore $ m1 <> m2+#endif -- | Encapsulates the type of 'StateStore' data so we can have a -- heterogeneous collection.
Haxl/Core/Stats.hs view
@@ -1,11 +1,14 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}@@ -23,6 +26,7 @@ , FetchStats(..) , Microseconds , Timestamp+ , DataSourceStats(..) , getTimestamp , emptyStats , numFetches@@ -59,6 +63,7 @@ import Data.Ord (Down(..)) import Data.Text (Text) import Data.Time.Clock.POSIX+import Data.Typeable import Text.Printf import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text@@ -79,6 +84,16 @@ -- --------------------------------------------------------------------------- -- Stats +data DataSourceStats =+ forall a. (Typeable a, Show a, Eq a, ToJSON a) => DataSourceStats a++instance Show DataSourceStats where+ show (DataSourceStats x) = printf "DataSourceStats %s" (show x)++instance Eq DataSourceStats where+ (==) (DataSourceStats a) (DataSourceStats b) =+ cast a == Just b+ -- | Stats that we collect along the way. newtype Stats = Stats [FetchStats] deriving (Show, ToJSON, Semigroup, Monoid)@@ -101,6 +116,7 @@ where isFetchStats FetchStats{} = True isFetchStats FetchWait{} = True+ isFetchStats FetchDataSourceStats{} = True isFetchStats _ = False validFetchStats = filter isFetchStats (reverse rss) numDashes = 50@@ -159,6 +175,12 @@ , fetchWaitStart :: {-# UNPACK #-} !Timestamp , fetchWaitDuration :: {-# UNPACK #-} !Microseconds }+ | FetchDataSourceStats+ { fetchDsStatsCallId :: CallId+ , fetchDsStatsDataSource :: Text+ , fetchDsStatsStats :: DataSourceStats+ , fetchBatchId :: {-# UNPACK #-} !Int+ } deriving (Eq, Show) -- | Pretty-print RoundStats.@@ -183,6 +205,9 @@ msg x = printf "%s (%.2fms)" x (fromIntegral fetchWaitDuration / 1000 :: Double)+ppFetchStats FetchDataSourceStats{..} =+ printf "%s (stats): %s" (Text.unpack fetchDsStatsDataSource)+ (show fetchDsStatsStats) -- | Aggregate stats merging FetchStats from the same dispatched batch into one. aggregateFetchBatches :: ([FetchStats] -> a) -> Stats -> [a]@@ -220,6 +245,14 @@ [ "type" .= ("FetchWait" :: Text) , "duration" .= fetchWaitDuration ]+ toJSON FetchDataSourceStats{..} = object+ [ "type" .= ("FetchDataSourceStats" :: Text)+ , "datasource" .= fetchDsStatsDataSource+ , "stats" .= sjson fetchDsStatsStats+ , "batchid" .= fetchBatchId+ ]+ where+ sjson (DataSourceStats s) = toJSON s emptyStats :: Stats emptyStats = Stats []
Haxl/Core/Util.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} -- | Internal utilities only. --
Haxl/DataSource/ConcurrentIO.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}
Haxl/Prelude.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}
Setup.hs view
@@ -1,2 +1,11 @@+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}++module Setup where import Distribution.Simple main = defaultMain
changelog.md view
@@ -1,6 +1,16 @@-# Changes in version <next>+# Changes in version 2.5.1.1+ * Bump dependencies; builds up to GHC 9.10++# Changes in version 2.5.1.0+ * Add schedulerHintState method to DataSource++# Changes in version 2.4.0.0 * Added fetchBatchId to FetchStats * Profiling now tracks full stacks and links each label to memos/fetches+ * Adds FetchDataSourceStats used to log stats/profiling data returned+ from datasources. This is stored in statsRef like any other Stats.+ * Report flag was changed from sequential numbers to bitmask.+ * Add ReportExceptionLabelStack flag to include label stack in HaxlException. # Changes in version 2.3.0.0 * Removed `FutureFetch`
haxl.cabal view
@@ -1,5 +1,5 @@ name: haxl-version: 2.3.0.0+version: 2.5.1.1 synopsis: A Haskell library for efficient, concurrent, and concise data access. homepage: https://github.com/facebook/Haxl@@ -14,11 +14,16 @@ stability: alpha cabal-version: >= 1.10 tested-with:- GHC==8.2.2,- GHC==8.4.4,- GHC==8.6.5,- GHC==8.8.3,- GHC==8.10.1+ GHC==8.4.4+ GHC==8.6.5+ GHC==8.8.4+ GHC==8.10.7+ GHC==9.0.2+ GHC==9.2.8+ GHC==9.4.8+ GHC==9.6.6+ GHC==9.8.2+ GHC==9.10.1 description: Haxl is a library and EDSL for efficient scheduling of concurrent data@@ -43,25 +48,25 @@ library build-depends:- aeson >= 0.6 && < 1.6,+ aeson >= 0.6 && < 2.3, base >= 4.10 && < 5, binary >= 0.7 && < 0.10,- bytestring >= 0.9 && < 0.11,- containers >= 0.5 && < 0.7,+ bytestring >= 0.9 && < 0.13,+ containers >= 0.5 && < 0.8, deepseq, exceptions >=0.8 && <0.11,- filepath >= 1.3 && < 1.5,+ filepath >= 1.3 && < 1.6, ghc-prim,- hashable >= 1.2 && < 1.4,+ hashable >= 1.2 && < 1.6, hashtables >= 1.2.3.1, pretty == 1.1.*, -- text 1.2.1.0 required for instance Binary Text- text >= 1.2.1.0 && < 1.3,- time >= 1.4 && < 1.10,+ text >= 1.2.1.0 && < 1.3 || >= 2 && < 2.2,+ time >= 1.4 && < 1.13, stm >= 2.4 && < 2.6, transformers, unordered-containers == 0.2.*,- vector >= 0.10 && <0.13+ vector >= 0.10 && <0.14 exposed-modules: Haxl.Core,@@ -87,6 +92,8 @@ Haxl.Core.Util default-language: Haskell2010+ default-extensions:+ TypeOperators ghc-options: -O2 -fprof-auto@@ -132,6 +139,7 @@ CoreTests DataCacheTest ExampleDataSource+ ExceptionStackTests FullyAsyncTest LoadCache MemoizationTests@@ -148,11 +156,14 @@ TestUtils WorkDataSource WriteTests+ DataSourceDispatchTests type: exitcode-stdio-1.0 default-language: Haskell2010+ default-extensions:+ TypeOperators flag bench default: False@@ -162,6 +173,8 @@ buildable: False default-language: Haskell2010+ default-extensions:+ TypeOperators hs-source-dirs: tests build-depends:@@ -182,6 +195,8 @@ buildable: False default-language: Haskell2010+ default-extensions:+ TypeOperators hs-source-dirs: tests build-depends:
readme.md view
@@ -1,8 +1,8 @@-+ # Haxl -[](https://travis-ci.org/facebook/Haxl)+[](https://opensource.fb.com/support-ukraine) [](https://travis-ci.org/facebook/Haxl) Haxl is a Haskell library that simplifies access to remote data, such as databases or web-based services. Haxl can automatically
tests/AdoTests.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE RebindableSyntax, OverloadedStrings, ApplicativeDo #-} module AdoTests (tests) where
tests/AllTests.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} module AllTests (allTests) where @@ -11,6 +13,7 @@ import BatchTests import CoreTests import DataCacheTest+import ExceptionStackTests import AdoTests import OutgoneFetchesTests import ProfileTests@@ -21,6 +24,7 @@ import WriteTests import ParallelTests import StatsTests+import DataSourceDispatchTests import Test.HUnit @@ -31,6 +35,7 @@ , TestLabel "BatchTests-sync" $ BatchTests.tests False , TestLabel "CoreTests" CoreTests.tests , TestLabel "DataCacheTests" DataCacheTest.tests+ , TestLabel "ExceptionStackTests" ExceptionStackTests.tests , TestLabel "AdoTests" $ AdoTests.tests False , TestLabel "OutgoneFetchesTest" OutgoneFetchesTests.tests , TestLabel "ProfileTests" ProfileTests.tests@@ -41,4 +46,5 @@ , TestLabel "WriteTest" WriteTests.tests , TestLabel "ParallelTest" ParallelTests.tests , TestLabel "StatsTests" StatsTests.tests+ , TestLabel "DataSourceDispatchTests" DataSourceDispatchTests.tests ]
tests/BadDataSource.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}
tests/BatchTests.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} module BatchTests (tests) where
tests/Bench.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE RankNTypes, GADTs, BangPatterns, DeriveDataTypeable, StandaloneDeriving #-}
tests/CoreTests.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RebindableSyntax #-}@@ -33,7 +35,7 @@ let st = stateSet exstate stateEmpty -- Create the Env:- initEnv st ()+ initEnv st () :: IO (Env () ()) useless :: String -> GenHaxl u w Bool useless _ = throw (NotFound "ha ha")@@ -41,7 +43,7 @@ exceptions :: Assertion exceptions = do- en <- emptyEnv ()+ en <- emptyEnv () :: IO (Env () ()) a <- runHaxl en $ try (useless "input") assertBool "NotFound -> HaxlException" $ isLeft (a :: Either HaxlException Bool)@@ -132,7 +134,7 @@ -- makes the compiler happy. base :: (Exception a) => a -> IO HaxlException base e = do- en <- emptyEnv ()+ en <- emptyEnv () :: IO (Env () ()) runHaxl en $ throw e `catch` \x -> return x printing :: Assertion@@ -154,21 +156,21 @@ withEnvTest :: Test withEnvTest = TestLabel "withEnvTest" $ TestCase $ do exstate <- ExampleDataSource.initGlobalState- e <- initEnv (stateSet exstate stateEmpty) False+ e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) b <- runHaxl e $ withEnv e { userEnv = True } $ env userEnv assertBool "withEnv1" b- e <- initEnv (stateSet exstate stateEmpty) False+ e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) b <- runHaxl e $ withEnv e { userEnv = True } $ do _ <- countAardvarks "aaa" env userEnv assertBool "withEnv2" b- e <- initEnv (stateSet exstate stateEmpty) False+ e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) b <- runHaxl e $ withEnv e { userEnv = True } $ do memo ("xxx" :: Text) $ do _ <- countAardvarks "aaa" env userEnv assertBool "withEnv3" b- e <- initEnv (stateSet exstate stateEmpty) False+ e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) b <- runHaxl e $ withEnv e { userEnv = True } $ do memo ("yyy" :: Text) $ do
tests/DataCacheTest.hs view
@@ -1,10 +1,16 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} module DataCacheTest (tests, newResult, takeResult) where import Haxl.Core.DataCache as DataCache@@ -12,12 +18,15 @@ import Haxl.Core import Control.Exception+import Data.Either import Data.Hashable import Data.Traversable import Data.Typeable import Prelude hiding (mapM) import Test.HUnit import Data.IORef+import Data.Text+import Unsafe.Coerce data TestReq a where Req :: Int -> TestReq a -- polymorphic result@@ -29,11 +38,30 @@ instance Hashable (TestReq a) where hashWithSalt salt (Req i) = hashWithSalt salt i -newResult :: a -> IO (IVar u w a)-newResult a = IVar <$> newIORef (IVarFull (Ok a NilWrites))+instance DataSource u TestReq where+ fetch = error "no fetch defined" +instance DataSourceName TestReq where+ dataSourceName _ = pack "TestReq"++instance StateKey TestReq where+ data State TestReq = TestReqState++instance ShowP TestReq where showp = show++data CacheableReq x where CacheableInt :: Int -> CacheableReq Int+ deriving Typeable+deriving instance Eq (CacheableReq x)+deriving instance Show (CacheableReq x)+instance Hashable (CacheableReq x) where+ hashWithSalt s (CacheableInt val) = hashWithSalt s (0::Int, val)+++newResult :: Monoid w => a -> IO (IVar u w a)+newResult a = newFullIVar (Ok a mempty)+ takeResult :: IVar u w a -> IO (ResultVal a w)-takeResult (IVar ref) = do+takeResult IVar{ivarRef = ref} = do e <- readIORef ref case e of IVarFull a -> return a@@ -59,13 +87,13 @@ r <- mapM takeResult =<< DataCache.lookup (Req 1) cache assertBool "dcSoundness2" $ case r :: Maybe (ResultVal Int ()) of- Just (Ok 1 NilWrites) -> True+ Just (Ok 1 Nothing) -> True _something_else -> False r <- mapM takeResult =<< DataCache.lookup (Req 2) cache assertBool "dcSoundness3" $ case r :: Maybe (ResultVal String ()) of- Just (Ok "hello" NilWrites) -> True+ Just (Ok "hello" Nothing) -> True _something_else -> False r <- mapM takeResult =<< DataCache.lookup (Req 2) cache@@ -77,7 +105,7 @@ dcStrictnessTest :: Test dcStrictnessTest = TestLabel "DataCache strictness" $ TestCase $ do- env <- initEnv stateEmpty ()+ env <- initEnv stateEmpty () :: IO (Env () ()) r <- Control.Exception.try $ runHaxl env $ cachedComputation (Req (error "BOOM")) $ return "OK" assertBool "dcStrictnessTest" $@@ -85,5 +113,90 @@ Left (ErrorCall "BOOM") -> True _other -> False +dcFallbackTest :: Test+dcFallbackTest = TestLabel "DataCache fallback" $ TestList+ [ TestLabel "Base" $ TestCase $ do+ env <- mkEnv+ (r,cached) <- runHaxl env (do+ a <- dataFetch req+ b <- cacheResult (CacheableInt 1234) (return 99999)+ return (a,b))+ (Stats stats) <- readIORef (statsRef env)+ assertEqual "fallback still has stats" 1+ (Prelude.length [x | x@FetchStats{} <- stats])+ assertEqual "dcFallbackTest found" 1 r+ assertEqual "dcFallbackTest cached" 1234 cached+ , TestLabel "Exception" $ TestCase $ do+ env <- mkEnv+ rbad <- Control.Exception.try $ runHaxl env (dataFetch reqBad)+ assertBool "dcFallbackTest not found" $+ case rbad of+ Left (ErrorCall "no fetch defined") -> True+ _ -> False+ , TestLabel "Completions" $ TestCase $ do+ -- check applicative still runs as it would have without a fallback+ env <- mkEnv+ let+ fetchA = dataFetch reqEx+ fetchB = tellWrite 7 >> dataFetch req+ (rbad, writes) <- runHaxlWithWrites env $+ Haxl.Core.try $ (,) <$> fetchA <*> fetchB+ fetches <- countFetches env+ assertEqual "dispatched 2 fetches" 2 fetches+ assertBool "exception propogates" $+ case rbad of+ Left (NotFound _) -> True+ _ -> False+ assertEqual "write side effects happen" [7] (flattenWT writes)+ ]+ where++ mkEnv = addLookup <$> initEnv (stateSet TestReqState stateEmpty) ()++ countFetches env = do+ (Stats stats) <- readIORef (statsRef env)+ let+ c = sum [ fetchBatchSize x+ | x@FetchStats{} <- stats+ ]+ return c++ addLookup :: Env () (WriteTree Int) -> Env () (WriteTree Int)+ addLookup e = e { dataCacheFetchFallback = Just (DataCacheLookup lookup)+ , flags = (flags e) { report = profilingReportFlags }+ }+ lookup+ :: forall req a . Typeable (req a)+ => req a+ -> IO (Maybe (ResultVal a (WriteTree Int)))+ lookup r+ | typeOf r == typeRep (Proxy :: Proxy (TestReq Int)) =+ -- have to coerce on the way out as results are not Typeable+ -- so you better be sure you do it right!+ return $ unsafeCoerce . doReq <$> cast r+ | typeOf r == typeRep (Proxy :: Proxy (CacheableReq Int)) =+ return $ unsafeCoerce . doCache <$> cast r+ | otherwise = return Nothing++ doReq :: TestReq Int -> ResultVal Int (WriteTree Int)+ doReq (Req 999) = ThrowHaxl (toException $ NotFound empty) Nothing+ doReq (Req r) = Ok r Nothing++ doCache :: CacheableReq Int -> ResultVal Int (WriteTree Int)+ doCache (CacheableInt i) = Ok i Nothing++ req :: TestReq Int+ req = Req 1++ reqEx :: TestReq Int+ reqEx = Req 999++ reqBad :: TestReq String+ reqBad = Req 2++ -- tests :: Assertion-tests = TestList [dcSoundnessTest, dcStrictnessTest]+tests = TestList [ dcSoundnessTest+ , dcStrictnessTest+ , dcFallbackTest+ ]
+ tests/DataSourceDispatchTests.hs view
@@ -0,0 +1,83 @@+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}++module DataSourceDispatchTests (tests) where+import Test.HUnit hiding (State)+import Control.Monad+import Haxl.Core+import Data.Hashable++data DataSourceDispatch ty where+ GetBatchSize :: Int -> DataSourceDispatch Int++deriving instance Eq (DataSourceDispatch ty)+deriving instance Show (DataSourceDispatch ty)++instance DataSourceName DataSourceDispatch where+ dataSourceName _ = "DataSourceDispatch"++instance StateKey DataSourceDispatch where+ data State DataSourceDispatch = DataSourceDispatchState++instance ShowP DataSourceDispatch where showp = show++instance Hashable (DataSourceDispatch a) where+ hashWithSalt s (GetBatchSize n) = hashWithSalt s n++initDataSource :: IO (State DataSourceDispatch)+initDataSource = return DataSourceDispatchState++instance DataSource UserEnv DataSourceDispatch where+ fetch _state _flags _u = SyncFetch $ \bfs -> forM_ bfs (fill $ length bfs)+ where+ fill :: Int -> BlockedFetch DataSourceDispatch -> IO ()+ fill l (BlockedFetch (GetBatchSize _ ) rv) = putResult rv (Right l)++ schedulerHint Batching = TryToBatch+ schedulerHint NoBatching = SubmitImmediately++data UserEnv = Batching | NoBatching deriving (Eq)++makeTestEnv :: UserEnv -> IO (Env UserEnv ())+makeTestEnv testUsrEnv = do+ st <- initDataSource+ e <- initEnv (stateSet st stateEmpty) testUsrEnv+ return e { flags = (flags e) {+ report = setReportFlag ReportFetchStats defaultReportFlags } }++schedulerTest:: Test+schedulerTest = TestCase $ do+ let+ fet = do+ x <- dataFetch (GetBatchSize 0)+ y <- dataFetch (GetBatchSize 1)+ return [x,y]++ e <- makeTestEnv Batching+ r1 :: [Int] <- runHaxl e fet+ assertEqual "Failed to create batches for data fetch" [2,2] r1++ eNoBatching <- makeTestEnv NoBatching+ r2 :: [Int] <- runHaxl eNoBatching fet+ assertEqual "Unexpexted batches in SubmitImmediately" [1,1] r2++ return ()++tests :: Test+tests = TestList+ [ TestLabel "schedulerTest" schedulerTest+ ]
tests/ExampleDataSource.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}
+ tests/ExceptionStackTests.hs view
@@ -0,0 +1,73 @@+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module ExceptionStackTests (tests) where++import Prelude ()+import Haxl.Core+import Haxl.Prelude++import Test.HUnit++import qualified ExampleDataSource++testEnv :: ReportFlags -> IO (Env () ())+testEnv report = do+ exstate <- ExampleDataSource.initGlobalState+ let st = stateSet exstate stateEmpty+ env <- initEnv st ()+ return env{ flags = (flags env){ report = report } }++reportFlags :: ReportFlags+reportFlags = setReportFlag ReportExceptionLabelStack defaultReportFlags++runHaxlTest+ :: ReportFlags+ -> String+ -> (Int -> Int -> GenHaxl () () Int)+ -> IO (Maybe [Text])+runHaxlTest report str func = do+ env <- testEnv report+ result <- runHaxl env $+ withLabel "try" $ tryToHaxlException $ withLabel "test" $ do+ x <- withLabel "dummy" $ pure 1+ y <- withLabel "fetch" $ ExampleDataSource.countAardvarks str+ withLabel "func" $ func x y+ case result of+ Left (HaxlException stk _) -> return stk+ Right{} -> assertFailure "expected: HaxlException"++fetchException :: Test+fetchException = TestCase $ do+ result <- runHaxlTest reportFlags "BANG4" $ \i j -> return $ i + j+ assertEqual "stack" (Just ["fetch", "test", "try", "MAIN"]) result++userException :: Test+userException = TestCase $ do+ result <- runHaxlTest reportFlags "aaa" $ \_ _ -> withLabel "throw" $+ throw $ InvalidParameter "throw"+ assertEqual "stack" (Just ["throw", "func", "test", "try", "MAIN"]) result++#ifndef PROFILING+disabledExceptionStack :: Test+disabledExceptionStack = TestCase $ do+ result <- runHaxlTest defaultReportFlags "BANG4" $ \i j -> return $ i + j+ assertEqual "stack" Nothing result+#endif++tests :: Test+tests = TestList+ [ TestLabel "FetchException" fetchException+ , TestLabel "UserException" userException+#ifndef PROFILING+ , TestLabel "DisabledExceptionStack" disabledExceptionStack+#endif+ ]
tests/FullyAsyncTest.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ module FullyAsyncTest where import Haxl.Prelude as Haxl@@ -20,10 +22,12 @@ tests :: Test tests = sleepTest +testEnv :: IO (Env () ()) testEnv = do st <- mkConcurrentIOState env <- initEnv (stateSet st stateEmpty) ()- return env { flags = (flags env) { report = 2 } }+ return env { flags = (flags env) {+ report = setReportFlag ReportFetchStats defaultReportFlags } } sleepTest :: Test sleepTest = TestCase $ do
tests/LoadCache.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE CPP, OverloadedStrings #-} module LoadCache where
tests/MemoizationTests.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ module MemoizationTests (tests) where import Data.IORef@@ -19,7 +21,7 @@ memoSoundness = TestCase $ do iEnv <- do exState <- ExampleDataSource.initGlobalState- initEnv (stateSet exState stateEmpty) ()+ initEnv (stateSet exState stateEmpty) () :: IO (Env () ()) unMemoizedWombats <- runHaxl iEnv $ listWombats 100
tests/MockTAO.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}
tests/MonadAsyncTest.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}@@ -19,7 +21,7 @@ import Control.Concurrent import Control.Exception as Exception import Control.Monad-import Haxl.Core.Monad (unsafeLiftIO)+import Haxl.Core.Monad (unsafeLiftIO, WriteTree) import System.IO.Unsafe import Data.Hashable import Data.IORef@@ -86,7 +88,7 @@ [ TestLabel "exceptionTest" exceptionTest ] -mkTestEnv :: IO (Env () SimpleWrite)+mkTestEnv :: IO (Env () (WriteTree SimpleWrite)) mkTestEnv = do st <- initDataSource initEnv (stateSet st stateEmpty) ()
tests/MonadBench.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ -- | Benchmarking tool for core performance characteristics of the Haxl monad. {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo, RecordWildCards #-}@@ -21,23 +23,22 @@ import Haxl.Prelude as Haxl import Prelude() -import Haxl.Core.Memo (newMemoWith, runMemo)- import Haxl.Core+import Haxl.Core.Monad (WriteTree) import Haxl.Core.Util import ExampleDataSource newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show) -testEnv :: Int -> IO (Env () SimpleWrite)+testEnv :: ReportFlags -> IO (Env () (WriteTree SimpleWrite)) testEnv report = do exstate <- ExampleDataSource.initGlobalState let st = stateSet exstate stateEmpty env <- initEnv st () return env { flags = (flags env) { report = report } } -type Test = (String, Int, Int -> GenHaxl () SimpleWrite ())+type Test = (String, Int, Int -> GenHaxl () (WriteTree SimpleWrite) ()) testName :: Test -> String testName (t,_,_) = t@@ -112,7 +113,7 @@ data Options = Options { test :: String , nOverride :: Maybe Int- , reportFlag :: Int+ , reportFlag :: ReportFlags } runTest :: Options -> Test -> IO ()@@ -128,9 +129,14 @@ optionsParser :: Parser Options optionsParser = do test <- argument str (metavar "TEST")- reportFlag <- option auto (long "report" <> value 0 <> metavar "REPORT")+ reportFlag <- reportFlagParser nOverride <- optional $ argument auto (metavar "NUM") return Options{..}+ where+ reportFlagParser = foldl' (flip ($)) defaultReportFlags <$> sequenceA+ [ flag id (setReportFlag i) $ long $ show i+ | i <- enumFrom minBound+ ] main :: IO () main = do@@ -148,19 +154,20 @@ tree :: Int- -> (Int -> GenHaxl () SimpleWrite [Id] -> GenHaxl () SimpleWrite [Id])- -> GenHaxl () SimpleWrite [Id]+ -> (Int -> GenHaxl () (WriteTree SimpleWrite) [Id]+ -> GenHaxl () (WriteTree SimpleWrite) [Id])+ -> GenHaxl () (WriteTree SimpleWrite) [Id] tree 0 wrap = wrap 0 $ listWombats 0 tree n wrap = wrap n $ concat <$> Haxl.sequence [ tree (n-1) wrap , listWombats (fromIntegral n), tree (n-1) wrap ] -unionWombats :: GenHaxl () SimpleWrite [Id]+unionWombats :: GenHaxl () (WriteTree SimpleWrite) [Id] unionWombats = foldl List.union [] <$> Haxl.mapM listWombats [1..1000] -unionWombatsTo :: Id -> GenHaxl () SimpleWrite [Id]+unionWombatsTo :: Id -> GenHaxl () (WriteTree SimpleWrite) [Id] unionWombatsTo x = foldl List.union [] <$> Haxl.mapM listWombats [1..x] -unionWombatsFromTo :: Id -> Id -> GenHaxl () SimpleWrite [Id]+unionWombatsFromTo :: Id -> Id -> GenHaxl () (WriteTree SimpleWrite) [Id] unionWombatsFromTo x y = foldl List.union [] <$> Haxl.mapM listWombats [x..y]
tests/OutgoneFetchesTests.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-} module OutgoneFetchesTests (tests) where@@ -13,11 +15,9 @@ import Haxl.Core import Haxl.DataSource.ConcurrentIO-import Haxl.Core.RequestStore (getMapFromRCMap) import Data.IORef import qualified Data.Map as Map-import Data.Proxy (Proxy(..)) import Data.Typeable import Test.HUnit import System.Timeout@@ -31,7 +31,8 @@ sleepState <- mkConcurrentIOState let st = stateSet exstate $ stateSet sleepState stateEmpty e <- initEnv st ()- return e { flags = (flags e) {report = 1} }+ return e { flags = (flags e) {+ report = setReportFlag ReportOutgoneFetches defaultReportFlags } } -- report=1 to enable fetches tracking -- A cheap haxl computation we interleave b/w the @sleep@ fetches.
tests/ParallelTests.hs view
@@ -1,3 +1,11 @@+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ module ParallelTests where import Haxl.Prelude@@ -10,6 +18,7 @@ import Test.HUnit +testEnv :: IO (Env () ()) testEnv = do sleepState <- mkConcurrentIOState let st = stateSet sleepState stateEmpty
tests/ProfileTests.hs view
@@ -1,12 +1,15 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-} module ProfileTests where @@ -23,15 +26,22 @@ import Data.Aeson import Data.IORef import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import Data.Int +import TestTypes import TestUtils import WorkDataSource import SleepDataSource +mkProfilingEnv :: IO HaxlEnv mkProfilingEnv = do env <- makeTestEnv False- return env { flags = (flags env) { report = 4 } }+ return env { flags = (flags env) { report = profilingReportFlags } } -- expects only one label to be shown labelToDataMap :: Profile -> HashMap.HashMap ProfileLabel ProfileData@@ -53,7 +63,7 @@ slp <- sum <$> mapM (\x -> withLabel "baz" $ return x) [1..5] -- do some non-trivial work that can't be lifted out -- first sleep though in order to force a Blocked result- sleep slp `andThen` case fromJSON <$> HashMap.lookup "A" u of+ sleep slp `andThen` case fromJSON <$> KeyMap.lookup "A" u of Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5 _otherwise -> return (4::Int) profCopy <- readIORef (profRef e)@@ -87,6 +97,24 @@ assertEqual "foo's parent is bar" (Just (head fooParents)) $ HashMap.lookup ("bar", 0) (profileTree profCopy) ++collectsLazyData :: Assertion+collectsLazyData = do+ e <- mkProfilingEnv+ _x <- runHaxl e $ withLabel "bar" $ do+ u <- env userEnv+ withLabel "foo" $ do+ let start = if KeyMap.member "A" u+ then 10+ else 1+ return $ sum [start..10000::Integer]+ profCopy <- readIORef (profRef e)+ -- check the allocations are attributed to foo+ assertBool "foo has allocations" $+ case profileAllocs <$> HashMap.lookup "foo" (labelToDataMap profCopy) of+ Just x -> x > 10000+ Nothing -> False+ exceptions :: Assertion exceptions = do env <- mkProfilingEnv@@ -113,8 +141,9 @@ -- for correct accounting when relying on allocation limits. threadAlloc :: Integer -> Assertion threadAlloc batches = do- env' <- initEnv (stateSet mkWorkState stateEmpty) ()- let env = env' { flags = (flags env') { report = 2 } }+ env' <- initEnv (stateSet mkWorkState stateEmpty) () :: IO (Env () ())+ let env = env' { flags = (flags env') {+ report = setReportFlag ReportFetchStats defaultReportFlags } } a0 <- getAllocationCounter let wsize = 100000@@ -180,6 +209,7 @@ tests = TestList [ TestLabel "collectsdata" $ TestCase collectsdata+ , TestLabel "collectsdata - lazy" $ TestCase collectsLazyData , TestLabel "exceptions" $ TestCase exceptions , TestLabel "threads" $ TestCase (threadAlloc 1) , TestLabel "threads with batch" $ TestCase (threadAlloc 50)
tests/SleepDataSource.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}
tests/StatsTests.hs view
@@ -1,12 +1,15 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module StatsTests (tests) where @@ -66,7 +69,7 @@ assertEqual "Grouping works as expected" expectedResultInterspersed aggInterspersedBatch -+testEnv :: IO (Env () ()) testEnv = do -- To use a data source, we need to initialize its state: exstate <- ExampleDataSource.initGlobalState@@ -77,7 +80,8 @@ -- Create the Env: env <- initEnv st ()- return env{ flags = (flags env){ report = 5 } }+ return env{ flags = (flags env){+ report = setReportFlag ReportFetchStack profilingReportFlags } } fetchIdsSync :: Test
tests/TestBadDataSource.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE OverloadedStrings #-} module TestBadDataSource (tests) where
tests/TestExampleDataSource.hs view
@@ -1,9 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE CPP, OverloadedStrings, RebindableSyntax, MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} module TestExampleDataSource (tests) where@@ -24,6 +26,7 @@ import ExampleDataSource import LoadCache +testEnv :: IO (Env () ()) testEnv = do -- To use a data source, we need to initialize its state: exstate <- ExampleDataSource.initGlobalState@@ -33,7 +36,8 @@ -- Create the Env: env <- initEnv st ()- return env{ flags = (flags env){ report = 2 } }+ return env{ flags = (flags env){+ report = setReportFlag ReportFetchStats defaultReportFlags } } tests = TestList [
tests/TestMain.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE CPP, OverloadedStrings #-} module Main where
tests/TestTypes.hs view
@@ -1,12 +1,15 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} module TestTypes ( UserEnv@@ -18,29 +21,40 @@ import Data.Aeson import Data.Binary (Binary)-import Data.Text (Text) import qualified Data.Text as Text-import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.Key (toText)+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import Data.Hashable import Data.Typeable import Haxl.Core +#if !MIN_VERSION_aeson(2,0,0)+type Key = Text.Text++toText :: Key -> Text.Text+toText = id+#endif+ type UserEnv = Object type Haxl a = GenHaxl UserEnv () a type HaxlEnv = Env UserEnv () -lookupInput :: FromJSON a => Text -> Haxl a+lookupInput :: FromJSON a => Key -> Haxl a lookupInput field = do- mb_val <- env (HashMap.lookup field . userEnv)+ mb_val <- env (KeyMap.lookup field . userEnv) case mb_val of Nothing ->- throw (NotFound (Text.concat ["field ", field, " was not found."]))+ throw (NotFound (Text.concat ["field ", toText field, " was not found."])) Just val -> case fromJSON val of Error str -> throw (UnexpectedType (Text.concat- ["field ", field, ": ", Text.pack str]))+ ["field ", toText field, ": ", Text.pack str])) Success a -> return a
tests/TestUtils.hs view
@@ -1,10 +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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}+ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module TestUtils ( makeTestEnv , expectResultWithEnv@@ -21,7 +24,11 @@ import Data.IORef import Data.Aeson import Test.HUnit-import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import Haxl.Core @@ -29,7 +36,7 @@ import Haxl.Prelude testinput :: Object-testinput = HashMap.fromList [+testinput = KeyMap.fromList [ "A" .= (1 :: Int), "B" .= (2 :: Int), "C" .= (3 :: Int),@@ -53,7 +60,8 @@ stio <- mkConcurrentIOState let st = stateSet stio $ stateSet tao stateEmpty env <- initEnv st testinput- return env { flags = (flags env) { report = 2 } }+ return env { flags = (flags env) {+ report = setReportFlag ReportFetchStats defaultReportFlags } } expectResultWithEnv :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion
tests/WorkDataSource.hs view
@@ -1,8 +1,10 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved.++ This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}
tests/WriteTests.hs view
@@ -1,28 +1,72 @@--- 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.+{-+ Copyright (c) Meta Platforms, Inc. and affiliates.+ All rights reserved. + This source code is licensed under the BSD-style license found in the+ LICENSE file in the root directory of this source tree.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} module WriteTests (tests) where import Test.HUnit +import Control.Arrow+import Control.Concurrent+import Data.Either import Data.Foldable+import Data.Hashable+import Data.IORef+import qualified Data.Text as Text +import Haxl.Core.Monad (mapWrites, mapWriteTree, flattenWT, WriteTree) import Haxl.Core import Haxl.Prelude as Haxl +-- A fake data source+data SimpleDataSource a where+ GetNumber :: SimpleDataSource Int++deriving instance Eq (SimpleDataSource a)+deriving instance Show (SimpleDataSource a)+instance ShowP SimpleDataSource where showp = show++instance Hashable (SimpleDataSource a) where+ hashWithSalt s GetNumber = hashWithSalt s (0 :: Int)++instance StateKey SimpleDataSource where+ data State SimpleDataSource = DSState++instance DataSourceName SimpleDataSource where+ dataSourceName _ = "SimpleDataSource"++instance DataSource u SimpleDataSource where+ fetch _st _flags _usr = SyncFetch $ Haxl.mapM_ fetch1+ where+ fetch1 :: BlockedFetch SimpleDataSource -> IO ()+ fetch1 (BlockedFetch GetNumber m) =+ threadDelay 1000 >> putSuccess m 37+ newtype SimpleWrite = SimpleWrite Text- deriving (Eq, Show)+ deriving (Eq, Show, Ord) -doInnerWrite :: GenHaxl u SimpleWrite Int+assertEqualIgnoreOrder ::+ (Eq a, Show a, Ord a) => String -> [a] -> [a] -> Assertion+assertEqualIgnoreOrder msg lhs rhs =+ assertEqual msg (sort lhs) (sort rhs)++doInnerWrite :: GenHaxl u (WriteTree SimpleWrite) Int doInnerWrite = do tellWrite $ SimpleWrite "inner" return 0 -doOuterWrite :: GenHaxl u SimpleWrite Int+doOuterWrite :: GenHaxl u (WriteTree SimpleWrite) Int doOuterWrite = do tellWrite $ SimpleWrite "outer1" @@ -35,19 +79,22 @@ return 1 -doNonMemoWrites :: GenHaxl u SimpleWrite Int+doNonMemoWrites :: GenHaxl u (WriteTree SimpleWrite) Int doNonMemoWrites = do tellWrite $ SimpleWrite "inner" tellWriteNoMemo $ SimpleWrite "inner not memo" return 0 +runHaxlWithWriteList :: Env u (WriteTree w) -> GenHaxl u (WriteTree w) a -> IO (a, [w])+runHaxlWithWriteList env haxl = second flattenWT <$> runHaxlWithWrites env haxl+ writeSoundness :: Test writeSoundness = TestCase $ do let numReps = 4 -- do writes without memoization env1 <- emptyEnv ()- (allRes, allWrites) <- runHaxlWithWrites env1 $+ (allRes, allWrites) <- runHaxlWithWriteList env1 $ Haxl.sequence (replicate numReps doInnerWrite) assertBool "Write Soundness 1" $@@ -57,7 +104,7 @@ -- do writes with memoization env2 <- emptyEnv () - (memoRes, memoWrites) <- runHaxlWithWrites env2 $ do+ (memoRes, memoWrites) <- runHaxlWithWriteList env2 $ do doWriteMemo <- newMemoWith doInnerWrite let memoizedWrite = runMemo doWriteMemo @@ -70,7 +117,7 @@ -- do writes with interleaved memo env3 <- emptyEnv () - (ilRes, ilWrites) <- runHaxlWithWrites env3 $ do+ (ilRes, ilWrites) <- runHaxlWithWriteList env3 $ do doWriteMemo <- newMemoWith doInnerWrite let memoizedWrite = runMemo doWriteMemo @@ -83,7 +130,7 @@ -- do writes with nested memo env4 <- emptyEnv () - (nestRes, nestWrites) <- runHaxlWithWrites env4 $ do+ (nestRes, nestWrites) <- runHaxlWithWriteList env4 $ do doWriteMemo' <- newMemoWith doOuterWrite let memoizedWrite' = runMemo doWriteMemo' @@ -101,7 +148,7 @@ -- do both kinds of writes without memoization env5 <- emptyEnv ()- (allRes, allWrites) <- runHaxlWithWrites env5 $+ (allRes, allWrites) <- runHaxlWithWriteList env5 $ Haxl.sequence (replicate numReps doNonMemoWrites) assertBool "Write Soundness 9" $@@ -112,7 +159,7 @@ -- do both kinds of writes with memoization env6 <- emptyEnv () - (memoRes, memoWrites) <- runHaxlWithWrites env6 $ do+ (memoRes, memoWrites) <- runHaxlWithWriteList env6 $ do doWriteMemo <- newMemoWith doNonMemoWrites let memoizedWrite = runMemo doWriteMemo @@ -124,6 +171,130 @@ [SimpleWrite "inner not memo"] assertBool "Write Soundness 12" $ memoRes == replicate numReps 0 +writeLogsCorrectnessTest :: Test+writeLogsCorrectnessTest = TestLabel "writeLogs_correctness" $ TestCase $ do+ e <- emptyEnv ()+ (_ , wrts) <- runHaxlWithWriteList e doNonMemoWrites+ assertEqualIgnoreOrder "Expected writes" [SimpleWrite "inner",+ SimpleWrite "inner not memo"] wrts+ wrtsNoMemo <- readIORef $ writeLogsRefNoMemo e+ wrtsMemo <- readIORef $ writeLogsRef e+ assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsNoMemo+ assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsMemo +mapWritesTest :: Test+mapWritesTest = TestLabel "mapWrites" $ TestCase $ do+ let funcSingle (SimpleWrite s) = SimpleWrite $ Text.toUpper s+ func = mapWriteTree funcSingle+ env0 <- emptyEnv ()+ (res0, wrts0) <- runHaxlWithWriteList env0 $ mapWrites func doNonMemoWrites+ assertEqual "Expected computation result" 0 res0+ assertEqualIgnoreOrder "Writes correctly transformed" [SimpleWrite "INNER",+ SimpleWrite "INNER NOT MEMO"] wrts0 -tests = TestList [TestLabel "Write Soundness" writeSoundness]+ -- Writes should behave the same inside and outside mapWrites+ env1 <- emptyEnv ()+ (res1, wrts1) <- runHaxlWithWriteList env1 $ do+ outer <- doOuterWrite+ outerMapped <- mapWrites func doOuterWrite+ return $ outer == outerMapped+ assertBool "Results are identical" res1+ assertEqualIgnoreOrder+ "Writes correctly transformed, non-transformed writes preserved"+ [ SimpleWrite "outer1", SimpleWrite "inner"+ , SimpleWrite "inner", SimpleWrite "outer2"+ , SimpleWrite "OUTER1", SimpleWrite "INNER"+ , SimpleWrite "INNER", SimpleWrite "OUTER2"+ ]+ wrts1++ -- Memoization behaviour should be unaffected+ env2 <- emptyEnv ()+ (_res2, wrts2) <- runHaxlWithWriteList env2 $ do+ writeMemo <- newMemoWith doNonMemoWrites+ let doWriteMemo = runMemo writeMemo+ _ <- mapWrites func doWriteMemo+ _ <- doWriteMemo+ return ()+ -- "inner not memo" should appear only once+ assertEqualIgnoreOrder+ "Write correctly transformed under memoization"+ [ SimpleWrite "INNER"+ , SimpleWrite "inner"+ , SimpleWrite "INNER NOT MEMO"+ ]+ wrts2++ -- Same as previous, but the non-mapped computation is run first+ env3 <- emptyEnv ()+ (_res3, wrts3) <- runHaxlWithWriteList env3 $ do+ writeMemo <- newMemoWith doNonMemoWrites+ let doWriteMemo = runMemo writeMemo+ _ <- doWriteMemo+ _ <- mapWrites func doWriteMemo+ return ()+ -- "inner not memo" should appear only once+ assertEqualIgnoreOrder+ "Flipped: Write correctly transformed under memoization"+ [ SimpleWrite "inner"+ , SimpleWrite "INNER"+ , SimpleWrite "inner not memo"+ ]+ wrts3++ -- inner computation performs no writes+ env4 <- emptyEnv ()+ (res4, wrts4) <- runHaxlWithWriteList env4 $+ mapWrites func (return (0 :: Int))+ assertEqual "No Writes: Expected computation result" 0 res4+ assertEqualIgnoreOrder "No writes" [] wrts4++ -- inner computation throws an exception+ env5 <- emptyEnv ()+ (res5, wrts5) <- runHaxlWithWriteList env5 $ mapWrites func $ try $ do+ _ <- doNonMemoWrites+ _ <- throw (NotFound "exception")+ return 0+ assertBool "Throw: Expected Computation Result" $ isLeft+ (res5 :: Either HaxlException Int)+ assertEqualIgnoreOrder+ "Datasource writes correctly transformed"+ [ SimpleWrite "INNER"+ , SimpleWrite "INNER NOT MEMO"+ ]+ wrts5++ -- inner computation calls a datasource+ env6 <- initEnv (stateSet DSState stateEmpty) ()+ (res6, wrts6) <- runHaxlWithWriteList env6 $ mapWrites func $ do+ _ <- doNonMemoWrites+ dataFetch GetNumber++ assertEqual "Datasource: Expected Computation Result" 37 res6+ assertEqualIgnoreOrder+ "Datasource writes correctly transformed"+ [ SimpleWrite "INNER"+ , SimpleWrite "INNER NOT MEMO"+ ]+ wrts6++ -- inner computation calls a datasource, flipped calls+ env7 <- initEnv (stateSet DSState stateEmpty) ()+ (res7, wrts7) <- runHaxlWithWriteList env7 $ mapWrites func $ do+ df <- dataFetch GetNumber+ _ <- doNonMemoWrites+ return df++ assertEqual "Flipped Datasource: Expected Computation Result" 37 res7+ assertEqualIgnoreOrder+ "Flipped: Datasource writes correctly transformed"+ [ SimpleWrite "INNER"+ , SimpleWrite "INNER NOT MEMO"+ ]+ wrts7++tests = TestList+ [ TestLabel "Write Soundness" writeSoundness,+ TestLabel "writeLogs_correctness" writeLogsCorrectnessTest,+ TestLabel "mapWrites" mapWritesTest+ ]