├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── Haxl ├── Core.hs ├── Core │ ├── CallGraph.hs │ ├── DataCache.hs │ ├── DataSource.hs │ ├── Exception.hs │ ├── Fetch.hs │ ├── Flags.hs │ ├── Memo.hs │ ├── Monad.hs │ ├── Parallel.hs │ ├── Profile.hs │ ├── RequestStore.hs │ ├── Run.hs │ ├── ShowP.hs │ ├── StateStore.hs │ ├── Stats.hs │ └── Util.hs ├── DataSource │ └── ConcurrentIO.hs └── Prelude.hs ├── LICENSE ├── Setup.hs ├── changelog.md ├── example ├── facebook │ ├── FB.hs │ ├── FB │ │ └── DataSource.hs │ ├── LICENSE │ ├── Setup.hs │ ├── TestFB.hs │ ├── haxl-facebook.cabal │ └── readme.md └── sql │ ├── Main.hs │ ├── Setup.hs │ ├── haxl-example.cabal │ └── readme.md ├── haxl.cabal ├── logo.png ├── logo.svg ├── readme.md ├── stack.yaml ├── stack.yaml.lock └── tests ├── AdoTests.hs ├── AllTests.hs ├── BadDataSource.hs ├── BatchTests.hs ├── Bench.hs ├── CoreTests.hs ├── DataCacheTest.hs ├── DataSourceDispatchTests.hs ├── ExampleDataSource.hs ├── ExceptionStackTests.hs ├── FBMain.hs ├── FullyAsyncTest.hs ├── LoadCache.hs ├── LoadCache.txt ├── MemoizationTests.hs ├── MockTAO.hs ├── MonadAsyncTest.hs ├── MonadBench.hs ├── OutgoneFetchesTests.hs ├── ParallelTests.hs ├── ProfileTests.hs ├── SleepDataSource.hs ├── StatsTests.hs ├── TestBadDataSource.hs ├── TestExampleDataSource.hs ├── TestMain.hs ├── TestTypes.hs ├── TestUtils.hs ├── WorkDataSource.hs └── WriteTests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci '--no-cabal-check' 'github' 'haxl.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250411 12 | # 13 | # REGENDATA ("0.19.20250411",["--no-cabal-check","github","haxl.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.10.1 32 | compilerKind: ghc 33 | compilerVersion: 9.10.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.8.2 37 | compilerKind: ghc 38 | compilerVersion: 9.8.2 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.6.6 42 | compilerKind: ghc 43 | compilerVersion: 9.6.6 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.4.8 47 | compilerKind: ghc 48 | compilerVersion: 9.4.8 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.2.8 52 | compilerKind: ghc 53 | compilerVersion: 9.2.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.0.2 57 | compilerKind: ghc 58 | compilerVersion: 9.0.2 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-8.10.7 62 | compilerKind: ghc 63 | compilerVersion: 8.10.7 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.8.4 67 | compilerKind: ghc 68 | compilerVersion: 8.8.4 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.6.5 72 | compilerKind: ghc 73 | compilerVersion: 8.6.5 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.4.4 77 | compilerKind: ghc 78 | compilerVersion: 8.4.4 79 | setup-method: ghcup 80 | allow-failure: false 81 | fail-fast: false 82 | steps: 83 | - name: apt-get install 84 | run: | 85 | apt-get update 86 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 87 | - name: Install GHCup 88 | run: | 89 | mkdir -p "$HOME/.ghcup/bin" 90 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 91 | chmod a+x "$HOME/.ghcup/bin/ghcup" 92 | - name: Install cabal-install 93 | run: | 94 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 95 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 96 | - name: Install GHC (GHCup) 97 | if: matrix.setup-method == 'ghcup' 98 | run: | 99 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 100 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 101 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 102 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 103 | echo "HC=$HC" >> "$GITHUB_ENV" 104 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 105 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 106 | env: 107 | HCKIND: ${{ matrix.compilerKind }} 108 | HCNAME: ${{ matrix.compiler }} 109 | HCVER: ${{ matrix.compilerVersion }} 110 | - name: Set PATH and environment variables 111 | run: | 112 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 113 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 114 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 115 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 116 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 117 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 118 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 119 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 120 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 121 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 122 | env: 123 | HCKIND: ${{ matrix.compilerKind }} 124 | HCNAME: ${{ matrix.compiler }} 125 | HCVER: ${{ matrix.compilerVersion }} 126 | - name: env 127 | run: | 128 | env 129 | - name: write cabal config 130 | run: | 131 | mkdir -p $CABAL_DIR 132 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 165 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 166 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 167 | rm -f cabal-plan.xz 168 | chmod a+x $HOME/.cabal/bin/cabal-plan 169 | cabal-plan --version 170 | - name: checkout 171 | uses: actions/checkout@v4 172 | with: 173 | path: source 174 | - name: initial cabal.project for sdist 175 | run: | 176 | touch cabal.project 177 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 178 | cat cabal.project 179 | - name: sdist 180 | run: | 181 | mkdir -p sdist 182 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 183 | - name: unpack 184 | run: | 185 | mkdir -p unpacked 186 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 187 | - name: generate cabal.project 188 | run: | 189 | PKGDIR_haxl="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/haxl-[0-9.]*')" 190 | echo "PKGDIR_haxl=${PKGDIR_haxl}" >> "$GITHUB_ENV" 191 | rm -f cabal.project cabal.project.local 192 | touch cabal.project 193 | touch cabal.project.local 194 | echo "packages: ${PKGDIR_haxl}" >> cabal.project 195 | echo "package haxl" >> cabal.project 196 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 197 | cat >> cabal.project <> cabal.project.local 200 | cat cabal.project 201 | cat cabal.project.local 202 | - name: dump install plan 203 | run: | 204 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 205 | cabal-plan 206 | - name: restore cache 207 | uses: actions/cache/restore@v4 208 | with: 209 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 210 | path: ~/.cabal/store 211 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 212 | - name: install dependencies 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 215 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 216 | - name: build w/o tests 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 219 | - name: build 220 | run: | 221 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 222 | - name: tests 223 | run: | 224 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 225 | - name: haddock 226 | run: | 227 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 228 | - name: unconstrained build 229 | run: | 230 | rm -f cabal.project.local 231 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 232 | - name: save cache 233 | if: always() 234 | uses: actions/cache/save@v4 235 | with: 236 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 237 | path: ~/.cabal/store 238 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | dist 4 | *~ 5 | .stack-work/ 6 | dist-newstyle/ 7 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as 6 | contributors and maintainers pledge to make participation in our project and 7 | our community a harassment-free experience for everyone, regardless of age, body 8 | size, disability, ethnicity, sex characteristics, gender identity and expression, 9 | level of experience, education, socio-economic status, nationality, personal 10 | appearance, race, religion, or sexual identity and orientation. 11 | 12 | ## Our Standards 13 | 14 | Examples of behavior that contributes to creating a positive environment 15 | include: 16 | 17 | * Using welcoming and inclusive language 18 | * Being respectful of differing viewpoints and experiences 19 | * Gracefully accepting constructive criticism 20 | * Focusing on what is best for the community 21 | * Showing empathy towards other community members 22 | 23 | Examples of unacceptable behavior by participants include: 24 | 25 | * The use of sexualized language or imagery and unwelcome sexual attention or 26 | advances 27 | * Trolling, insulting/derogatory comments, and personal or political attacks 28 | * Public or private harassment 29 | * Publishing others' private information, such as a physical or electronic 30 | address, without explicit permission 31 | * Other conduct which could reasonably be considered inappropriate in a 32 | professional setting 33 | 34 | ## Our Responsibilities 35 | 36 | Project maintainers are responsible for clarifying the standards of acceptable 37 | behavior and are expected to take appropriate and fair corrective action in 38 | response to any instances of unacceptable behavior. 39 | 40 | Project maintainers have the right and responsibility to remove, edit, or 41 | reject comments, commits, code, wiki edits, issues, and other contributions 42 | that are not aligned to this Code of Conduct, or to ban temporarily or 43 | permanently any contributor for other behaviors that they deem inappropriate, 44 | threatening, offensive, or harmful. 45 | 46 | ## Scope 47 | 48 | This Code of Conduct applies within all project spaces, and it also applies when 49 | an individual is representing the project or its community in public spaces. 50 | Examples of representing a project or community include using an official 51 | project e-mail address, posting via an official social media account, or acting 52 | as an appointed representative at an online or offline event. Representation of 53 | a project may be further defined and clarified by project maintainers. 54 | 55 | ## Enforcement 56 | 57 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 58 | reported by contacting the project team at . All 59 | complaints will be reviewed and investigated and will result in a response that 60 | is deemed necessary and appropriate to the circumstances. The project team is 61 | obligated to maintain confidentiality with regard to the reporter of an incident. 62 | Further details of specific enforcement policies may be posted separately. 63 | 64 | Project maintainers who do not follow or enforce the Code of Conduct in good 65 | faith may face temporary or permanent repercussions as determined by other 66 | members of the project's leadership. 67 | 68 | ## Attribution 69 | 70 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, 71 | available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html 72 | 73 | [homepage]: https://www.contributor-covenant.org 74 | 75 | For answers to common questions about this code of conduct, see 76 | https://www.contributor-covenant.org/faq 77 | 78 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Haxl 2 | We want to make contributing to this project as easy and transparent as 3 | possible. 4 | 5 | ## Contributor License Agreement ("CLA") 6 | In order to accept your pull request, we need you to submit a CLA. You only need 7 | to do this once to work on any of Facebook's open source projects. 8 | 9 | Complete your CLA here: 10 | 11 | ## Issues 12 | We use GitHub issues to track public bugs. Please ensure your description is 13 | clear and has sufficient instructions to be able to reproduce the issue. 14 | 15 | Facebook has a [bounty program](https://www.facebook.com/whitehat/) for the safe 16 | disclosure of security bugs. In those cases, please go through the process 17 | outlined on that page and do not file a public issue. 18 | 19 | ## Code of Conduct 20 | 21 | Facebook has adopted a Code of Conduct that we expect project participants to adhere to. Please [read the full text](https://code.facebook.com/codeofconduct) so that you can understand what actions will and will not be tolerated. 22 | 23 | ## License 24 | By contributing to Haxl, you agree that your contributions will be licensed 25 | under the LICENSE file in the root directory of this source tree. 26 | -------------------------------------------------------------------------------- /Haxl/Core.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | -- | Everything needed to define data sources and to invoke the 10 | -- engine. 11 | -- 12 | {-# LANGUAGE CPP #-} 13 | module Haxl.Core ( 14 | -- * The monad and operations 15 | GenHaxl (..), runHaxl, runHaxlWithWrites 16 | 17 | -- ** Env 18 | , Env(..), Caches, caches 19 | -- *** Operations in the monad 20 | , env, withEnv, withLabel 21 | -- *** Building the Env 22 | , initEnvWithData, initEnv, emptyEnv, sanitizeEnv 23 | -- *** Building the StateStore 24 | , StateStore, stateGet, stateSet, stateEmpty 25 | 26 | -- ** Writes inside the monad 27 | , tellWrite, tellWriteNoMemo 28 | 29 | -- ** Exceptions 30 | , throw, catch, catchIf, try, tryToHaxlException 31 | 32 | -- ** Data fetching and caching 33 | , dataFetch, uncachedRequest 34 | , cacheRequest, dupableCacheRequest, cacheResult, cacheResultWithShow 35 | , cachedComputation, preCacheComputation 36 | , dumpCacheAsHaskell 37 | 38 | -- ** Memoization 39 | , newMemo, newMemoWith, prepareMemo, runMemo 40 | , memo, memoUnique, memoize, memoize1, memoize2 41 | , memoFingerprint, MemoFingerprintKey(..) 42 | 43 | -- ** Conditionals 44 | , pAnd, pOr, unsafeChooseFirst 45 | 46 | -- ** Statistics 47 | , Stats(..) 48 | , FetchStats(..) 49 | , CallId 50 | , Microseconds 51 | , Timestamp 52 | , emptyStats 53 | , numFetches 54 | , ppStats 55 | , ppFetchStats 56 | , aggregateFetchBatches 57 | , Profile(..) 58 | , ProfileMemo(..) 59 | , ProfileFetch(..) 60 | , emptyProfile 61 | , ProfileLabel 62 | , ProfileKey 63 | , ProfileData(..) 64 | , emptyProfileData 65 | , AllocCount 66 | , LabelHitCount 67 | 68 | -- * Report flags 69 | , ReportFlag(..) 70 | , ReportFlags 71 | , defaultReportFlags 72 | , profilingReportFlags 73 | , setReportFlag 74 | , clearReportFlag 75 | , testReportFlag 76 | 77 | -- ** Flags 78 | , Flags(..) 79 | , defaultFlags 80 | , ifTrace 81 | , ifReport 82 | , ifProfiling 83 | 84 | -- * Building data sources 85 | , DataSource(..) 86 | , ShowP(..) 87 | , DataSourceName(..) 88 | , Request 89 | , BlockedFetch(..) 90 | , PerformFetch(..) 91 | , StateKey(..) 92 | , SchedulerHint(..) 93 | , FailureClassification(..) 94 | 95 | -- ** Result variables 96 | , ResultVar(..) 97 | , mkResultVar 98 | , putFailure 99 | , putResult 100 | , putSuccess 101 | , putResultFromChildThread 102 | , putResultWithStats 103 | , putResultWithStatsFromChildThread 104 | , DataSourceStats(..) 105 | 106 | -- ** Default fetch implementations 107 | , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease 108 | , backgroundFetchSeq, backgroundFetchPar 109 | , backgroundFetchAcquireRelease, backgroundFetchAcquireReleaseMVar 110 | , stubFetch 111 | , syncFetch 112 | 113 | -- ** Utilities 114 | , except 115 | , setError 116 | , getMapFromRCMap 117 | 118 | -- * Exceptions 119 | , module Haxl.Core.Exception 120 | 121 | -- * Recording the function callgraph 122 | , module Haxl.Core.CallGraph 123 | ) where 124 | 125 | import Haxl.Core.CallGraph 126 | import Haxl.Core.DataSource 127 | import Haxl.Core.Flags 128 | import Haxl.Core.Memo 129 | import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -}) 130 | import Haxl.Core.Fetch 131 | import Haxl.Core.Parallel 132 | import Haxl.Core.Profile 133 | import Haxl.Core.Run 134 | import Haxl.Core.Stats 135 | import Haxl.Core.Exception 136 | import Haxl.Core.RequestStore (getMapFromRCMap) 137 | import Haxl.Core.ShowP (ShowP(..)) 138 | import Haxl.Core.StateStore 139 | -------------------------------------------------------------------------------- /Haxl/Core/CallGraph.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE CPP #-} 11 | 12 | module Haxl.Core.CallGraph where 13 | 14 | import Data.Map.Strict (Map) 15 | import qualified Data.Map.Strict as Map 16 | #if __GLASGOW_HASKELL__ < 804 17 | import Data.Monoid 18 | #endif 19 | import Data.Text (Text) 20 | import qualified Data.Text as Text 21 | 22 | type ModuleName = Text 23 | 24 | -- | An unqualified function 25 | type Function = Text 26 | 27 | -- | A qualified function 28 | data QualFunction = QualFunction ModuleName Function deriving (Eq, Ord) 29 | 30 | instance Show QualFunction where 31 | show (QualFunction mn nm) = Text.unpack $ mn <> Text.pack "." <> nm 32 | 33 | -- | Represents an edge between a parent function which calls a child function 34 | -- in the call graph 35 | type FunctionCall = (QualFunction, QualFunction) 36 | 37 | -- | An edge list which represents the dependencies between function calls 38 | type CallGraph = ([FunctionCall], Map QualFunction Text) 39 | 40 | -- | Used as the root of all function calls 41 | mainFunction :: QualFunction 42 | mainFunction = QualFunction "MAIN" "main" 43 | 44 | emptyCallGraph :: CallGraph 45 | emptyCallGraph = ([], Map.empty) 46 | -------------------------------------------------------------------------------- /Haxl/Core/DataCache.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE ExistentialQuantification #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | -- | 15 | -- A cache mapping data requests to their results. This module is 16 | -- provided for access to Haxl internals only; most users should not 17 | -- need to import it. 18 | -- 19 | module Haxl.Core.DataCache 20 | ( DataCache(..) 21 | , SubCache(..) 22 | , emptyDataCache 23 | , filter 24 | , insert 25 | , insertNotShowable 26 | , insertWithShow 27 | , lookup 28 | , showCache 29 | , readCache 30 | ) where 31 | 32 | import Prelude hiding (lookup, filter) 33 | import Control.Exception 34 | import Unsafe.Coerce 35 | import Data.Typeable 36 | import Data.Hashable 37 | import qualified Data.HashTable.IO as H 38 | 39 | -- --------------------------------------------------------------------------- 40 | -- DataCache 41 | 42 | -- | A @'DataCache' res@ maps things of type @req a@ to @res a@, for 43 | -- any @req@ and @a@ provided @req a@ is an instance of 'Typeable'. In 44 | -- practice @req a@ will be a request type parameterised by its result. 45 | -- 46 | newtype DataCache res = DataCache (HashTable TypeRep (SubCache res)) 47 | 48 | -- | The implementation is a two-level map: the outer level maps the 49 | -- types of requests to 'SubCache', which maps actual requests to their 50 | -- results. So each 'SubCache' contains requests of the same type. 51 | -- This works well because we only have to store the dictionaries for 52 | -- 'Hashable' and 'Eq' once per request type. 53 | -- 54 | data SubCache res = 55 | forall req a . (Hashable (req a), Eq (req a)) => 56 | SubCache (req a -> String) (a -> String) !(HashTable (req a) (res a)) 57 | -- NB. the inner HashMap is strict, to avoid building up 58 | -- a chain of thunks during repeated insertions. 59 | 60 | type HashTable k v = H.BasicHashTable k v 61 | 62 | -- | A new, empty 'DataCache'. 63 | emptyDataCache :: IO (DataCache res) 64 | emptyDataCache = DataCache <$> H.new 65 | 66 | -- | Inserts a request-result pair into the 'DataCache'. 67 | insert 68 | :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a) 69 | => req a 70 | -- ^ Request 71 | -> res a 72 | -- ^ Result 73 | -> DataCache res 74 | -> IO () 75 | 76 | insert = insertWithShow show show 77 | 78 | -- | Inserts a request-result pair into the 'DataCache', without 79 | -- requiring Show instances of the request or the result. The cache 80 | -- cannot be subsequently used with `showCache`. 81 | insertNotShowable 82 | :: (Hashable (req a), Typeable (req a), Eq (req a)) 83 | => req a 84 | -- ^ Request 85 | -> res a 86 | -- ^ Result 87 | -> DataCache res 88 | -> IO () 89 | 90 | insertNotShowable = insertWithShow notShowable notShowable 91 | 92 | -- | Inserts a request-result pair into the 'DataCache', with the given 93 | -- functions used to show the request and result. 94 | insertWithShow 95 | :: (Hashable (req a), Typeable (req a), Eq (req a)) 96 | => (req a -> String) 97 | -- ^ Show function for request 98 | -> (a -> String) 99 | -- ^ Show function for result 100 | -> req a 101 | -- ^ Request 102 | -> res a 103 | -- ^ Result 104 | -> DataCache res 105 | -> IO () 106 | 107 | insertWithShow showRequest showResult request result (DataCache m) = 108 | H.mutateIO m (typeOf request) (mutate showRequest showResult request result) 109 | 110 | notShowable :: a 111 | notShowable = error "insertNotShowable" 112 | 113 | -- | A mutation function for mutateIO. If the key doesn't exist in the top-level 114 | -- cache, creates a new hashtable and inserts the request and result. 115 | -- If the key exists, insert the request and result into the existing subcache, 116 | -- replacing any existing mapping. 117 | mutate :: (Hashable (req a), Typeable (req a), Eq (req a)) 118 | => (req a -> String) 119 | -> (a -> String) 120 | -> req a 121 | -> res a 122 | -> Maybe (SubCache res) 123 | -> IO (Maybe (SubCache res), ()) 124 | mutate showRequest showResult request result Nothing = do 125 | newTable <- H.new 126 | H.insert newTable request result 127 | return (Just (SubCache showRequest showResult newTable), ()) 128 | mutate _ _ request result (Just sc@(SubCache _ _ oldTable)) = do 129 | H.insert oldTable (unsafeCoerce request) (unsafeCoerce result) 130 | return (Just sc, ()) 131 | 132 | -- | Looks up the cached result of a request. 133 | lookup 134 | :: Typeable (req a) 135 | => req a 136 | -- ^ Request 137 | -> DataCache res 138 | -> IO (Maybe (res a)) 139 | 140 | lookup req (DataCache m) = do 141 | mbRes <- H.lookup m (typeOf req) 142 | case mbRes of 143 | Nothing -> return Nothing 144 | Just (SubCache _ _ sc) -> 145 | unsafeCoerce (H.lookup sc (unsafeCoerce req)) 146 | 147 | filter 148 | :: forall res 149 | . (forall a. res a -> IO Bool) 150 | -> DataCache res 151 | -> IO (DataCache res) 152 | filter pred (DataCache cache) = do 153 | cacheList <- H.toList cache 154 | filteredCache <- filterSubCache `mapM` cacheList 155 | DataCache <$> H.fromList filteredCache 156 | where 157 | filterSubCache 158 | :: (TypeRep, SubCache res) 159 | -> IO (TypeRep, SubCache res) 160 | filterSubCache (ty, SubCache showReq showRes hm) = do 161 | filteredList <- H.foldM go [] hm 162 | filteredSC <- H.fromList filteredList 163 | return (ty, SubCache showReq showRes filteredSC) 164 | where 165 | go res (request, rvar) = do 166 | predRes <- pred rvar 167 | return $ if predRes then (request, rvar):res else res 168 | 169 | -- | Dumps the contents of the cache, with requests and responses 170 | -- converted to 'String's using the supplied show functions. The 171 | -- entries are grouped by 'TypeRep'. Note that this will fail if 172 | -- 'insertNotShowable' has been used to insert any entries. 173 | showCache 174 | :: forall res 175 | . DataCache res 176 | -> (forall a . res a -> IO (Maybe (Either SomeException a))) 177 | -> IO [(TypeRep, [(String, Either SomeException String)])] 178 | showCache (DataCache cache) readRes = H.foldM goSubCache [] cache 179 | where 180 | goSubCache 181 | :: [(TypeRep, [(String, Either SomeException String)])] 182 | -> (TypeRep, SubCache res) 183 | -> IO [(TypeRep, [(String, Either SomeException String)])] 184 | goSubCache res (ty, SubCache showReq showRes hm) = do 185 | subCacheResult <- H.foldM go [] hm 186 | return $ (ty, subCacheResult):res 187 | where 188 | go res (request, rvar) = do 189 | maybe_r <- readRes rvar 190 | return $ case maybe_r of 191 | Nothing -> res 192 | Just (Left e) -> (showReq request, Left e) : res 193 | Just (Right result) -> 194 | (showReq request, Right (showRes result)) : res 195 | 196 | -- | Dumps the contents of the cache responses to list 197 | readCache 198 | :: forall res ret 199 | . DataCache res 200 | -> (forall a . res a -> IO ret) 201 | -> IO [(TypeRep, [Either SomeException ret])] 202 | readCache (DataCache cache) readRes = H.foldM goSubCache [] cache 203 | where 204 | goSubCache 205 | :: [(TypeRep, [Either SomeException ret])] 206 | -> (TypeRep, SubCache res) 207 | -> IO [(TypeRep, [Either SomeException ret])] 208 | goSubCache res (ty, SubCache _showReq _showRes hm) = do 209 | subCacheResult <- H.foldM go [] hm 210 | return $ (ty, subCacheResult):res 211 | where 212 | go res (_request, rvar) = do 213 | r <- try $ readRes rvar 214 | return $ r : res 215 | -------------------------------------------------------------------------------- /Haxl/Core/Flags.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE BangPatterns #-} 10 | 11 | -- | 12 | -- The 'Flags' type and related functions. This module is provided 13 | -- for access to Haxl internals only; most users should import 14 | -- "Haxl.Core" instead. 15 | -- 16 | module Haxl.Core.Flags 17 | ( 18 | -- * Report flags 19 | ReportFlag(..) 20 | , ReportFlags 21 | , defaultReportFlags 22 | , profilingReportFlags 23 | , setReportFlag 24 | , clearReportFlag 25 | , testReportFlag 26 | -- * Flags 27 | , Flags(..) 28 | , defaultFlags 29 | , ifTrace 30 | , ifReport 31 | , ifProfiling 32 | ) where 33 | 34 | import Control.Monad 35 | import Data.Bits 36 | import Data.List (foldl') 37 | import Text.Printf (printf) 38 | 39 | -- --------------------------------------------------------------------------- 40 | -- ReportFlags 41 | data ReportFlag 42 | = ReportOutgoneFetches -- ^ outgone fetches, for debugging eg: timeouts 43 | | ReportFetchStats -- ^ data fetch stats & errors 44 | | ReportProfiling -- ^ enabling label stack and profiling 45 | | ReportExceptionLabelStack -- ^ include label stack in HaxlException 46 | | ReportFetchStack -- ^ log cost-center stack traces of dataFetch calls 47 | deriving (Bounded, Enum, Eq, Show) 48 | 49 | profilingDependents :: [ReportFlag] 50 | profilingDependents = 51 | [ ReportExceptionLabelStack 52 | , ReportFetchStack 53 | ] 54 | 55 | newtype ReportFlags = ReportFlags Int 56 | 57 | instance Show ReportFlags where 58 | show (ReportFlags fs) = printf "%0*b" (fromEnum maxReportFlag + 1) fs 59 | where 60 | maxReportFlag = maxBound :: ReportFlag 61 | 62 | defaultReportFlags :: ReportFlags 63 | defaultReportFlags = ReportFlags 0 64 | 65 | profilingReportFlags :: ReportFlags 66 | profilingReportFlags = foldl' (flip setReportFlag) defaultReportFlags 67 | [ ReportOutgoneFetches 68 | , ReportFetchStats 69 | , ReportProfiling 70 | ] 71 | 72 | setReportFlag :: ReportFlag -> ReportFlags -> ReportFlags 73 | setReportFlag f (ReportFlags fs) = 74 | ReportFlags $ setDependencies $ setBit fs $ fromEnum f 75 | where 76 | setDependencies 77 | | f `elem` profilingDependents = flip setBit $ fromEnum ReportProfiling 78 | | otherwise = id 79 | 80 | clearReportFlag :: ReportFlag -> ReportFlags -> ReportFlags 81 | clearReportFlag f (ReportFlags fs) = 82 | ReportFlags $ clearDependents $ clearBit fs $ fromEnum f 83 | where 84 | clearDependents z = case f of 85 | ReportProfiling -> foldl' clearBit z $ map fromEnum profilingDependents 86 | _ -> z 87 | 88 | {-# INLINE testReportFlag #-} 89 | testReportFlag :: ReportFlag -> ReportFlags -> Bool 90 | testReportFlag !f (ReportFlags !fs) = testBit fs $ fromEnum f 91 | 92 | -- --------------------------------------------------------------------------- 93 | -- Flags 94 | 95 | -- | Flags that control the operation of the engine. 96 | data Flags = Flags 97 | { trace :: {-# UNPACK #-} !Int 98 | -- ^ Tracing level (0 = quiet, 3 = very verbose). 99 | , report :: {-# UNPACK #-} !ReportFlags 100 | -- ^ Report flags 101 | , caching :: {-# UNPACK #-} !Int 102 | -- ^ Non-zero if caching is enabled. If caching is disabled, then 103 | -- we still do batching and de-duplication, but do not cache 104 | -- results. 105 | , recording :: {-# UNPACK #-} !Int 106 | -- ^ Non-zero if recording is enabled. This allows tests to record cache 107 | -- calls for datasources by making uncachedRequest behave like dataFetch 108 | } 109 | 110 | defaultFlags :: Flags 111 | defaultFlags = Flags 112 | { trace = 0 113 | , report = defaultReportFlags 114 | , caching = 1 115 | , recording = 0 116 | } 117 | 118 | -- | Runs an action if the tracing level is above the given threshold. 119 | ifTrace :: Monad m => Flags -> Int -> m a -> m () 120 | ifTrace flags i = when (trace flags >= i) . void 121 | 122 | -- | Runs an action if the ReportFlag is set. 123 | ifReport :: Monad m => Flags -> ReportFlag -> m a -> m () 124 | ifReport flags i = when (testReportFlag i $ report flags) . void 125 | 126 | ifProfiling :: Monad m => Flags -> m a -> m () 127 | ifProfiling flags = ifReport flags ReportProfiling 128 | -------------------------------------------------------------------------------- /Haxl/Core/Parallel.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE BangPatterns #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | 14 | -- | Psuedo-parallel operations. Most users should import "Haxl.Core" 15 | -- instead. 16 | -- 17 | module Haxl.Core.Parallel 18 | ( -- * Parallel operations 19 | biselect 20 | , pAnd 21 | , pOr 22 | , unsafeChooseFirst 23 | ) where 24 | 25 | import Haxl.Core.Monad hiding (catch, throw) 26 | import Haxl.Core.Exception 27 | 28 | import Control.Exception (throw) 29 | 30 | -- ----------------------------------------------------------------------------- 31 | -- Parallel operations 32 | 33 | -- Bind more tightly than .&&, .|| 34 | infixr 5 `pAnd` 35 | infixr 4 `pOr` 36 | 37 | 38 | biselect :: GenHaxl u w (Either a b) 39 | -> GenHaxl u w (Either a c) 40 | -> GenHaxl u w (Either a (b,c)) 41 | biselect haxla haxlb = biselect_opt id id Left Right haxla haxlb 42 | 43 | {-# INLINE biselect_opt #-} 44 | biselect_opt :: (l -> Either a b) 45 | -> (r -> Either a c) 46 | -> (a -> t) 47 | -> ((b,c) -> t) 48 | -> GenHaxl u w l 49 | -> GenHaxl u w r 50 | -> GenHaxl u w t 51 | biselect_opt discrimA discrimB left right haxla haxlb = 52 | let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env -> do 53 | ra <- haxla env 54 | case ra of 55 | Done ea -> 56 | case discrimA ea of 57 | Left a -> return (Done (left a)) 58 | Right b -> do 59 | rb <- haxlb env 60 | case rb of 61 | Done eb -> 62 | case discrimB eb of 63 | Left a -> return (Done (left a)) 64 | Right c -> return (Done (right (b,c))) 65 | Throw e -> return (Throw e) 66 | Blocked ib haxlb' -> 67 | return (Blocked ib 68 | (haxlb' :>>= \b' -> go_right b b')) 69 | Throw e -> return (Throw e) 70 | Blocked ia haxla' -> do 71 | rb <- haxlb env 72 | case rb of 73 | Done eb -> 74 | case discrimB eb of 75 | Left a -> return (Done (left a)) 76 | Right c -> 77 | return (Blocked ia 78 | (haxla' :>>= \a' -> go_left a' c)) 79 | Throw e -> return (Throw e) 80 | Blocked ib haxlb' -> do 81 | i <- newIVar 82 | addJob env (return ()) i ia 83 | addJob env (return ()) i ib 84 | return (Blocked i (Cont (go (toHaxl haxla') (toHaxl haxlb')))) 85 | -- The code above makes sure that the computation 86 | -- wakes up whenever either 'ia' or 'ib' is filled. 87 | -- The ivar 'i' is used as a synchronisation point 88 | -- for the whole computation, and we make sure that 89 | -- whenever 'ia' or 'ib' are filled in then 'i' will 90 | -- also be filled. 91 | 92 | go_right b eb = 93 | case discrimB eb of 94 | Left a -> return (left a) 95 | Right c -> return (right (b,c)) 96 | go_left ea c = 97 | case discrimA ea of 98 | Left a -> return (left a) 99 | Right b -> return (right (b,c)) 100 | in go haxla haxlb 101 | 102 | -- | Parallel version of '(.||)'. Both arguments are evaluated in 103 | -- parallel, and if either returns 'True' then the other is 104 | -- not evaluated any further. 105 | -- 106 | -- WARNING: exceptions may be unpredictable when using 'pOr'. If one 107 | -- argument returns 'True' before the other completes, then 'pOr' 108 | -- returns 'True' immediately, ignoring a possible exception that 109 | -- the other argument may have produced if it had been allowed to 110 | -- complete. 111 | pOr :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool 112 | pOr x y = biselect_opt discrim discrim left right x y 113 | where 114 | discrim True = Left () 115 | discrim False = Right () 116 | left _ = True 117 | right _ = False 118 | 119 | -- | Parallel version of '(.&&)'. Both arguments are evaluated in 120 | -- parallel, and if either returns 'False' then the other is 121 | -- not evaluated any further. 122 | -- 123 | -- WARNING: exceptions may be unpredictable when using 'pAnd'. If one 124 | -- argument returns 'False' before the other completes, then 'pAnd' 125 | -- returns 'False' immediately, ignoring a possible exception that 126 | -- the other argument may have produced if it had been allowed to 127 | -- complete. 128 | pAnd :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool 129 | pAnd x y = biselect_opt discrim discrim left right x y 130 | where 131 | discrim False = Left () 132 | discrim True = Right () 133 | left _ = False 134 | right _ = True 135 | 136 | -- | This function takes two haxl computations as input, and returns the 137 | -- output of whichever computation finished first. This is clearly 138 | -- non-deterministic in its output and exception behavior, be careful when 139 | -- using it. 140 | unsafeChooseFirst 141 | :: GenHaxl u w a 142 | -> GenHaxl u w b 143 | -> GenHaxl u w (Either a b) 144 | unsafeChooseFirst x y = biselect_opt discrimx discrimy id right x y 145 | where 146 | discrimx :: a -> Either (Either a b) () 147 | discrimx a = Left (Left a) 148 | 149 | discrimy :: b -> Either (Either a b) () 150 | discrimy b = Left (Right b) 151 | 152 | right _ = throw $ CriticalError 153 | "unsafeChooseFirst: We should never have a 'Right ()'" 154 | -------------------------------------------------------------------------------- /Haxl/Core/Profile.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE BangPatterns #-} 10 | {-# LANGUAGE CPP #-} 11 | {-# LANGUAGE MagicHash #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | 17 | -- | Implementation of lightweight profiling. Most users should 18 | -- import "Haxl.Core" instead. 19 | -- 20 | module Haxl.Core.Profile 21 | ( withLabel 22 | , withFingerprintLabel 23 | , addProfileFetch 24 | , incrementMemoHitCounterFor 25 | , collectProfileData 26 | , profileCont 27 | ) where 28 | 29 | import Data.IORef 30 | import Data.Hashable 31 | import Data.List.NonEmpty (NonEmpty(..), (<|)) 32 | #if __GLASGOW_HASKELL__ < 804 33 | import Data.Monoid 34 | #endif 35 | import Data.Typeable 36 | import qualified Data.HashMap.Strict as HashMap 37 | import GHC.Exts 38 | import qualified Data.Text as Text 39 | import Haxl.Core.DataSource 40 | import Haxl.Core.Flags 41 | import Haxl.Core.Stats 42 | import Haxl.Core.Monad 43 | 44 | -- ----------------------------------------------------------------------------- 45 | -- Profiling 46 | 47 | -- | Label a computation so profiling data is attributed to the label. 48 | withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a 49 | withLabel l (GenHaxl m) = GenHaxl $ \env -> 50 | if not $ testReportFlag ReportProfiling $ report $ flags env 51 | then m env 52 | else collectProfileData l m env 53 | 54 | -- | Label a computation so profiling data is attributed to the label. 55 | -- Intended only for internal use by 'memoFingerprint'. 56 | withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a 57 | withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env -> 58 | if not $ testReportFlag ReportProfiling $ report $ flags env 59 | then m env 60 | else collectProfileData 61 | (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr) 62 | m env 63 | 64 | -- | Collect profiling data and attribute it to given label. 65 | collectProfileData 66 | :: ProfileLabel 67 | -> (Env u w -> IO (Result u w a)) 68 | -> Env u w 69 | -> IO (Result u w a) 70 | collectProfileData l m env = do 71 | let ProfileCurrent prevProfKey (prevProfLabel :| _) = profCurrent env 72 | if prevProfLabel == l 73 | then 74 | -- do not add a new label if we are recursing 75 | m env 76 | else do 77 | key <- atomicModifyIORef' (profRef env) $ \p -> 78 | case HashMap.lookup (l, prevProfKey) (profileTree p) of 79 | Just k -> (p, k) 80 | Nothing -> (p 81 | { profileTree = HashMap.insert 82 | (l, prevProfKey) 83 | (profileNextKey p) 84 | (profileTree p) 85 | , profileNextKey = profileNextKey p + 1 }, profileNextKey p) 86 | runProfileData l key m False env 87 | {-# INLINE collectProfileData #-} 88 | 89 | runProfileData 90 | :: ProfileLabel 91 | -> ProfileKey 92 | -> (Env u w -> IO (Result u w a)) 93 | -> Bool 94 | -> Env u w 95 | -> IO (Result u w a) 96 | runProfileData l key m isCont env = do 97 | t0 <- getTimestamp 98 | a0 <- getAllocationCounter 99 | let 100 | ProfileCurrent caller stack = profCurrent env 101 | nextCurrent = ProfileCurrent 102 | { profCurrentKey = key 103 | , profLabelStack = l <| stack 104 | } 105 | runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True 106 | 107 | r <- m env{profCurrent=nextCurrent} -- what if it throws? 108 | 109 | -- Make the result strict in Done/Throw so that if the user code 110 | -- returns (force a), the force is evaluated *inside* the profile. 111 | result <- case r of 112 | Done !a -> return (Done a) 113 | Throw !e -> return (Throw e) 114 | Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k))) 115 | 116 | a1 <- getAllocationCounter 117 | t1 <- getTimestamp 118 | 119 | -- caller might not be the actual caller of this function 120 | -- for example MAIN may be continuing a function from the middle of the stack. 121 | -- But this is what we want as we need to account for allocations. 122 | -- So do not be tempted to pass through prevProfKey (from collectProfileData) 123 | -- which is the original caller 124 | modifyProfileData env key caller (a0 - a1) (t1-t0) (if isCont then 0 else 1) 125 | 126 | -- So we do not count the allocation overhead of modifyProfileData 127 | setAllocationCounter a1 128 | return result 129 | {-# INLINE runProfileData #-} 130 | 131 | modifyProfileData 132 | :: Env u w 133 | -> ProfileKey 134 | -> ProfileKey 135 | -> AllocCount 136 | -> Microseconds 137 | -> LabelHitCount 138 | -> IO () 139 | modifyProfileData env key caller allocs t labelIncrement = do 140 | modifyIORef' (profRef env) $ \ p -> 141 | p { profile = 142 | HashMap.insertWith updEntry key newEntry . 143 | HashMap.insertWith updCaller caller newCaller $ 144 | profile p } 145 | where newEntry = 146 | emptyProfileData 147 | { profileAllocs = allocs 148 | , profileLabelHits = labelIncrement 149 | , profileTime = t 150 | } 151 | updEntry _ old = 152 | old 153 | { profileAllocs = profileAllocs old + allocs 154 | , profileLabelHits = profileLabelHits old + labelIncrement 155 | , profileTime = profileTime old + t 156 | } 157 | -- subtract allocs/time from caller, so they are not double counted 158 | -- we don't know the caller's caller, but it will get set on 159 | -- the way back out, so an empty hashset is fine for now 160 | newCaller = 161 | emptyProfileData { profileAllocs = -allocs 162 | , profileTime = -t 163 | } 164 | updCaller _ old = 165 | old { profileAllocs = profileAllocs old - allocs 166 | , profileTime = profileTime old - t 167 | } 168 | 169 | 170 | -- Like collectProfileData, but intended to be run from the scheduler. 171 | -- 172 | -- * doesn't add a dependency (the original withLabel did this) 173 | -- 174 | -- * doesn't subtract allocs from the caller (we're evaluating this 175 | -- cont from the top level, so we don't need this) 176 | -- 177 | -- * doesn't wrap a Blocked continuation in withLabel (the scheduler 178 | -- will call profileCont the next time this cont runs) 179 | -- 180 | profileCont 181 | :: (Env u w -> IO (Result u w a)) 182 | -> Env u w 183 | -> IO (Result u w a) 184 | profileCont m env = do 185 | t0 <- getTimestamp 186 | a0 <- getAllocationCounter 187 | r <- m env 188 | a1 <- getAllocationCounter 189 | t1 <- getTimestamp 190 | let 191 | allocs = a0 - a1 192 | t = t1 - t0 193 | newEntry = emptyProfileData 194 | { profileAllocs = allocs 195 | , profileTime = t 196 | } 197 | updEntry _ old = old 198 | { profileAllocs = profileAllocs old + allocs 199 | , profileTime = profileTime old + t 200 | } 201 | profKey = profCurrentKey (profCurrent env) 202 | modifyIORef' (profRef env) $ \ p -> 203 | p { profile = 204 | HashMap.insertWith updEntry profKey newEntry $ 205 | profile p } 206 | -- So we do not count the allocation overhead of modifyProfileData 207 | setAllocationCounter a1 208 | return r 209 | {-# INLINE profileCont #-} 210 | 211 | incrementMemoHitCounterFor :: Env u w -> CallId -> Bool -> IO () 212 | incrementMemoHitCounterFor env callId wasCached = do 213 | modifyIORef' (profRef env) $ \p -> p { 214 | profile = HashMap.insertWith 215 | upd 216 | (profCurrentKey $ profCurrent env) 217 | (emptyProfileData { profileMemos = [val] }) 218 | (profile p) 219 | } 220 | where 221 | val = ProfileMemo callId wasCached 222 | upd _ old = old { profileMemos = val : profileMemos old } 223 | 224 | {-# NOINLINE addProfileFetch #-} 225 | addProfileFetch 226 | :: forall r u w a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a)) 227 | => Env u w -> r a -> CallId -> Bool -> IO () 228 | addProfileFetch env _req cid wasCached = do 229 | c <- getAllocationCounter 230 | let (ProfileCurrent profKey _) = profCurrent env 231 | modifyIORef' (profRef env) $ \ p -> 232 | let 233 | val = ProfileFetch cid (memoKey env) wasCached 234 | upd _ old = old { profileFetches = val : profileFetches old } 235 | 236 | in p { profile = 237 | HashMap.insertWith 238 | upd 239 | profKey 240 | (emptyProfileData { profileFetches = [val] }) 241 | (profile p) 242 | } 243 | -- So we do not count the allocation overhead of addProfileFetch 244 | setAllocationCounter c 245 | -------------------------------------------------------------------------------- /Haxl/Core/RequestStore.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE ExistentialQuantification #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE BangPatterns #-} 14 | -- | Bucketing requests by 'DataSource'. 15 | -- 16 | -- When a request is issued by the client via 'dataFetch', it is placed 17 | -- in the 'RequestStore'. When we are ready to fetch the current batch 18 | -- of requests, the 'contents' operation extracts the fetches, bucketed 19 | -- by 'DataSource'. 20 | -- 21 | -- This module is provided for access to Haxl internals only; most 22 | -- users should not need to import it. 23 | -- 24 | module Haxl.Core.RequestStore 25 | ( BlockedFetches(..) 26 | , BlockedFetchInternal(..) 27 | , RequestStore 28 | , isEmpty 29 | , noRequests 30 | , addRequest 31 | , contents 32 | , getSize 33 | , ReqCountMap(..) 34 | , emptyReqCounts 35 | , filterRCMap 36 | , getMapFromRCMap 37 | , getSummaryMapFromRCMap 38 | , addToCountMap 39 | , subFromCountMap 40 | ) where 41 | 42 | import Haxl.Core.DataSource 43 | import Haxl.Core.Stats 44 | import Data.Map (Map) 45 | import qualified Data.HashMap.Strict as HashMap 46 | import qualified Data.Map.Strict as Map 47 | import Data.Proxy 48 | import Data.Text (Text) 49 | import Data.Kind (Type) 50 | import Data.Typeable 51 | import Unsafe.Coerce 52 | 53 | -- | A container for multiple 'BlockedFetch' objects. 54 | newtype RequestStore u = RequestStore (Map TypeRep (BlockedFetches u)) 55 | -- Since we don't know which data sources we will be using, the store 56 | -- is dynamically-typed. It maps the TypeRep of the request to the 57 | -- 'BlockedFetches' for that 'DataSource'. 58 | 59 | newtype BlockedFetchInternal = BlockedFetchInternal CallId 60 | 61 | -- | A batch of 'BlockedFetch' objects for a single 'DataSource' 62 | data BlockedFetches u = 63 | forall r. (DataSource u r) => 64 | BlockedFetches [BlockedFetch r] [BlockedFetchInternal] 65 | 66 | isEmpty :: RequestStore u -> Bool 67 | isEmpty (RequestStore m) = Map.null m 68 | 69 | -- | A new empty 'RequestStore'. 70 | noRequests :: RequestStore u 71 | noRequests = RequestStore Map.empty 72 | 73 | -- | Adds a 'BlockedFetch' to a 'RequestStore'. 74 | addRequest 75 | :: forall u r. (DataSource u r) 76 | => BlockedFetch r -> BlockedFetchInternal -> RequestStore u -> RequestStore u 77 | addRequest bf bfi (RequestStore m) = 78 | RequestStore $ Map.insertWith combine ty (BlockedFetches [bf] [bfi]) m 79 | where 80 | combine :: BlockedFetches u -> BlockedFetches u -> BlockedFetches u 81 | combine _ (BlockedFetches bfs bfis) 82 | | typeOf1 (getR bfs) == ty = BlockedFetches (unsafeCoerce bf:bfs) (bfi:bfis) 83 | | otherwise = error "RequestStore.insert" 84 | -- the dynamic type check here should be unnecessary, but if 85 | -- there are bugs in `Typeable` or `Map` then we'll get an 86 | -- error instead of a crash. The overhead is negligible. 87 | 88 | -- a type conversion only, so we can get the type of the reqeusts from 89 | -- the list of BlockedFetch. 90 | getR :: [BlockedFetch r1] -> r1 a 91 | getR _ = undefined 92 | 93 | -- The TypeRep of requests for this data source 94 | ty :: TypeRep 95 | !ty = typeOf1 (undefined :: r a) 96 | 97 | -- | Retrieves the whole contents of the 'RequestStore'. 98 | contents :: RequestStore u -> [BlockedFetches u] 99 | contents (RequestStore m) = Map.elems m 100 | 101 | getSize :: RequestStore u -> Int 102 | getSize (RequestStore m) = Map.size m 103 | 104 | -- A counter to keep track of outgone requests. Entries are added to this 105 | -- map as we send requests to datasources, and removed as these fetches 106 | -- are completed. 107 | -- This is a 2 level map: the 1st level stores requests for a particular 108 | -- datasource, the 2nd level stores count of requests per type. 109 | newtype ReqCountMap = ReqCountMap (Map Text (Map TypeRep Int)) 110 | deriving (Show) 111 | 112 | emptyReqCounts :: ReqCountMap 113 | emptyReqCounts = ReqCountMap Map.empty 114 | 115 | addToCountMap 116 | :: forall (r :: Type -> Type). (DataSourceName r, Typeable r) 117 | => Proxy r 118 | -> Int -- type and number of requests 119 | -> ReqCountMap 120 | -> ReqCountMap 121 | addToCountMap = updateCountMap (+) 122 | 123 | subFromCountMap 124 | :: forall (r :: Type -> Type). (DataSourceName r, Typeable r) 125 | => Proxy r 126 | -> Int -- type and number of requests 127 | -> ReqCountMap 128 | -> ReqCountMap 129 | subFromCountMap = updateCountMap (-) 130 | 131 | updateCountMap 132 | :: forall (r :: Type -> Type). (DataSourceName r, Typeable r) 133 | => (Int -> Int -> Int) 134 | -> Proxy r 135 | -> Int -- type and number of requests 136 | -> ReqCountMap 137 | -> ReqCountMap 138 | updateCountMap op p n (ReqCountMap m) = ReqCountMap $ Map.insertWith 139 | (flip (Map.unionWith op)) -- flip is important as "op" is not commutative 140 | (dataSourceName p) (Map.singleton ty n) 141 | m 142 | where 143 | -- The TypeRep of requests for this data source 144 | -- The way this is implemented, all elements in the 2nd level map will be 145 | -- mapped to the same key, as all requests to a datasource have the same 146 | -- "type". It will be more beneficial to be able to instead map requests 147 | -- to their names (ie, data constructor) - but there's no cheap way of doing 148 | -- that. 149 | ty :: TypeRep 150 | !ty = typeOf1 (undefined :: r a) 151 | 152 | -- Filter all keys with 0 fetches. Since ReqCountMap is a 2-level map, we need 153 | -- nested filter operations. 154 | filterRCMap :: ReqCountMap -> ReqCountMap 155 | filterRCMap (ReqCountMap m) = ReqCountMap $ 156 | Map.filter ((> 0) . Map.size) (Map.filter (> 0) <$> m) 157 | 158 | -- Filters the ReqCountMap by default 159 | getMapFromRCMap :: ReqCountMap -> Map Text (Map TypeRep Int) 160 | getMapFromRCMap r 161 | | ReqCountMap m <- filterRCMap r = m 162 | 163 | getSummaryMapFromRCMap :: ReqCountMap -> HashMap.HashMap Text Int 164 | getSummaryMapFromRCMap (ReqCountMap m) = HashMap.fromList 165 | [ (k, s) 166 | | (k, v) <- Map.toList m 167 | , not $ Map.null v 168 | , let s = sum $ Map.elems v 169 | , s > 0 170 | ] 171 | -------------------------------------------------------------------------------- /Haxl/Core/ShowP.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | -- | 10 | -- Most users should import "Haxl.Core" instead of importing this 11 | -- module directly. 12 | -- 13 | module Haxl.Core.ShowP 14 | ( ShowP(..) 15 | ) where 16 | 17 | -- | A class of type constructors for which we can show all 18 | -- parameterizations. 19 | class ShowP f where 20 | showp :: f a -> String 21 | -------------------------------------------------------------------------------- /Haxl/Core/StateStore.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE ExistentialQuantification #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE CPP #-} 14 | 15 | -- | 16 | -- Most users should import "Haxl.Core" instead of importing this 17 | -- module directly. 18 | -- 19 | module Haxl.Core.StateStore 20 | ( StateKey(..) 21 | , StateStore 22 | , stateGet 23 | , stateSet 24 | , stateEmpty 25 | ) where 26 | 27 | import Data.Map (Map) 28 | import Data.Kind (Type) 29 | import qualified Data.Map.Strict as Map 30 | #if __GLASGOW_HASKELL__ < 804 31 | import Data.Monoid 32 | #endif 33 | import Data.Typeable 34 | import Unsafe.Coerce 35 | 36 | -- | 'StateKey' maps one type to another type. A type that is an 37 | -- instance of 'StateKey' can store and retrieve information from a 38 | -- 'StateStore'. 39 | -- 40 | class Typeable f => StateKey (f :: Type -> Type) where 41 | data State f 42 | 43 | -- | We default this to typeOf1, but if f is itself a complex type that is 44 | -- already applied to some paramaters, we want to be able to use the same 45 | -- state by using typeOf2, etc 46 | getStateType :: Proxy f -> TypeRep 47 | getStateType = typeRep 48 | 49 | -- | The 'StateStore' maps a 'StateKey' to the 'State' for that type. 50 | newtype StateStore = StateStore (Map TypeRep StateStoreData) 51 | 52 | #if __GLASGOW_HASKELL__ >= 804 53 | instance Semigroup StateStore where 54 | -- Left-biased union 55 | StateStore m1 <> StateStore m2 = StateStore $ m1 <> m2 56 | #endif 57 | 58 | instance Monoid StateStore where 59 | mempty = stateEmpty 60 | #if __GLASGOW_HASKELL__ < 804 61 | mappend (StateStore m1) (StateStore m2) = StateStore $ m1 <> m2 62 | #endif 63 | 64 | -- | Encapsulates the type of 'StateStore' data so we can have a 65 | -- heterogeneous collection. 66 | data StateStoreData = forall f. StateKey f => StateStoreData (State f) 67 | 68 | -- | A `StateStore` with no entries. 69 | stateEmpty :: StateStore 70 | stateEmpty = StateStore Map.empty 71 | 72 | -- | Inserts a `State` in the `StateStore` container. 73 | stateSet :: forall f . StateKey f => State f -> StateStore -> StateStore 74 | stateSet st (StateStore m) = 75 | StateStore (Map.insert (getStateType (Proxy :: Proxy f)) (StateStoreData st) m) 76 | 77 | -- | Retrieves a `State` from the `StateStore` container. 78 | stateGet :: forall r . StateKey r => StateStore -> Maybe (State r) 79 | stateGet (StateStore m) = 80 | case Map.lookup ty m of 81 | Nothing -> Nothing 82 | Just (StateStoreData (st :: State f)) 83 | | getStateType (Proxy :: Proxy f) == ty -> Just (unsafeCoerce st) 84 | | otherwise -> Nothing 85 | -- the dynamic type check here should be unnecessary, but if 86 | -- there are bugs in `Typeable` or `Map` then we'll get an 87 | -- error instead of a crash. The overhead is a few percent. 88 | where 89 | ty = getStateType (Proxy :: Proxy r) 90 | -------------------------------------------------------------------------------- /Haxl/Core/Util.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | -- | Internal utilities only. 10 | -- 11 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 12 | module Haxl.Core.Util 13 | ( atomicallyOnBlocking 14 | , compose 15 | , textShow 16 | , trace_ 17 | ) where 18 | 19 | import Data.Text (Text) 20 | import Debug.Trace (trace) 21 | import qualified Data.Text as Text 22 | 23 | import Control.Concurrent.STM 24 | import Control.Exception 25 | 26 | atomicallyOnBlocking :: Exception e => e -> STM a -> IO a 27 | atomicallyOnBlocking e stm = 28 | catch (atomically stm) 29 | (\BlockedIndefinitelyOnSTM -> throw e) 30 | 31 | -- | Composes a list of endofunctions. 32 | compose :: [a -> a] -> a -> a 33 | compose = foldr (.) id 34 | 35 | textShow :: (Show a) => a -> Text 36 | textShow = Text.pack . show 37 | 38 | -- | This function can be used to trace a bunch of lines to stdout when 39 | -- debugging haxl core. 40 | trace_ :: String -> a -> a 41 | trace_ _ = id 42 | --trace_ = Debug.Trace.trace 43 | -------------------------------------------------------------------------------- /Haxl/DataSource/ConcurrentIO.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE StandaloneDeriving #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | 18 | -- | 19 | -- A generic Haxl datasource for performing arbitrary IO concurrently. 20 | -- Every IO operation will be performed in a separate thread. 21 | -- You can use this with any kind of IO, but each different operation 22 | -- requires an instance of the 'ConcurrentIO' class. 23 | -- 24 | -- For example, to make a concurrent sleep operation: 25 | -- 26 | -- > sleep :: Int -> GenHaxl u w Int 27 | -- > sleep n = dataFetch (Sleep n) 28 | -- > 29 | -- > data Sleep 30 | -- > instance ConcurrentIO Sleep where 31 | -- > data ConcurrentIOReq Sleep a where 32 | -- > Sleep :: Int -> ConcurrentIOReq Sleep Int 33 | -- > 34 | -- > performIO (Sleep n) = threadDelay (n*1000) >> return n 35 | -- > 36 | -- > deriving instance Eq (ConcurrentIOReq Sleep a) 37 | -- > deriving instance Show (ConcurrentIOReq Sleep a) 38 | -- > 39 | -- > instance ShowP (ConcurrentIOReq Sleep) where showp = show 40 | -- > 41 | -- > instance Hashable (ConcurrentIOReq Sleep a) where 42 | -- > hashWithSalt s (Sleep n) = hashWithSalt s n 43 | -- 44 | -- Note that you can have any number of constructors in your 45 | -- ConcurrentIOReq GADT, so most of the boilerplate only needs to be 46 | -- written once. 47 | 48 | module Haxl.DataSource.ConcurrentIO 49 | ( mkConcurrentIOState 50 | , ConcurrentIO(..) 51 | ) where 52 | 53 | import Control.Concurrent 54 | import Control.Monad 55 | import qualified Data.Text as Text 56 | import Data.Typeable 57 | 58 | import Haxl.Core 59 | 60 | class ConcurrentIO tag where 61 | data ConcurrentIOReq tag a 62 | performIO :: ConcurrentIOReq tag a -> IO a 63 | 64 | deriving instance Typeable ConcurrentIOReq -- not needed by GHC 7.10 and later 65 | 66 | instance (Typeable tag) => StateKey (ConcurrentIOReq tag) where 67 | data State (ConcurrentIOReq tag) = ConcurrentIOState 68 | getStateType _ = typeRep (Proxy :: Proxy ConcurrentIOReq) 69 | 70 | mkConcurrentIOState :: IO (State (ConcurrentIOReq ())) 71 | mkConcurrentIOState = return ConcurrentIOState 72 | 73 | instance Typeable tag => DataSourceName (ConcurrentIOReq tag) where 74 | dataSourceName _ = 75 | Text.pack (show (typeRepTyCon (typeRep (Proxy :: Proxy tag)))) 76 | 77 | instance 78 | (Typeable tag, ShowP (ConcurrentIOReq tag), ConcurrentIO tag) 79 | => DataSource u (ConcurrentIOReq tag) 80 | where 81 | fetch _state _flags _u = BackgroundFetch $ \bfs -> do 82 | forM_ bfs $ \(BlockedFetch req rv) -> 83 | forkFinally (performIO req) (putResultFromChildThread rv) 84 | -------------------------------------------------------------------------------- /Haxl/Prelude.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# OPTIONS_GHC -fno-warn-orphans #-} 14 | 15 | -- | Support for using Haxl as a DSL. This module provides most of 16 | -- the standard Prelude, plus a selection of stuff that makes 17 | -- Haxl client code cleaner and more concise. 18 | -- 19 | -- We intend Haxl client code to: 20 | -- 21 | -- * Import @Haxl.Prelude@ 22 | -- 23 | -- * Use @RebindableSyntax@. This implies @NoImplicitPrelude@, and 24 | -- allows @if@-@then@-@else@ to be used with a monadic condition. 25 | -- 26 | -- * Use @OverloadedStrings@ (we use @Text@ a lot) 27 | -- 28 | module Haxl.Prelude ( 29 | -- * The Standard Haskell Prelude 30 | -- | Everything from "Prelude" except 'mapM', 'mapM_', 31 | -- 'sequence', and 'sequence' 32 | module Prelude, 33 | 34 | -- * Haxl and Fetching data 35 | GenHaxl, dataFetch, DataSource, memo, 36 | memoize, memoize1, memoize2, 37 | 38 | -- * Extra Monad and Applicative things 39 | Applicative(..), 40 | mapM, mapM_, sequence, sequence_, filterM, foldM, 41 | forM, forM_, 42 | foldl', sort, 43 | Monoid(..), 44 | join, 45 | andThen, 46 | 47 | -- * Lifted operations 48 | IfThenElse(..), 49 | (.>), (.<), (.>=), (.<=), 50 | (.==), (./=), (.&&), (.||), 51 | (.++), 52 | pair, 53 | pAnd, pOr, 54 | 55 | -- * Text things 56 | Text, 57 | IsString(..), 58 | 59 | -- * Exceptions 60 | throw, catch, try, withDefault, catchAny, 61 | HaxlException(..), TransientError(..), LogicError(..), 62 | NotFound(..), UnexpectedType(..), FetchError(..), 63 | EmptyList(..), InvalidParameter(..) 64 | 65 | ) where 66 | 67 | import Haxl.Core.DataSource 68 | import Haxl.Core.Exception 69 | import Haxl.Core.Memo 70 | import Haxl.Core.Monad 71 | import Haxl.Core.Fetch 72 | import Haxl.Core.Parallel 73 | 74 | import Control.Applicative 75 | import Control.Monad (foldM, join, void) 76 | import Data.List (foldl', sort) 77 | import Data.Text (Text) 78 | import Data.Traversable hiding (forM, mapM, sequence) 79 | import GHC.Exts (IsString(..)) 80 | import Prelude hiding (mapM, mapM_, sequence, sequence_) 81 | import Data.Maybe 82 | import Control.Exception (fromException) 83 | 84 | infixr 3 .&& 85 | infixr 2 .|| 86 | infix 4 .>, .<, .>=, .<=, .==, ./= 87 | 88 | -- ----------------------------------------------------------------------------- 89 | -- Haxl versions of Haskell Prelude stuff 90 | 91 | -- Using overloading and RebindableSyntax to hide the monad as far as 92 | -- possible. 93 | 94 | class IfThenElse a b where 95 | ifThenElse :: a -> b -> b -> b 96 | 97 | instance IfThenElse Bool a where 98 | ifThenElse b t e = if b then t else e 99 | 100 | -- The equality constraint is necessary to convince the typechecker that 101 | -- this is valid: 102 | -- 103 | -- > if ipGetCountry ip .== "us" then ... else ... 104 | -- 105 | instance (u1 ~ u2) => IfThenElse (GenHaxl u1 w Bool) (GenHaxl u2 w a) where 106 | ifThenElse fb t e = do 107 | b <- fb 108 | if b then t else e 109 | 110 | instance Num a => Num (GenHaxl u w a) where 111 | (+) = liftA2 (+) 112 | (-) = liftA2 (-) 113 | (*) = liftA2 (*) 114 | fromInteger = pure . fromInteger 115 | abs = liftA abs 116 | signum = liftA signum 117 | negate = liftA negate 118 | 119 | instance Fractional a => Fractional (GenHaxl u w a) where 120 | (/) = liftA2 (/) 121 | recip = liftA recip 122 | fromRational = return . fromRational 123 | 124 | -- ----------------------------------------------------------------------------- 125 | -- Convenience functions for avoiding do-notation boilerplate 126 | 127 | -- convention is to prefix the name with a '.'. We could change this, 128 | -- or even just not provide these at all. 129 | 130 | (.>) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool 131 | (.>) = liftA2 (Prelude.>) 132 | 133 | (.<) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool 134 | (.<) = liftA2 (Prelude.<) 135 | 136 | (.>=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool 137 | (.>=) = liftA2 (Prelude.>=) 138 | 139 | (.<=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool 140 | (.<=) = liftA2 (Prelude.<=) 141 | 142 | (.==) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool 143 | (.==) = liftA2 (Prelude.==) 144 | 145 | (./=) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool 146 | (./=) = liftA2 (Prelude./=) 147 | 148 | (.++) :: GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a] 149 | (.++) = liftA2 (Prelude.++) 150 | 151 | -- short-circuiting Bool operations 152 | (.&&):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool 153 | fa .&& fb = do a <- fa; if a then fb else return False 154 | 155 | (.||):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool 156 | fa .|| fb = do a <- fa; if a then return True else fb 157 | 158 | pair :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (a, b) 159 | pair = liftA2 (,) 160 | 161 | -- ----------------------------------------------------------------------------- 162 | -- Applicative traversals 163 | 164 | -- | We don't want the monadic 'mapM', because that doesn't do batching. 165 | -- There doesn't seem to be a way to make 'Data.Traversable.mapM' have 166 | -- the right behaviour when used with Haxl, so instead we define 'mapM' 167 | -- to be 'traverse' in Haxl code. 168 | mapM :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) 169 | mapM = traverse 170 | 171 | forM :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) 172 | forM = flip mapM 173 | 174 | -- | See 'mapM'. 175 | mapM_ :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f () 176 | mapM_ f t = void $ traverse f t 177 | 178 | forM_ :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f () 179 | forM_ = flip mapM_ 180 | 181 | -- | See 'mapM'. 182 | sequence :: (Traversable t, Applicative f) => t (f a) -> f (t a) 183 | sequence = sequenceA 184 | 185 | -- | See 'mapM'. 186 | sequence_ :: (Traversable t, Applicative f) => t (f a) -> f () 187 | sequence_ t = void $ sequenceA t 188 | 189 | -- | See 'mapM'. 190 | filterM :: (Applicative f) => (a -> f Bool) -> [a] -> f [a] 191 | filterM predicate xs = 192 | filt <$> mapM predicate xs 193 | where 194 | filt bools = [ x | (x,True) <- zip xs bools ] 195 | 196 | -- | In somes cases, we do want the monadic version of @('>>')@ to disable 197 | -- concurrency and start one computation only after the other finishes, e.g.: 198 | -- 199 | -- @ 200 | -- deferedFetch x = do 201 | -- sleep 5 202 | -- fetch x -- fetch will actually run concurrently with sleep 203 | -- @ 204 | -- 205 | -- But we have defined @('>>') = ('*>')@ with the applicative behavior as this 206 | -- is desired in most cases, so instead we define 'andThen' as the monadic 207 | -- version of @('>>')@: 208 | -- 209 | -- @ 210 | -- deferedFetch x = sleep 5 `andThen` fetch x 211 | -- @ 212 | andThen :: Monad m => m a -> m b -> m b 213 | andThen a b = a >>= \_ -> b 214 | 215 | -------------------------------------------------------------------------------- 216 | 217 | -- | Runs the given 'GenHaxl' computation, and if it throws a 218 | -- 'TransientError' or 'LogicError' exception (see 219 | -- "Haxl.Core.Exception"), the exception is ignored and the supplied 220 | -- default value is returned instead. 221 | withDefault :: a -> GenHaxl u w a -> GenHaxl u w a 222 | withDefault d a = catchAny a (return d) 223 | 224 | -- | Catch 'LogicError's and 'TransientError's and perform an alternative action 225 | catchAny 226 | :: GenHaxl u w a -- ^ run this first 227 | -> GenHaxl u w a -- ^ if it throws 'LogicError' or 'TransientError', run this 228 | -> GenHaxl u w a 229 | catchAny haxl handler = 230 | haxl `catch` \e -> 231 | if isJust (fromException e :: Maybe LogicError) || 232 | isJust (fromException e :: Maybe TransientError) 233 | then 234 | handler 235 | else 236 | throw e 237 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-present, Facebook, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 22 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 23 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 24 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 25 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module Setup where 10 | import Distribution.Simple 11 | main = defaultMain 12 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Changes in version 2.5.1.1 2 | * Bump dependencies; builds up to GHC 9.10 3 | 4 | # Changes in version 2.5.1.0 5 | * Add schedulerHintState method to DataSource 6 | 7 | # Changes in version 2.4.0.0 8 | * Added fetchBatchId to FetchStats 9 | * Profiling now tracks full stacks and links each label to memos/fetches 10 | * Adds FetchDataSourceStats used to log stats/profiling data returned 11 | from datasources. This is stored in statsRef like any other Stats. 12 | * Report flag was changed from sequential numbers to bitmask. 13 | * Add ReportExceptionLabelStack flag to include label stack in HaxlException. 14 | 15 | # Changes in version 2.3.0.0 16 | * Removed `FutureFetch` 17 | 18 | # Changes in version 2.2.0.0 19 | 20 | * Use BasicHashTable for the Haxl DataCache instead of HashMap 21 | * API Changes in: Haxl.Core.DataCache, Haxl.Core.Fetch 22 | * Removed support for GHC < 8.2 23 | 24 | # Changes in version 2.1.2.0 25 | 26 | * Add a callgraph reference to 'Env' to record the function callgraph during a 27 | computation. The callgraph is stored as an edge list in the Env through the 28 | use of `withCallGraph` and enables users to debug a Haxl computation. 29 | 30 | # Changes in version 2.1.1.0 31 | * Adds feature to track outgone datasource fetches. This is only turned on 32 | for report level greater than 1. The fetches are stored as a running Map 33 | in the env ('submittedReqsRef'). 34 | 35 | # Changes in version 2.1.0.0 36 | 37 | * Add a new 'w' parameter to 'GenHaxl' to allow arbitrary writes during 38 | a computation. These writes are stored as a running log in the Env, 39 | and are memoized. This allows users to extract information from 40 | a Haxl computation which throws. Our advise is to limit these writes to 41 | monitoring and debugging logs. 42 | 43 | * A 'WriteTree' constructor to maintain log of writes inside the Environment. 44 | This is defined to allow O(1) mappend. 45 | 46 | # Changes in version 2.0.1.1 47 | 48 | * Support for GHC 8.6.1 49 | * Bugfixes 50 | 51 | # Changes in version 2.0.1.0 52 | 53 | * Exported MemoVar from Haxl.Core.Memo 54 | * Updated the facebook example 55 | * Fixed some links in the documentation 56 | * Bump some version bounds 57 | 58 | # Changes in version 2.0.0.0 59 | 60 | * Completely rewritten internals to support arbitrarily overlapping 61 | I/O and computation. Haxl no longer runs batches of I/O in 62 | "rounds", waiting for all the I/O to complete before resuming the 63 | computation. In Haxl 2, we can spawn I/O that returns results in 64 | the background and computation fragments are resumed when the 65 | values they depend on are available. See 66 | `tests/FullyAsyncTest.hs` for an example. 67 | 68 | * A new `PerformFetch` constructor supports the new concurrency 69 | features: `BackgroundFetch`. The data source is expected to call 70 | `putResult` in the background on each `BlockedFetch` when its 71 | result is ready. 72 | 73 | * There is a generic `DataSource` implementation in 74 | `Haxl.DataSource.ConcurrentIO` for performing each I/O operation 75 | in a separate thread. 76 | 77 | * Lots of cleanup and refactoring of the APIs. 78 | 79 | * License changed from BSD+PATENTS to plain BSD3. 80 | 81 | # Changes in version 0.5.1.0 82 | 83 | * 'pAnd' and 'pOr' were added 84 | * 'asyncFetchAcquireRelease' was added 85 | * 'cacheResultWithShow' was exposed 86 | * GHC 8.2.1 compatibility 87 | 88 | # Changes in version 0.5.0.0 89 | * Rename 'Show1' to 'ShowP' ([#62](https://github.com/facebook/Haxl/issues/62)) 90 | 91 | # Changes in version 0.3.0.0 92 | 93 | * Some performance improvements, including avoiding quadratic 94 | slowdown with left-associated binds. 95 | 96 | * Documentation cleanup; Haxl.Core is the single entry point for the 97 | core and engine docs. 98 | 99 | * (>>) is now defined to be (*>), and therefore no longer forces 100 | sequencing. This can have surprising consequences if you are 101 | using Haxl with side-effecting data sources, so watch out! 102 | 103 | * New function withEnv, for running a sub-computation in a local Env 104 | 105 | * Add a higher-level memoization API, see 'memo' 106 | 107 | * Show is no longer required for keys in cachedComputation 108 | 109 | * Exceptions now have `Eq` instances 110 | -------------------------------------------------------------------------------- /example/facebook/FB.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module FB 10 | ( getObject 11 | , getUser 12 | , getUserFriends 13 | , Id(..), Friend(..), User(..) 14 | ) where 15 | 16 | import FB.DataSource 17 | import Data.Aeson 18 | import Facebook (Id(..), Friend(..), User(..)) 19 | 20 | import Haxl.Core 21 | 22 | -- | Fetch an arbitrary object in the Facebook graph. 23 | getObject :: Id -> GenHaxl u w Object 24 | getObject id = dataFetch (GetObject id) 25 | 26 | -- | Fetch a Facebook user. 27 | getUser :: Id -> GenHaxl u w User 28 | getUser id = dataFetch (GetUser id) 29 | 30 | -- | Fetch the friends of a Facebook user that are registered with the 31 | -- current app. 32 | getUserFriends :: Id -> GenHaxl u w [Friend] 33 | getUserFriends id = dataFetch (GetUserFriends id) 34 | -------------------------------------------------------------------------------- /example/facebook/FB/DataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings, StandaloneDeriving, RecordWildCards, 10 | GADTs, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, 11 | FlexibleInstances #-} 12 | -- QSem was deprecated in 7.6, but no more 13 | {-# OPTIONS_GHC -fno-warn-deprecations #-} 14 | module FB.DataSource 15 | ( FacebookReq(..) 16 | , initGlobalState 17 | , Credentials(..) 18 | , UserAccessToken 19 | , AccessToken(..) 20 | ) where 21 | 22 | import Network.HTTP.Conduit 23 | import Facebook as FB 24 | import Control.Monad 25 | import Control.Monad.Trans.Resource 26 | import Data.Hashable 27 | import Data.Typeable 28 | import Network.HTTP.Client.TLS (tlsManagerSettings) 29 | import Data.Conduit 30 | import Data.Conduit.List hiding (mapM, mapM_) 31 | import Data.Monoid 32 | import Data.Aeson 33 | import Control.Concurrent.Async 34 | import Control.Concurrent.QSem 35 | import Control.Exception 36 | 37 | import Haxl.Core 38 | 39 | data FacebookReq a where 40 | GetObject :: Id -> FacebookReq Object 41 | GetUser :: UserId -> FacebookReq User 42 | GetUserFriends :: UserId -> FacebookReq [Friend] 43 | deriving Typeable 44 | 45 | deriving instance Eq (FacebookReq a) 46 | deriving instance Show (FacebookReq a) 47 | 48 | instance ShowP FacebookReq where showp = show 49 | 50 | instance Hashable (FacebookReq a) where 51 | hashWithSalt s (GetObject (Id id)) = hashWithSalt s (0::Int,id) 52 | hashWithSalt s (GetUser (Id id)) = hashWithSalt s (1::Int,id) 53 | hashWithSalt s (GetUserFriends (Id id)) = hashWithSalt s (2::Int,id) 54 | 55 | instance StateKey FacebookReq where 56 | data State FacebookReq = 57 | FacebookState 58 | { credentials :: Credentials 59 | , userAccessToken :: UserAccessToken 60 | , manager :: Manager 61 | , semaphore :: QSem 62 | } 63 | 64 | instance DataSourceName FacebookReq where 65 | dataSourceName _ = "Facebook" 66 | 67 | instance DataSource u FacebookReq where 68 | fetch = facebookFetch 69 | 70 | initGlobalState 71 | :: Int 72 | -> Credentials 73 | -> UserAccessToken 74 | -> IO (State FacebookReq) 75 | 76 | initGlobalState threads creds token = do 77 | manager <- newManager tlsManagerSettings 78 | sem <- newQSem threads 79 | return FacebookState 80 | { credentials = creds 81 | , manager = manager 82 | , userAccessToken = token 83 | , semaphore = sem 84 | } 85 | 86 | facebookFetch 87 | :: State FacebookReq 88 | -> Flags 89 | -> u 90 | -> PerformFetch FacebookReq 91 | 92 | facebookFetch FacebookState{..} _flags _user = 93 | BackgroundFetch $ 94 | mapM_ (fetchAsync credentials manager userAccessToken semaphore) 95 | 96 | fetchAsync 97 | :: Credentials -> Manager -> UserAccessToken -> QSem 98 | -> BlockedFetch FacebookReq 99 | -> IO () 100 | fetchAsync creds manager tok sem (BlockedFetch req rvar) = 101 | void $ async $ bracket_ (waitQSem sem) (signalQSem sem) $ do 102 | e <- Control.Exception.try $ 103 | runResourceT $ runFacebookT creds manager $ fetchFBReq tok req 104 | case e of 105 | Left ex -> putFailure rvar (ex :: SomeException) 106 | Right a -> putSuccess rvar a 107 | 108 | fetchFBReq 109 | :: UserAccessToken 110 | -> FacebookReq a 111 | -> FacebookT Auth (ResourceT IO) a 112 | 113 | fetchFBReq tok (GetObject (Id id)) = 114 | getObject ("/" <> id) [] (Just tok) 115 | 116 | fetchFBReq _tok (GetUser id) = 117 | getUser id [] Nothing 118 | 119 | fetchFBReq tok (GetUserFriends id) = do 120 | f <- getUserFriends id [] tok 121 | source <- fetchAllNextPages f 122 | source $$ consume 123 | -------------------------------------------------------------------------------- /example/facebook/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-present, Facebook, Inc. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Simon Marlow nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /example/facebook/Setup.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module Setup where 10 | import Distribution.Simple 11 | main = defaultMain 12 | -------------------------------------------------------------------------------- /example/facebook/TestFB.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} 10 | module TestFB (main) where 11 | 12 | import Control.Exception as E 13 | import Data.Aeson 14 | import Data.HashMap.Strict ((!)) 15 | import Data.Time.Calendar 16 | import Data.Time.Clock 17 | import FB 18 | import FB.DataSource 19 | import Haxl.Core 20 | import Haxl.Prelude 21 | import System.Environment 22 | import System.Exit 23 | import System.IO.Error 24 | import qualified Data.HashMap.Strict as HashMap 25 | import qualified Data.Text as T 26 | import qualified Data.Vector as Vector 27 | 28 | main = do 29 | (creds, access_token) <- getCredentials 30 | facebookState <- initGlobalState 10 creds access_token 31 | env <- initEnv (stateSet facebookState stateEmpty) () 32 | r <- runHaxl env $ do 33 | likes <- getObject "me/likes" 34 | mapM getObject (likeIds likes) -- these happen concurrently 35 | print r 36 | 37 | likeIds :: Object -> [Id] 38 | likeIds likes = do 39 | Array arr <- [likes ! "data"] 40 | Object obj <- Vector.toList arr 41 | String id <- [obj ! "id"] 42 | return (Id id) 43 | 44 | -- Modifed from the test in the fb package: 45 | -- https://github.com/meteficha/fb/blob/master/tests/Main.hs 46 | -- Copyright (c)2012, Felipe Lessa 47 | 48 | -- | Grab the Facebook credentials from the environment. 49 | getCredentials :: IO (Credentials, UserAccessToken) 50 | getCredentials = tryToGet `E.catch` showHelp 51 | where 52 | tryToGet = do 53 | [appName, appId, appSecret, accessToken] <- 54 | mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET", "ACCESS_TOKEN"] 55 | now <- getCurrentTime 56 | let creds = Credentials (T.pack appName) 57 | (T.pack appId) 58 | (T.pack appSecret) 59 | access_token = UserAccessToken 60 | (Id "me") 61 | (T.pack accessToken) 62 | now 63 | return (creds, access_token) 64 | 65 | showHelp exc | not (isDoesNotExistError exc) = E.throw exc 66 | showHelp _ = do 67 | putStrLn $ unlines 68 | [ "In order to run the tests from the 'haxl-facebook' package, you" 69 | , "need developer access to a Facebook app. Create an app by" 70 | , "going to http://developers.facebook.com, select \"Create a New" 71 | , " App\" from the \"Apps\" menu at the top. Then create an" 72 | , "access token using the Graph API explorer:" 73 | , " https://developers.facebook.com/tools/explorer" 74 | , "Select your app from the \"Application\" menu at the top, then hit" 75 | , "\"Get Access Token\". The access token will last about 2 hours." 76 | , "" 77 | , "Please supply your app's name, id and secret in the environment" 78 | , "variables APP_NAME, APP_ID and APP_SECRET, respectively, and" 79 | , "the access token in ACCESS_TOKEN." 80 | , "" 81 | , "For example, before running the test you could run in the shell:" 82 | , "" 83 | , " $ export APP_NAME=\"test\"" 84 | , " $ export APP_ID=\"000000000000000\"" 85 | , " $ export APP_SECRET=\"xxxxxxxxxxxxxxxxxxxxxxxxxxxx\"" 86 | , " $ export ACCESS_TOKEN=\"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\"" 87 | , "" 88 | , "Of course, these values above aren't valid and you need to" 89 | , "replace them with your own." 90 | , "" 91 | , "(Exiting now with a failure code.)"] 92 | exitFailure 93 | -------------------------------------------------------------------------------- /example/facebook/haxl-facebook.cabal: -------------------------------------------------------------------------------- 1 | name: haxl-facebook 2 | version: 0.2.0.0 3 | synopsis: An example Haxl data source for accessing the 4 | Facebook Graph API 5 | homepage: https://github.com/facebook/Haxl 6 | bug-reports: https://github.com/facebook/Haxl/issues 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Facebook, Inc. 10 | maintainer: The Haxl Team 11 | copyright: Copyright (c) 2014-present, Facebook, Inc. 12 | category: Concurrency, Network 13 | build-type: Simple 14 | cabal-version: >=1.10 15 | 16 | library 17 | build-depends: 18 | base == 4.*, 19 | aeson >= 0.6 && < 1.4, 20 | fb >=1.0 && <1.3, 21 | http-conduit >=2.1 && <2.4, 22 | resourcet >=1.1 && <1.3, 23 | text >= 1.2.1.0 && < 1.3, 24 | transformers >=0.3 && <0.6, 25 | hashable >=1.2 && <1.3, 26 | data-default >=0.5 && <0.8, 27 | http-client-tls >=0.2 && <0.4, 28 | time >= 1.4 && < 1.9, 29 | conduit >=1.1 && <1.4, 30 | async >=2.0 && <2.3, 31 | haxl == 2.0.* 32 | 33 | other-extensions: 34 | OverloadedStrings, 35 | StandaloneDeriving, 36 | RecordWildCards, 37 | GADTs, 38 | TypeFamilies, 39 | MultiParamTypeClasses, 40 | DeriveDataTypeable 41 | 42 | exposed-modules: 43 | FB, 44 | FB.DataSource 45 | 46 | ghc-options: 47 | -Wall -fno-warn-name-shadowing 48 | 49 | default-language: 50 | Haskell2010 51 | 52 | test-suite test 53 | type: 54 | exitcode-stdio-1.0 55 | 56 | main-is: 57 | TestFB.hs 58 | 59 | build-depends: 60 | base == 4.*, 61 | aeson >= 0.6 && < 1.4, 62 | fb >=1.0 && <1.3, 63 | http-conduit >=2.1 && <2.4, 64 | resourcet >=1.1 && <1.3, 65 | text >= 1.2.1.0 && < 1.3, 66 | transformers >=0.3 && <0.6, 67 | hashable >=1.2 && <1.3, 68 | data-default >=0.5 && <0.8, 69 | http-client-tls >=0.2 && <0.4, 70 | time >= 1.4 && < 1.9, 71 | conduit >=1.1 && <1.4, 72 | async >=2.0 && <2.3, 73 | haxl == 2.0.*, 74 | unordered-containers == 0.2.*, 75 | vector >= 0.10 && < 0.13 76 | 77 | default-language: 78 | Haskell2010 79 | -------------------------------------------------------------------------------- /example/sql/Main.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | -- Necessary: 10 | {-# LANGUAGE DeriveDataTypeable #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | 17 | -- Incidental: 18 | {-# LANGUAGE FlexibleInstances #-} 19 | {-# LANGUAGE TypeSynonymInstances #-} 20 | 21 | module Main where 22 | 23 | import Control.Monad 24 | import Data.Hashable 25 | import Data.List 26 | import Data.Text (Text) 27 | import Data.Traversable (for) 28 | import Data.Typeable 29 | import Haxl.Core 30 | import System.Random 31 | 32 | import qualified Data.Text as Text 33 | 34 | main :: IO () 35 | main = do 36 | let stateStore = stateSet UserState{} stateEmpty 37 | env0 <- initEnv stateStore () 38 | names <- runHaxl env0 getAllUsernames 39 | print names 40 | 41 | -- Data source API. 42 | 43 | getAllUsernames :: Haxl [Name] 44 | getAllUsernames = do 45 | userIds <- getAllUserIds 46 | for userIds $ \userId -> do 47 | getUsernameById userId 48 | 49 | getAllUserIds :: Haxl [Id] 50 | getAllUserIds = dataFetch GetAllIds 51 | 52 | getUsernameById :: Id -> Haxl Name 53 | getUsernameById userId = dataFetch (GetNameById userId) 54 | 55 | -- Aliases. 56 | 57 | type Haxl = GenHaxl () () 58 | type Id = Int 59 | type Name = Text 60 | 61 | -- Data source implementation. 62 | 63 | data UserReq a where 64 | GetAllIds :: UserReq [Id] 65 | GetNameById :: Id -> UserReq Name 66 | deriving (Typeable) 67 | 68 | deriving instance Eq (UserReq a) 69 | instance Hashable (UserReq a) where 70 | hashWithSalt s GetAllIds = hashWithSalt s (0::Int) 71 | hashWithSalt s (GetNameById a) = hashWithSalt s (1::Int, a) 72 | 73 | deriving instance Show (UserReq a) 74 | instance ShowP UserReq where showp = show 75 | 76 | instance StateKey UserReq where 77 | data State UserReq = UserState {} 78 | 79 | instance DataSourceName UserReq where 80 | dataSourceName _ = "UserDataSource" 81 | 82 | instance DataSource u UserReq where 83 | fetch _state _flags _userEnv = SyncFetch $ \blockedFetches -> do 84 | let 85 | allIdVars :: [ResultVar [Id]] 86 | allIdVars = [r | BlockedFetch GetAllIds r <- blockedFetches] 87 | 88 | idStrings :: [String] 89 | idStrings = map show ids 90 | 91 | ids :: [Id] 92 | vars :: [ResultVar Name] 93 | (ids, vars) = unzip 94 | [(userId, r) | BlockedFetch (GetNameById userId) r <- blockedFetches] 95 | 96 | unless (null allIdVars) $ do 97 | allIds <- sql "select id from ids" 98 | mapM_ (\r -> putSuccess r allIds) allIdVars 99 | 100 | unless (null ids) $ do 101 | names <- sql $ unwords 102 | [ "select name from names where" 103 | , intercalate " or " $ map ("id = " ++) idStrings 104 | , "order by find_in_set(id, '" ++ intercalate "," idStrings ++ "')" 105 | ] 106 | mapM_ (uncurry putSuccess) (zip vars names) 107 | 108 | -- Mock SQL API. 109 | 110 | class SQLResult a where 111 | mockResult :: IO a 112 | 113 | instance SQLResult a => SQLResult [a] where 114 | mockResult = replicateM 10 mockResult 115 | 116 | instance SQLResult Name where 117 | -- An infinite number of employees, all named Jim. 118 | mockResult = ("Jim" `Text.append`) . Text.pack . show <$> randomRIO (1::Int, 100) 119 | 120 | instance SQLResult Id where 121 | mockResult = randomRIO (1, 100) 122 | 123 | sql :: SQLResult a => String -> IO a 124 | sql query = print query >> mockResult 125 | -------------------------------------------------------------------------------- /example/sql/Setup.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module Setup where 10 | import Distribution.Simple 11 | main = defaultMain 12 | -------------------------------------------------------------------------------- /example/sql/haxl-example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.8 2 | name: haxl-example 3 | version: 0.1.0.0 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Facebook, Inc. 7 | copyright: Copyright (c) 2014-present, Facebook, Inc. 8 | executable example 9 | main-is: 10 | Main.hs 11 | build-depends: 12 | hashable, 13 | haxl, 14 | text, 15 | random, 16 | base 17 | -------------------------------------------------------------------------------- /example/sql/readme.md: -------------------------------------------------------------------------------- 1 | # Solving the "N+1 Selects Problem" with Haxl 2 | 3 | The so-called “[N+1 selects problem](http://ocharles.org.uk/blog/posts/2014-03-24-queries-in-loops-without-a-care-in-the-world.html)” is characterized by a set of queries in a loop. To ape the example from Ollie Charles: 4 | 5 | ```haskell 6 | getAllUsernames = do 7 | userIds <- getAllUserIds 8 | for userIds $ \userId -> do 9 | getUsernameById userId 10 | ``` 11 | 12 | The `IO` version of this code would perform one data fetch for `getAllUserIds`, then another for each call to `getUsernameById`; assuming each one is implemented with something like the SQL `select` statement, that means “N+1 selects”. 13 | 14 | But Haxl does not suffer from this problem. Using *this very code*, the Haxl implementation will perform *exactly two* data fetches: one to `getAllUserIds` and one with all the `getUsernameById` calls batched together. 15 | 16 | First, a dash of boilerplate: 17 | 18 | ```haskell 19 | {-# LANGUAGE DeriveDataTypeable, 20 | GADTs, 21 | MultiParamTypeClasses, 22 | StandaloneDeriving, 23 | TypeFamilies #-} 24 | 25 | import Data.Typeable 26 | import Haxl.Core 27 | ``` 28 | 29 | ## The Request Type 30 | 31 | First we make a data type with a constructor for each type of request. 32 | 33 | ```haskell 34 | data UserReq a where 35 | GetAllIds :: UserReq [Id] 36 | GetNameById :: Id -> UserReq Name 37 | deriving (Typeable) 38 | 39 | type Id = Int 40 | type Name = String 41 | 42 | deriving instance Eq (UserReq a) 43 | instance Hashable (UserReq a) where 44 | hashWithSalt s GetAllIds = hashWithSalt s (0::Int) 45 | hashWithSalt s (GetNameById a) = hashWithSalt s (1::Int, a) 46 | 47 | deriving instance Show (UserReq a) 48 | instance ShowP UserReq where showp = show 49 | ``` 50 | 51 | This type is parameterized so that each request can indicate which type of result it returns. It is `Typeable` so that Haxl can safely store requests to multiple data sources at once, as well as `Eq` and `Hashable` for caching and `Show` for debug output. 52 | 53 | ## Making a Data Source from a Request Type 54 | 55 | Now we make this an instance of Haxl’s `StateKey` and `DataSource` classes. `StateKey` lets us associate a data source with its global state, to be initialized once. (We won’t take advantage of this here.) 56 | 57 | ```haskell 58 | instance StateKey UserReq where 59 | data State UserReq = UserState {} 60 | ``` 61 | 62 | Every data source needs to tell Haxl its name, by giving an instance for 63 | the `DataSourceName` class: 64 | 65 | ```haskell 66 | instance DataSourceName UserReq where 67 | dataSourceName _ = "UserDataSource" 68 | ``` 69 | 70 | Next, `DataSource` lets us specify how a set of blocked requests are to be fetched. It is parameterized by the type of a *user environment* of cross–data source global data, as well as a request type that is an instance of `StateKey`. It is defined as follows: 71 | 72 | ```haskell 73 | class (DataSourceName, StateKey req, ShowP req) => DataSource u req where 74 | fetch 75 | :: State req -- Data source state. 76 | -> Flags -- Flags, containing tracing verbosity level, etc. 77 | -> u -- User environment for cross–data source globals. 78 | -> [BlockedFetch req] -- Set of blocked fetches to perform. 79 | -> PerformFetch -- An action to perform the fetching. 80 | ``` 81 | 82 | We are mainly concerned with implementing the `fetch` method, and in this case we can ignore many of its parameters, which are to support more complex data sources than ours. The key point is that Haxl gives us a list of *all* the requests that are currently waiting to be fetched, which means we can batch them together however we please. 83 | 84 | Taking a look at the definition of `BlockedFetch` informs us how to implement the `fetch` method: 85 | 86 | ```haskell 87 | data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a) 88 | type ResultVar a = MVar (Either SomeException a) 89 | ``` 90 | 91 | Here we have that a `BlockedFetch` consists of a pair of a request (of type `r a`) and a `MVar` containing `Either SomeException` (if fetching failed) or the result of the request. The role of `fetch` is to fill these `MVar`s. 92 | 93 | ## Implementing the `fetch` Method 94 | 95 | Now, a data source can fetch data in one of two ways: 96 | 97 | * **Synchronously:** the fetching operation is an `IO ()` that fetches all the 98 | data and then returns. 99 | 100 | * **Asynchronously:** we can do something else while the data is being 101 | fetched. The fetching operation takes an `IO ()` as an argument, which is 102 | the operation to perform while the data is being fetched. 103 | 104 | These are represented by the constructors of the `PerformFetch` type that `fetch` returns: 105 | 106 | ```haskell 107 | data PerformFetch 108 | = SyncFetch (IO ()) 109 | | AsyncFetch (IO () -> IO ()) 110 | ``` 111 | 112 | We will use `SyncFetch` here for simplicity. (Haxl also includes `syncFetch` and `asyncFetch` helper functions for implementing common `fetch` patterns.) Now, in the implementation of `fetch`, assuming we have some function `sql` for running SQL queries, we can do something like this: 113 | 114 | ```haskell 115 | -- We have no user environment, so we use (). 116 | type Haxl = GenHaxl () 117 | 118 | instance DataSource u UserReq where 119 | fetch _state _flags _userEnv blockedFetches = SyncFetch $ do 120 | 121 | unless (null allIdVars) $ do 122 | allIds <- sql "select id from ids" 123 | mapM_ (\r -> putSuccess r allIds) allIdVars 124 | 125 | unless (null ids) $ do 126 | names <- sql $ unwords 127 | [ "select name from names where" 128 | , intercalate " or " $ map ("id = " ++) idStrings 129 | , "order by find_in_set(id, '" ++ intercalate "," idStrings ++ "')" 130 | ] 131 | mapM_ (uncurry putSuccess) (zip vars names) 132 | 133 | where 134 | allIdVars :: [ResultVar [Id]] 135 | allIdVars = [r | BlockedFetch GetAllIds r <- blockedFetches] 136 | 137 | idStrings :: [String] 138 | idStrings = map show ids 139 | 140 | ids :: [Id] 141 | vars :: [ResultVar Name] 142 | (ids, vars) = unzip 143 | [(userId, r) | BlockedFetch (GetNameById userId) r <- blockedFetches] 144 | ``` 145 | 146 | ## Tying it All Together 147 | 148 | All that remains to make the original example work is to define `getAllUserIds` and `getUserById` using Haxl’s `dataFetch` function. 149 | 150 | ```haskell 151 | getAllUserIds :: Haxl [Id] 152 | getAllUserIds = dataFetch GetAllIds 153 | 154 | getUsernameById :: Id -> Haxl Name 155 | getUsernameById userId = dataFetch (GetNameById userId) 156 | ``` 157 | 158 | `dataFetch` simply takes a request to a data source and returns a 159 | `GenHaxl` action to fetch it concurrently with others. 160 | 161 | ```haskell 162 | dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a 163 | ``` 164 | 165 | Like magic, the naïve code that *looks* like it will do N+1 fetches will now do just two. 166 | 167 | ```haskell 168 | getAllUsernames :: Haxl [Name] 169 | getAllUsernames = do 170 | userIds <- getAllUserIds -- Round 1 171 | for userIds $ \userId -> do -- Round 2 172 | getUsernameById userId 173 | ``` 174 | 175 | The only change is that its type signature is now `Haxl` instead of `IO`, and at the top level we have to place a call to `runHaxl`: 176 | 177 | ```haskell 178 | main :: IO () 179 | main = do 180 | 181 | -- Initialize Haxl state. 182 | let stateStore = stateSet UserState{} stateEmpty 183 | 184 | -- Initialize Haxl environment. 185 | env0 <- initEnv stateStore () 186 | 187 | -- Run action. 188 | names <- runHaxl env0 getAllUsernames 189 | 190 | print names 191 | ``` 192 | -------------------------------------------------------------------------------- /haxl.cabal: -------------------------------------------------------------------------------- 1 | name: haxl 2 | version: 2.5.1.1 3 | synopsis: A Haskell library for efficient, concurrent, 4 | and concise data access. 5 | homepage: https://github.com/facebook/Haxl 6 | bug-reports: https://github.com/facebook/Haxl/issues 7 | license: BSD3 8 | license-files: LICENSE 9 | author: Facebook, Inc. 10 | maintainer: The Haxl Team 11 | copyright: Copyright (c) 2014-present, Facebook, Inc. 12 | category: Concurrency 13 | build-type: Simple 14 | stability: alpha 15 | cabal-version: >= 1.10 16 | tested-with: 17 | GHC==8.4.4 18 | GHC==8.6.5 19 | GHC==8.8.4 20 | GHC==8.10.7 21 | GHC==9.0.2 22 | GHC==9.2.8 23 | GHC==9.4.8 24 | GHC==9.6.6 25 | GHC==9.8.2 26 | GHC==9.10.1 27 | 28 | description: 29 | Haxl is a library and EDSL for efficient scheduling of concurrent data 30 | accesses with a concise applicative API. 31 | . 32 | To use Haxl, you need to implement one or more /data sources/, which 33 | provide the means for accessing remote data or other I/O that you 34 | want to perform using Haxl. 35 | . 36 | Haxl provides two top-level modules: 37 | . 38 | * /Data-source implementations/ import "Haxl.Core", 39 | . 40 | * /Client code/ import your data sources and "Haxl.Prelude", or some 41 | other client-level API that you provide. 42 | 43 | extra-source-files: 44 | readme.md 45 | tests/LoadCache.txt 46 | changelog.md 47 | 48 | library 49 | 50 | build-depends: 51 | aeson >= 0.6 && < 2.3, 52 | base >= 4.10 && < 5, 53 | binary >= 0.7 && < 0.10, 54 | bytestring >= 0.9 && < 0.13, 55 | containers >= 0.5 && < 0.8, 56 | deepseq, 57 | exceptions >=0.8 && <0.11, 58 | filepath >= 1.3 && < 1.6, 59 | ghc-prim, 60 | hashable >= 1.2 && < 1.6, 61 | hashtables >= 1.2.3.1, 62 | pretty == 1.1.*, 63 | -- text 1.2.1.0 required for instance Binary Text 64 | text >= 1.2.1.0 && < 1.3 || >= 2 && < 2.2, 65 | time >= 1.4 && < 1.13, 66 | stm >= 2.4 && < 2.6, 67 | transformers, 68 | unordered-containers == 0.2.*, 69 | vector >= 0.10 && <0.14 70 | 71 | exposed-modules: 72 | Haxl.Core, 73 | Haxl.Core.CallGraph, 74 | Haxl.Core.DataCache, 75 | Haxl.Core.DataSource, 76 | Haxl.Core.Exception, 77 | Haxl.Core.Flags, 78 | Haxl.Core.Memo, 79 | Haxl.Core.Monad, 80 | Haxl.Core.Fetch, 81 | Haxl.Core.Parallel, 82 | Haxl.Core.Profile, 83 | Haxl.Core.Run, 84 | Haxl.Core.RequestStore, 85 | Haxl.Core.ShowP, 86 | Haxl.Core.StateStore, 87 | Haxl.Core.Stats, 88 | Haxl.Prelude 89 | Haxl.DataSource.ConcurrentIO 90 | 91 | other-modules: 92 | Haxl.Core.Util 93 | 94 | default-language: Haskell2010 95 | default-extensions: 96 | TypeOperators 97 | 98 | ghc-options: 99 | -O2 -fprof-auto 100 | -Wall 101 | -Wno-name-shadowing 102 | 103 | test-suite test 104 | 105 | build-depends: 106 | aeson, 107 | HUnit >= 1.2 && < 1.7, 108 | base >= 4.7 && < 5, 109 | binary, 110 | bytestring, 111 | containers, 112 | deepseq, 113 | filepath, 114 | hashable, 115 | hashtables, 116 | haxl, 117 | test-framework, 118 | test-framework-hunit, 119 | text, 120 | time, 121 | unordered-containers 122 | 123 | ghc-options: 124 | -Wall 125 | -fno-warn-name-shadowing 126 | -fno-warn-missing-signatures 127 | 128 | hs-source-dirs: 129 | tests 130 | 131 | main-is: 132 | TestMain.hs 133 | 134 | other-modules: 135 | AdoTests 136 | AllTests 137 | BadDataSource 138 | BatchTests 139 | CoreTests 140 | DataCacheTest 141 | ExampleDataSource 142 | ExceptionStackTests 143 | FullyAsyncTest 144 | LoadCache 145 | MemoizationTests 146 | MockTAO 147 | MonadAsyncTest 148 | OutgoneFetchesTests 149 | ParallelTests 150 | ProfileTests 151 | SleepDataSource 152 | StatsTests 153 | TestBadDataSource 154 | TestExampleDataSource 155 | TestTypes 156 | TestUtils 157 | WorkDataSource 158 | WriteTests 159 | DataSourceDispatchTests 160 | 161 | type: 162 | exitcode-stdio-1.0 163 | 164 | default-language: Haskell2010 165 | default-extensions: 166 | TypeOperators 167 | 168 | flag bench 169 | default: False 170 | 171 | executable monadbench 172 | if !flag(bench) 173 | buildable: False 174 | default-language: 175 | Haskell2010 176 | default-extensions: 177 | TypeOperators 178 | hs-source-dirs: 179 | tests 180 | build-depends: 181 | base, 182 | haxl, 183 | hashable, 184 | time, 185 | optparse-applicative 186 | main-is: 187 | MonadBench.hs 188 | other-modules: 189 | ExampleDataSource 190 | ghc-options: 191 | -O2 -main-is MonadBench -rtsopts 192 | 193 | executable cachebench 194 | if !flag(bench) 195 | buildable: False 196 | default-language: 197 | Haskell2010 198 | default-extensions: 199 | TypeOperators 200 | hs-source-dirs: 201 | tests 202 | build-depends: 203 | base, 204 | haxl, 205 | hashable, 206 | hashtables, 207 | time 208 | main-is: 209 | Bench.hs 210 | ghc-options: 211 | -O2 -main-is Bench -rtsopts 212 | -------------------------------------------------------------------------------- /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/facebook/Haxl/037506e2f082c9b9bab3a473ef117fe0fdc1e35f/logo.png -------------------------------------------------------------------------------- /logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 21 | 23 | 41 | 50 | 58 | 59 | 61 | 62 | 64 | image/svg+xml 65 | 67 | 68 | 69 | 70 | 71 | 76 | 79 | 85 | 91 | 97 | 103 | 109 | 110 | 118 | 121 | 127 | 133 | 139 | 145 | 151 | 152 | 153 | 154 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | ![Haxl Logo](https://raw.githubusercontent.com/facebook/Haxl/main/logo.png) 2 | 3 | # Haxl 4 | 5 | [![Support Ukraine](https://img.shields.io/badge/Support-Ukraine-FFD500?style=flat&labelColor=005BBB)](https://opensource.fb.com/support-ukraine) [![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl) 6 | 7 | Haxl is a Haskell library that simplifies access to remote data, such 8 | as databases or web-based services. Haxl can automatically 9 | 10 | * batch multiple requests to the same data source, 11 | * request data from multiple data sources concurrently, 12 | * cache previous requests, 13 | * memoize computations. 14 | 15 | Having all this handled for you behind the scenes means that your 16 | data-fetching code can be much cleaner and clearer than it would 17 | otherwise be if it had to worry about optimizing data-fetching. We'll 18 | give some examples of how this works in the pages linked below. 19 | 20 | There are two Haskell packages here: 21 | 22 | * `haxl`: The core Haxl framework 23 | * `haxl-facebook` (in [https://github.com/facebook/Haxl/tree/master/example/facebook](example/facebook)): An (incomplete) example data source for accessing the Facebook Graph API 24 | 25 | To use Haxl in your own application, you will likely need to build one or more 26 | *data sources*: the thin layer between Haxl and the data that you want 27 | to fetch, be it a database, a web API, a cloud service, or whatever. 28 | 29 | There is a generic datasource in "Haxl.DataSource.ConcurrentIO" that 30 | can be used for performing arbitrary IO operations concurrently, given 31 | a bit of boilerplate to define the IO operations you want to perform. 32 | 33 | The `haxl-facebook` package shows how we might build a Haxl data 34 | source based on the existing `fb` package for talking to the Facebook 35 | Graph API. 36 | 37 | ## Where to go next? 38 | 39 | * [The Story of Haxl](https://code.facebook.com/posts/302060973291128/open-sourcing-haxl-a-library-for-haskell/) 40 | explains how Haxl came about at Facebook, and discusses our 41 | particular use case. 42 | 43 | * [An example Facebook data source](https://github.com/facebook/Haxl/blob/master/example/facebook/readme.md) walks 44 | through building an example data source that queries the Facebook 45 | Graph API concurrently. 46 | 47 | * [Fun with Haxl (part 1)](https://simonmar.github.io/posts/2015-10-20-Fun-With-Haxl-1.html) 48 | Walks through using Haxl from scratch for a simple SQLite-backed 49 | blog engine. 50 | 51 | * [The N+1 Selects Problem](https://github.com/facebook/Haxl/blob/master/example/sql/readme.md) explains how Haxl 52 | can address a common performance problem with SQL queries by 53 | automatically batching multiple queries into a single query, 54 | without the programmer having to specify this behavior. 55 | 56 | * [Haxl Documentation](http://hackage.haskell.org/package/haxl) on 57 | Hackage. 58 | 59 | * [There is no Fork: An Abstraction for Efficient, Concurrent, and Concise Data Access](http://simonmar.github.io/bib/papers/haxl-icfp14.pdf), our paper on Haxl, accepted for publication at ICFP'14. 60 | 61 | ## Contributing 62 | 63 | We welcome contributions! See [CONTRIBUTING](https://github.com/facebook/Haxl/blob/master/CONTRIBUTING.md) for details on how to get started, and our [Code of Conduct](https://github.com/facebook/Haxl/blob/master/CODE_OF_CONDUCT.md). 64 | 65 | ## License 66 | 67 | Haxl uses the BSD 3-clause License, as found in the [LICENSE](https://github.com/facebook/Haxl/blob/master/LICENSE) file. 68 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.2 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: [] 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 617368 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/2.yaml 11 | sha256: e7e57649a12f6178d1158e4b6f1f1885ed56d210ae6174385271cecc9b1ea974 12 | original: lts-19.2 13 | -------------------------------------------------------------------------------- /tests/AdoTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE RebindableSyntax, OverloadedStrings, ApplicativeDo #-} 10 | module AdoTests (tests) where 11 | 12 | import TestUtils 13 | import MockTAO 14 | 15 | import Control.Applicative 16 | import Test.HUnit 17 | 18 | import Prelude() 19 | import Haxl.Prelude 20 | 21 | -- ----------------------------------------------------------------------------- 22 | 23 | -- 24 | -- Test ApplicativeDo batching 25 | -- 26 | ado1 = expectResult 12 ado1_ 27 | 28 | ado1_ = do 29 | a <- friendsOf =<< id1 30 | b <- friendsOf =<< id2 31 | return (length (a ++ b)) 32 | 33 | ado2 = expectResult 12 ado2_ 34 | 35 | ado2_ = do 36 | x <- id1 37 | a <- friendsOf x 38 | y <- id2 39 | b <- friendsOf y 40 | return (length (a ++ b)) 41 | 42 | ado3 = expectResult 11 ado3_ 43 | 44 | ado3_ = do 45 | x <- id1 46 | a <- friendsOf x 47 | a' <- friendsOf =<< if null a then id3 else id4 48 | y <- id2 49 | b <- friendsOf y 50 | b' <- friendsOf =<< if null b then id4 else id3 51 | return (length (a' ++ b')) 52 | 53 | tests future = TestList 54 | [ TestLabel "ado1" $ TestCase (ado1 future) 55 | , TestLabel "ado2" $ TestCase (ado2 future) 56 | , TestLabel "ado3" $ TestCase (ado3 future) 57 | ] 58 | -------------------------------------------------------------------------------- /tests/AllTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | module AllTests (allTests) where 11 | 12 | import TestExampleDataSource 13 | import BatchTests 14 | import CoreTests 15 | import DataCacheTest 16 | import ExceptionStackTests 17 | import AdoTests 18 | import OutgoneFetchesTests 19 | import ProfileTests 20 | import MemoizationTests 21 | import MonadAsyncTest 22 | import TestBadDataSource 23 | import FullyAsyncTest 24 | import WriteTests 25 | import ParallelTests 26 | import StatsTests 27 | import DataSourceDispatchTests 28 | 29 | import Test.HUnit 30 | 31 | allTests :: Test 32 | allTests = TestList 33 | [ TestLabel "ExampleDataSource" TestExampleDataSource.tests 34 | , TestLabel "BatchTests-future" $ BatchTests.tests True 35 | , TestLabel "BatchTests-sync" $ BatchTests.tests False 36 | , TestLabel "CoreTests" CoreTests.tests 37 | , TestLabel "DataCacheTests" DataCacheTest.tests 38 | , TestLabel "ExceptionStackTests" ExceptionStackTests.tests 39 | , TestLabel "AdoTests" $ AdoTests.tests False 40 | , TestLabel "OutgoneFetchesTest" OutgoneFetchesTests.tests 41 | , TestLabel "ProfileTests" ProfileTests.tests 42 | , TestLabel "MemoizationTests" MemoizationTests.tests 43 | , TestLabel "MonadAsyncTests" MonadAsyncTest.tests 44 | , TestLabel "BadDataSourceTests" TestBadDataSource.tests 45 | , TestLabel "FullyAsyncTest" FullyAsyncTest.tests 46 | , TestLabel "WriteTest" WriteTests.tests 47 | , TestLabel "ParallelTest" ParallelTests.tests 48 | , TestLabel "StatsTests" StatsTests.tests 49 | , TestLabel "DataSourceDispatchTests" DataSourceDispatchTests.tests 50 | ] 51 | -------------------------------------------------------------------------------- /tests/BadDataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 16 | {-# LANGUAGE FlexibleInstances #-} 17 | {-# LANGUAGE RecordWildCards #-} 18 | 19 | -- | A data source that can be made to fail in various ways, for testing 20 | 21 | module BadDataSource ( 22 | -- * initialise the state 23 | State(..), initGlobalState, FetchImpl(..), 24 | 25 | -- * requests for this data source 26 | FailAfter(..) 27 | ) where 28 | 29 | import Haxl.Prelude 30 | import Prelude () 31 | 32 | import Haxl.Core 33 | 34 | import Control.Exception 35 | import Data.Typeable 36 | import Data.Hashable 37 | import Control.Concurrent 38 | import Control.Monad (void) 39 | 40 | import GHC.Conc ( PrimMVar ) 41 | import Foreign.StablePtr 42 | import Foreign.C.Types ( CInt(..) ) 43 | 44 | foreign import ccall safe 45 | hs_try_putmvar :: CInt -> StablePtr PrimMVar -> IO () 46 | 47 | data FetchImpl = 48 | Async 49 | | Background 50 | | BackgroundMVar 51 | | BackgroundSeq 52 | | BackgroundPar 53 | 54 | data FailAfter a where 55 | FailAfter :: Int -> FailAfter Int 56 | deriving Typeable 57 | 58 | deriving instance Eq (FailAfter a) 59 | deriving instance Show (FailAfter a) 60 | instance ShowP FailAfter where showp = show 61 | 62 | instance Hashable (FailAfter a) where 63 | hashWithSalt s (FailAfter a) = hashWithSalt s (0::Int,a) 64 | 65 | instance StateKey FailAfter where 66 | data State FailAfter = FailAfterState 67 | { failAcquireDelay :: Int 68 | , failAcquire :: IO () 69 | , failReleaseDelay :: Int 70 | , failRelease :: IO () 71 | , failDispatchDelay :: Int 72 | , failDispatch :: IO () 73 | , failWaitDelay :: Int 74 | , failWait :: IO () 75 | , failImpl :: FetchImpl 76 | } 77 | 78 | instance DataSourceName FailAfter where 79 | dataSourceName _ = "BadDataSource" 80 | 81 | 82 | instance DataSource u FailAfter where 83 | fetch state@FailAfterState{..} 84 | | BackgroundSeq <- failImpl = backgroundFetchSeq runOne state 85 | | BackgroundPar <- failImpl = backgroundFetchPar runOne state 86 | | Background <- failImpl = backgroundFetchAcquireRelease 87 | acquire release dispatchbg wait 88 | submit state 89 | | BackgroundMVar <- failImpl = backgroundFetchAcquireReleaseMVar 90 | acquire release dispatchbgMVar wait 91 | submit state 92 | | Async <- failImpl = asyncFetchAcquireRelease 93 | acquire release dispatch wait 94 | submit state 95 | where 96 | acquire = do threadDelay failAcquireDelay; failAcquire 97 | release _ = do threadDelay failReleaseDelay; failRelease 98 | dispatch _ = do threadDelay failDispatchDelay; failDispatch 99 | dispatchBase put = (do 100 | failDispatch 101 | _ <- mask_ $ forkIO $ finally 102 | (threadDelay failDispatchDelay) 103 | put 104 | return ()) `onException` put 105 | dispatchbg _ c m = dispatchBase (hs_try_putmvar (fromIntegral c) m) 106 | dispatchbgMVar _ _ m = dispatchBase (void $ tryPutMVar m ()) 107 | wait _ = do threadDelay failWaitDelay; failWait 108 | submit :: () -> FailAfter a -> IO (IO (Either SomeException a)) 109 | submit _ (FailAfter t) = do 110 | threadDelay t 111 | return (return (Left (toException (FetchError "failed request")))) 112 | runOne :: FailAfter a -> IO (Either SomeException a) 113 | runOne r = do 114 | bracket acquire release $ \s -> do 115 | dispatch s 116 | getRes <- submit s r 117 | wait s 118 | getRes 119 | 120 | initGlobalState :: FetchImpl -> IO (State FailAfter) 121 | initGlobalState impl = do 122 | return FailAfterState 123 | { failAcquireDelay = 0 124 | , failAcquire = return () 125 | , failReleaseDelay = 0 126 | , failRelease = return () 127 | , failDispatchDelay = 0 128 | , failDispatch = return () 129 | , failWaitDelay = 0 130 | , failWait = return () 131 | , failImpl = impl 132 | } 133 | -------------------------------------------------------------------------------- /tests/BatchTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} 10 | module BatchTests (tests) where 11 | 12 | import TestTypes 13 | import TestUtils 14 | import MockTAO 15 | 16 | import Control.Applicative 17 | import Test.HUnit 18 | 19 | import Haxl.Core 20 | 21 | import Prelude() 22 | import Haxl.Prelude 23 | import Data.IORef 24 | 25 | -- ----------------------------------------------------------------------------- 26 | 27 | -- 28 | -- Test batching over multiple arguments in liftA2 29 | -- 30 | batching1 = expectResult 12 batching1_ 31 | 32 | batching1_ = do 33 | a <- id1 34 | b <- id2 35 | length <$> liftA2 (++) (friendsOf a) (friendsOf b) 36 | 37 | -- 38 | -- Test batching in mapM (which is really traverse) 39 | -- 40 | batching2 = expectResult 12 batching2_ 41 | 42 | batching2_ = do 43 | a <- id1 44 | b <- id2 45 | fs <- mapM friendsOf [a,b] 46 | return (sum (map length fs)) 47 | 48 | -- 49 | -- Test batching when we have a monadic bind in each branch 50 | -- 51 | batching3 = expectResult 12 batching3_ 52 | 53 | batching3_ = do 54 | let a = id1 >>= friendsOf 55 | b = id2 >>= friendsOf 56 | length <$> a .++ b 57 | 58 | -- 59 | -- Test batching over both arguments of (+) 60 | -- 61 | batching4 = expectResult 12 batching4_ 62 | 63 | batching4_ = do 64 | let a = length <$> (id1 >>= friendsOf) 65 | b = length <$> (id2 >>= friendsOf) 66 | a + b 67 | 68 | -- 69 | -- Test batching over both arguments of (+) 70 | -- 71 | batching5 = expectResult 2 batching5_ 72 | 73 | batching5_ :: Haxl Int 74 | batching5_ = if a .> b then 1 else 2 75 | where 76 | a = length <$> (id1 >>= friendsOf) 77 | b = length <$> (id2 >>= friendsOf) 78 | 79 | -- 80 | -- Test batching when we perform all batching tests together with sequence 81 | -- 82 | batching6 = expectResult [12,12,12,12,2] batching6_ 83 | 84 | batching6_ = sequence [batching1_,batching2_,batching3_,batching4_,batching5_] 85 | 86 | -- 87 | -- Ensure if/then/else and bool operators break batching 88 | -- 89 | batching7 = expectResult 12 batching7_ 90 | 91 | batching7_ :: Haxl Int 92 | batching7_ = if a .> 0 then a+b else 0 93 | where 94 | a = length <$> (id1 >>= friendsOf) 95 | b = length <$> (id2 >>= friendsOf) 96 | 97 | -- We expect 3 rounds here due to boolean operators 98 | batching8 = expectResult 12 batching8_ 99 | 100 | batching8_ :: Haxl Int 101 | batching8_ = if (c .== 0) .|| (a .> 0 .&& b .> 0) then a+b else 0 102 | where 103 | a = length <$> (id1 >>= friendsOf) 104 | b = length <$> (id2 >>= friendsOf) 105 | c = length <$> (id3 >>= friendsOf) 106 | 107 | -- (>>) should batch, so we expect one round 108 | batching9 = expectResult 6 batching9_ 109 | 110 | batching9_ :: Haxl Int 111 | batching9_ = (id1 >>= friendsOf) >> (length <$> (id2 >>= friendsOf)) 112 | 113 | -- 114 | -- Test data caching, numFetches 115 | -- 116 | 117 | -- simple (one cache hit) 118 | caching1 = expectFetches 3 caching1_ 119 | caching1_ = nf id1 + nf id2 + nf id3 + nf id3 120 | where 121 | nf id = length <$> (id >>= friendsOf) 122 | 123 | -- simple, in rounds (no cache hits) 124 | caching2 = expectFetches 3 caching2_ 125 | caching2_ = if nf id1 .> 0 then nf id2 + nf id3 else 0 126 | where 127 | nf id = length <$> (id >>= friendsOf) 128 | 129 | -- rounds (one cache hit) 130 | caching3 = expectFetches 3 caching3_ 131 | caching3_ = if nf id1 .> 0 then nf id1 + nf id2 + nf id3 else 0 132 | where 133 | nf id = length <$> (id >>= friendsOf) 134 | 135 | -- 136 | -- Basic sanity check on data-cache re-use 137 | -- 138 | cacheReuse future = do 139 | env <- makeTestEnv future 140 | expectResultWithEnv 12 batching7_ env 141 | 142 | -- make a new env 143 | tao <- MockTAO.initGlobalState future 144 | let st = stateSet tao stateEmpty 145 | env2 <- initEnvWithData st testinput (caches env) 146 | cid <- readIORef (callIdRef env2) 147 | assertBool "callId is unique" (cid > 0) 148 | 149 | -- ensure no more data fetching rounds needed 150 | expectResultWithEnv 12 batching7_ env2 151 | 152 | noCaching future = do 153 | env <- makeTestEnv future 154 | let env' = env{ flags = (flags env){caching = 0} } 155 | result <- runHaxl env' caching3_ 156 | assertEqual "result" result 18 157 | stats <- readIORef (statsRef env) 158 | assertEqual "fetches" 4 (numFetches stats) 159 | 160 | exceptionTest1 = expectResult [] 161 | $ withDefault [] $ friendsOf 101 162 | 163 | exceptionTest2 = expectResult [7..12] $ liftA2 (++) 164 | (withDefault [] (friendsOf 101)) 165 | (withDefault [] (friendsOf 2)) 166 | 167 | deterministicExceptions future = do 168 | env <- makeTestEnv future 169 | let haxl = 170 | sequence [ do _ <- friendsOf =<< id1; throw (NotFound "xxx") 171 | , throw (NotFound "yyy") 172 | ] 173 | -- the first time, friendsOf should block, but we should still get the 174 | -- "xxx" exception. 175 | r <- runHaxl env $ try haxl 176 | assertBool "exceptionTest3" $ 177 | case r of 178 | Left (NotFound "xxx") -> True 179 | _ -> False 180 | -- the second time, friendsOf will be cached, and we should get the "xxx" 181 | -- exception as before. 182 | r <- runHaxl env $ try haxl 183 | assertBool "exceptionTest3" $ 184 | case r of 185 | Left (NotFound "xxx") -> True 186 | _ -> False 187 | 188 | pOrTests future = do 189 | env <- makeTestEnv future 190 | 191 | -- Test semantics 192 | r <- runHaxl env $ do 193 | a <- return False `pOr` return False 194 | b <- return False `pOr` return True 195 | c <- return True `pOr` return False 196 | d <- return True `pOr` return True 197 | return (not a && b && c && d) 198 | assertBool "pOr0" r 199 | 200 | -- pOr is left-biased with respect to exceptions: 201 | r <- runHaxl env $ try $ return True `pOr` throw (NotFound "foo") 202 | assertBool "pOr1" $ 203 | case (r :: Either NotFound Bool) of 204 | Right True -> True 205 | _ -> False 206 | r <- runHaxl env $ try $ throw (NotFound "foo") `pOr` return True 207 | assertBool "pOr2" $ 208 | case (r :: Either NotFound Bool) of 209 | Left (NotFound "foo") -> True 210 | _ -> False 211 | 212 | -- pOr is non-deterministic (see also Note [tricky pOr/pAnd]) 213 | let nondet = (do _ <- friendsOf 1; throw (NotFound "foo")) `pOr` return True 214 | r <- runHaxl env $ try nondet 215 | assertBool "pOr3" $ 216 | case (r :: Either NotFound Bool) of 217 | Right True -> True 218 | _ -> False 219 | -- next we populate the cache 220 | _ <- runHaxl env $ friendsOf 1 221 | -- and now exactly the same pOr again will throw this time: 222 | r <- runHaxl env $ try nondet 223 | assertBool "pOr4" $ 224 | case (r :: Either NotFound Bool) of 225 | Left (NotFound "foo") -> True 226 | _ -> False 227 | 228 | -- One more test: Blocked/False => Blocked 229 | r <- runHaxl env $ try $ 230 | (do _ <- friendsOf 2; throw (NotFound "foo")) `pOr` return False 231 | assertBool "pOr5" $ 232 | case (r :: Either NotFound Bool) of 233 | Left (NotFound _) -> True 234 | _ -> False 235 | 236 | pAndTests future = do 237 | env <- makeTestEnv future 238 | 239 | -- Test semantics 240 | r <- runHaxl env $ do 241 | a <- return False `pAnd` return False 242 | b <- return False `pAnd` return True 243 | c <- return True `pAnd` return False 244 | d <- return True `pAnd` return True 245 | return (not a && not b && not c && d) 246 | assertBool "pAnd0" r 247 | 248 | -- pAnd is left-biased with respect to exceptions: 249 | r <- runHaxl env $ try $ return False `pAnd` throw (NotFound "foo") 250 | assertBool "pAnd1" $ 251 | case (r :: Either NotFound Bool) of 252 | Right False -> True 253 | _ -> False 254 | r <- runHaxl env $ try $ throw (NotFound "foo") `pAnd` return False 255 | assertBool "pAnd2" $ 256 | case (r :: Either NotFound Bool) of 257 | Left (NotFound "foo") -> True 258 | _ -> False 259 | 260 | -- pAnd is non-deterministic (see also Note [tricky pOr/pAnd]) 261 | let nondet = 262 | (do _ <- friendsOf 1; throw (NotFound "foo")) `pAnd` return False 263 | r <- runHaxl env $ try nondet 264 | assertBool "pAnd3" $ 265 | case (r :: Either NotFound Bool) of 266 | Right False -> True 267 | _ -> False 268 | -- next we populate the cache 269 | _ <- runHaxl env $ friendsOf 1 270 | -- and now exactly the same pAnd again will throw this time: 271 | r <- runHaxl env $ try nondet 272 | assertBool "pAnd4" $ 273 | case (r :: Either NotFound Bool) of 274 | Left (NotFound "foo") -> True 275 | _ -> False 276 | 277 | -- One more test: Blocked/True => Blocked 278 | r <- runHaxl env $ try $ 279 | (do _ <- friendsOf 2; throw (NotFound "foo")) `pAnd` return True 280 | assertBool "pAnd5" $ 281 | case (r :: Either NotFound Bool) of 282 | Left (NotFound _) -> True 283 | _ -> False 284 | 285 | tests :: Bool -> Test 286 | tests future = TestList 287 | [ TestLabel "batching1" $ TestCase (batching1 future) 288 | , TestLabel "batching2" $ TestCase (batching2 future) 289 | , TestLabel "batching3" $ TestCase (batching3 future) 290 | , TestLabel "batching4" $ TestCase (batching4 future) 291 | , TestLabel "batching5" $ TestCase (batching5 future) 292 | , TestLabel "batching6" $ TestCase (batching6 future) 293 | , TestLabel "batching7" $ TestCase (batching7 future) 294 | , TestLabel "batching8" $ TestCase (batching8 future) 295 | , TestLabel "batching9" $ TestCase (batching9 future) 296 | , TestLabel "caching1" $ TestCase (caching1 future) 297 | , TestLabel "caching2" $ TestCase (caching2 future) 298 | , TestLabel "caching3" $ TestCase (caching3 future) 299 | , TestLabel "CacheReuse" $ TestCase (cacheReuse future) 300 | , TestLabel "NoCaching" $ TestCase (noCaching future) 301 | , TestLabel "exceptionTest1" $ TestCase (exceptionTest1 future) 302 | , TestLabel "exceptionTest2" $ TestCase (exceptionTest2 future) 303 | , TestLabel "deterministicExceptions" $ 304 | TestCase (deterministicExceptions future) 305 | , TestLabel "pOrTest" $ TestCase (pOrTests future) 306 | , TestLabel "pAndTest" $ TestCase (pAndTests future) 307 | ] 308 | -------------------------------------------------------------------------------- /tests/Bench.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE RankNTypes, GADTs, BangPatterns, DeriveDataTypeable, 10 | StandaloneDeriving #-} 11 | {-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-type-defaults #-} 12 | 13 | module Bench where 14 | 15 | import Haxl.Core.DataCache as DataCache 16 | 17 | import Prelude hiding (mapM) 18 | 19 | import Data.Hashable 20 | import Data.IORef 21 | import Data.Time.Clock 22 | import Data.Traversable 23 | import Data.Typeable 24 | import System.Environment 25 | import Text.Printf 26 | 27 | data TestReq a where 28 | ReqInt :: {-# UNPACK #-} !Int -> TestReq Int 29 | ReqDouble :: {-# UNPACK #-} !Int -> TestReq Double 30 | ReqBool :: {-# UNPACK #-} !Int -> TestReq Bool 31 | deriving Typeable 32 | 33 | deriving instance Eq (TestReq a) 34 | deriving instance Show (TestReq a) 35 | 36 | instance Hashable (TestReq a) where 37 | hashWithSalt salt (ReqInt i) = hashWithSalt salt (0::Int, i) 38 | hashWithSalt salt (ReqDouble i) = hashWithSalt salt (1::Int, i) 39 | hashWithSalt salt (ReqBool i) = hashWithSalt salt (2::Int, i) 40 | 41 | main = do 42 | [n] <- fmap (fmap read) getArgs 43 | t0 <- getCurrentTime 44 | cache <- emptyDataCache 45 | let 46 | f 0 = return () 47 | f !n = do 48 | m <- newIORef 0 49 | DataCache.insert (ReqInt n) m cache 50 | f (n-1) 51 | -- 52 | f n 53 | m <- DataCache.lookup (ReqInt (n `div` 2)) cache 54 | print =<< mapM readIORef m 55 | t1 <- getCurrentTime 56 | printf "insert: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double) 57 | 58 | t0 <- getCurrentTime 59 | let 60 | f 0 !m = return m 61 | f !n !m = do 62 | mbRes <- DataCache.lookup (ReqInt n) cache 63 | case mbRes of 64 | Nothing -> f (n-1) m 65 | Just _ -> f (n-1) (m+1) 66 | f n 0 >>= print 67 | t1 <- getCurrentTime 68 | printf "lookup: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double) 69 | -------------------------------------------------------------------------------- /tests/CoreTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PatternGuards #-} 11 | {-# LANGUAGE RebindableSyntax #-} 12 | 13 | module CoreTests where 14 | 15 | import Haxl.Prelude 16 | import Prelude () 17 | 18 | import Haxl.Core 19 | 20 | import Test.HUnit 21 | 22 | import Data.Aeson 23 | import qualified Data.ByteString.Lazy.Char8 as BS 24 | import Data.List 25 | 26 | import Control.Exception (Exception(..)) 27 | 28 | import ExampleDataSource 29 | 30 | testEnv = do 31 | -- To use a data source, we need to initialize its state: 32 | exstate <- ExampleDataSource.initGlobalState 33 | 34 | -- And create a StateStore object containing the states we need: 35 | let st = stateSet exstate stateEmpty 36 | 37 | -- Create the Env: 38 | initEnv st () :: IO (Env () ()) 39 | 40 | useless :: String -> GenHaxl u w Bool 41 | useless _ = throw (NotFound "ha ha") 42 | 43 | exceptions :: Assertion 44 | exceptions = 45 | do 46 | en <- emptyEnv () :: IO (Env () ()) 47 | a <- runHaxl en $ try (useless "input") 48 | assertBool "NotFound -> HaxlException" $ 49 | isLeft (a :: Either HaxlException Bool) 50 | 51 | b <- runHaxl en $ try (useless "input") 52 | assertBool "NotFound -> Logic Error" $ 53 | isLeft (b :: Either LogicError Bool) 54 | 55 | c <- runHaxl en $ try (useless "input") 56 | assertBool "NotFound -> NotFound" $ 57 | isLeft (c :: Either NotFound Bool) 58 | 59 | -- Make sure TransientError -doesn't- catch our NotFound 60 | d <- runHaxl en $ 61 | (useless "input" 62 | `catch` \TransientError{} -> return False) 63 | `catch` \LogicError{} -> return True 64 | assertBool "Transient != NotFound" d 65 | 66 | -- test catch 67 | e <- runHaxl en $ 68 | throw (NotFound "haha") `catch` \NotFound{} -> return True 69 | assertBool "catch1" e 70 | 71 | f <- runHaxl en $ 72 | throw (NotFound "haha") `catch` \LogicError{} -> return True 73 | assertBool "catch2" f 74 | 75 | -- test catchIf 76 | let transientOrNotFound e 77 | | Just TransientError{} <- fromException e = True 78 | | Just NotFound{} <- fromException e = True 79 | | otherwise = False 80 | 81 | e <- runHaxl en $ 82 | catchIf transientOrNotFound (throw (NotFound "haha")) $ \_ -> 83 | return True 84 | assertBool "catchIf1" e 85 | 86 | e <- runHaxl en $ 87 | catchIf transientOrNotFound (throw (FetchError "haha")) $ \_ -> 88 | return True 89 | assertBool "catchIf2" e 90 | 91 | e <- runHaxl en $ 92 | (catchIf transientOrNotFound (throw (CriticalError "haha")) $ \_ -> 93 | return True) 94 | `catch` \InternalError{} -> return False 95 | assertBool "catchIf2" (not e) 96 | 97 | -- test tryToHaxlException 98 | e <- runHaxl en $ tryToHaxlException $ head [] 99 | assertBool "tryToHaxlException1" $ 100 | case e of 101 | Left ex | Just NonHaxlException{} <- fromException (toException ex) 102 | -> True 103 | _ -> False 104 | 105 | env <- testEnv 106 | e <- runHaxl env $ tryToHaxlException $ do 107 | xs <- listWombats 3 108 | return $! length xs `quot` 0 109 | print e 110 | assertBool "tryToHaxlException1" $ 111 | case e of 112 | Left ex | Just NonHaxlException{} <- fromException (toException ex) 113 | -> True 114 | _ -> False 115 | 116 | env <- testEnv 117 | e <- runHaxl env $ mapM tryToHaxlException 118 | [ do xs <- listWombats 3; return $! length xs `quot` 0 119 | , head [] 120 | ] 121 | print e 122 | assertBool "tryToHaxlException2" $ 123 | case e of 124 | [Left ex1, Left ex2] 125 | | "divide" `isInfixOf` show ex1 126 | , "head" `isInfixOf` show ex2 -> True 127 | _ -> False 128 | where 129 | isLeft Left{} = True 130 | isLeft _ = False 131 | 132 | 133 | -- This is mostly a compile test, to make sure all the plumbing 134 | -- makes the compiler happy. 135 | base :: (Exception a) => a -> IO HaxlException 136 | base e = do 137 | en <- emptyEnv () :: IO (Env () ()) 138 | runHaxl en $ throw e `catch` \x -> return x 139 | 140 | printing :: Assertion 141 | printing = do 142 | a <- base $ NotFound "notfound!" 143 | print a 144 | 145 | b <- base $ CriticalError "ohthehumanity!" 146 | print b 147 | 148 | c <- base $ FetchError "timeout!" 149 | print c 150 | 151 | BS.putStrLn $ encode a 152 | BS.putStrLn $ encode b 153 | BS.putStrLn $ encode c 154 | 155 | 156 | withEnvTest :: Test 157 | withEnvTest = TestLabel "withEnvTest" $ TestCase $ do 158 | exstate <- ExampleDataSource.initGlobalState 159 | e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) 160 | b <- runHaxl e $ withEnv e { userEnv = True } $ env userEnv 161 | assertBool "withEnv1" b 162 | e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) 163 | b <- runHaxl e $ withEnv e { userEnv = True } $ do 164 | _ <- countAardvarks "aaa" 165 | env userEnv 166 | assertBool "withEnv2" b 167 | e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) 168 | b <- runHaxl e $ withEnv e { userEnv = True } $ do 169 | memo ("xxx" :: Text) $ do 170 | _ <- countAardvarks "aaa" 171 | env userEnv 172 | assertBool "withEnv3" b 173 | e <- initEnv (stateSet exstate stateEmpty) False :: IO (Env Bool ()) 174 | b <- runHaxl e $ 175 | withEnv e { userEnv = True } $ do 176 | memo ("yyy" :: Text) $ do 177 | _ <- countAardvarks "aaa" 178 | _ <- countAardvarks "bbb" 179 | env userEnv 180 | assertBool "withEnv4" b 181 | 182 | 183 | tests = TestList 184 | [ TestLabel "exceptions" $ TestCase exceptions, 185 | TestLabel "print_stuff" $ TestCase printing, 186 | TestLabel "withEnv" $ withEnvTest 187 | ] 188 | -------------------------------------------------------------------------------- /tests/DataCacheTest.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE ExistentialQuantification #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | module DataCacheTest (tests, newResult, takeResult) where 15 | 16 | import Haxl.Core.DataCache as DataCache 17 | import Haxl.Core.Monad 18 | import Haxl.Core 19 | 20 | import Control.Exception 21 | import Data.Either 22 | import Data.Hashable 23 | import Data.Traversable 24 | import Data.Typeable 25 | import Prelude hiding (mapM) 26 | import Test.HUnit 27 | import Data.IORef 28 | import qualified Data.Text as Text 29 | import Unsafe.Coerce 30 | 31 | data TestReq a where 32 | Req :: Int -> TestReq a -- polymorphic result 33 | deriving Typeable 34 | 35 | deriving instance Eq (TestReq a) 36 | deriving instance Show (TestReq a) 37 | 38 | instance Hashable (TestReq a) where 39 | hashWithSalt salt (Req i) = hashWithSalt salt i 40 | 41 | instance DataSource u TestReq where 42 | fetch = error "no fetch defined" 43 | 44 | instance DataSourceName TestReq where 45 | dataSourceName _ = Text.pack "TestReq" 46 | 47 | instance StateKey TestReq where 48 | data State TestReq = TestReqState 49 | 50 | instance ShowP TestReq where showp = show 51 | 52 | data CacheableReq x where CacheableInt :: Int -> CacheableReq Int 53 | deriving Typeable 54 | deriving instance Eq (CacheableReq x) 55 | deriving instance Show (CacheableReq x) 56 | instance Hashable (CacheableReq x) where 57 | hashWithSalt s (CacheableInt val) = hashWithSalt s (0::Int, val) 58 | 59 | 60 | newResult :: Monoid w => a -> IO (IVar u w a) 61 | newResult a = newFullIVar (Ok a mempty) 62 | 63 | takeResult :: IVar u w a -> IO (ResultVal a w) 64 | takeResult IVar{ivarRef = ref} = do 65 | e <- readIORef ref 66 | case e of 67 | IVarFull a -> return a 68 | _ -> error "takeResult" 69 | 70 | 71 | dcSoundnessTest :: Test 72 | dcSoundnessTest = TestLabel "DataCache soundness" $ TestCase $ do 73 | m1 <- newResult 1 74 | m2 <- newResult "hello" 75 | cache <- emptyDataCache 76 | DataCache.insert (Req 2 :: TestReq String) m2 cache 77 | DataCache.insert (Req 1 :: TestReq Int) m1 cache 78 | 79 | -- "Req 1" has a result of type Int, so if we try to look it up 80 | -- with a result of type String, we should get Nothing, not a crash. 81 | r <- mapM takeResult =<< DataCache.lookup (Req 1) cache 82 | assertBool "dcSoundness1" $ 83 | case r :: Maybe (ResultVal String ()) of 84 | Nothing -> True 85 | _something_else -> False 86 | 87 | r <- mapM takeResult =<< DataCache.lookup (Req 1) cache 88 | assertBool "dcSoundness2" $ 89 | case r :: Maybe (ResultVal Int ()) of 90 | Just (Ok 1 Nothing) -> True 91 | _something_else -> False 92 | 93 | r <- mapM takeResult =<< DataCache.lookup (Req 2) cache 94 | assertBool "dcSoundness3" $ 95 | case r :: Maybe (ResultVal String ()) of 96 | Just (Ok "hello" Nothing) -> True 97 | _something_else -> False 98 | 99 | r <- mapM takeResult =<< DataCache.lookup (Req 2) cache 100 | assertBool "dcSoundness4" $ 101 | case r :: Maybe (ResultVal Int ()) of 102 | Nothing -> True 103 | _something_else -> False 104 | 105 | 106 | dcStrictnessTest :: Test 107 | dcStrictnessTest = TestLabel "DataCache strictness" $ TestCase $ do 108 | env <- initEnv stateEmpty () :: IO (Env () ()) 109 | r <- Control.Exception.try $ runHaxl env $ 110 | cachedComputation (Req (error "BOOM")) $ return "OK" 111 | assertBool "dcStrictnessTest" $ 112 | case r of 113 | Left (ErrorCall "BOOM") -> True 114 | _other -> False 115 | 116 | dcFallbackTest :: Test 117 | dcFallbackTest = TestLabel "DataCache fallback" $ TestList 118 | [ TestLabel "Base" $ TestCase $ do 119 | env <- mkEnv 120 | (r,cached) <- runHaxl env (do 121 | a <- dataFetch req 122 | b <- cacheResult (CacheableInt 1234) (return 99999) 123 | return (a,b)) 124 | (Stats stats) <- readIORef (statsRef env) 125 | assertEqual "fallback still has stats" 1 126 | (Prelude.length [x | x@FetchStats{} <- stats]) 127 | assertEqual "dcFallbackTest found" 1 r 128 | assertEqual "dcFallbackTest cached" 1234 cached 129 | , TestLabel "Exception" $ TestCase $ do 130 | env <- mkEnv 131 | rbad <- Control.Exception.try $ runHaxl env (dataFetch reqBad) 132 | assertBool "dcFallbackTest not found" $ 133 | case rbad of 134 | Left (ErrorCall "no fetch defined") -> True 135 | _ -> False 136 | , TestLabel "Completions" $ TestCase $ do 137 | -- check applicative still runs as it would have without a fallback 138 | env <- mkEnv 139 | let 140 | fetchA = dataFetch reqEx 141 | fetchB = tellWrite 7 >> dataFetch req 142 | (rbad, writes) <- runHaxlWithWrites env $ 143 | Haxl.Core.try $ (,) <$> fetchA <*> fetchB 144 | fetches <- countFetches env 145 | assertEqual "dispatched 2 fetches" 2 fetches 146 | assertBool "exception propogates" $ 147 | case rbad of 148 | Left (NotFound _) -> True 149 | _ -> False 150 | assertEqual "write side effects happen" [7] (flattenWT writes) 151 | ] 152 | where 153 | 154 | mkEnv = addLookup <$> initEnv (stateSet TestReqState stateEmpty) () 155 | 156 | countFetches env = do 157 | (Stats stats) <- readIORef (statsRef env) 158 | let 159 | c = sum [ fetchBatchSize x 160 | | x@FetchStats{} <- stats 161 | ] 162 | return c 163 | 164 | addLookup :: Env () (WriteTree Int) -> Env () (WriteTree Int) 165 | addLookup e = e { dataCacheFetchFallback = Just (DataCacheLookup lookup) 166 | , flags = (flags e) { report = profilingReportFlags } 167 | } 168 | lookup 169 | :: forall req a . Typeable (req a) 170 | => req a 171 | -> IO (Maybe (ResultVal a (WriteTree Int))) 172 | lookup r 173 | | typeOf r == typeRep (Proxy :: Proxy (TestReq Int)) = 174 | -- have to coerce on the way out as results are not Typeable 175 | -- so you better be sure you do it right! 176 | return $ unsafeCoerce . doReq <$> cast r 177 | | typeOf r == typeRep (Proxy :: Proxy (CacheableReq Int)) = 178 | return $ unsafeCoerce . doCache <$> cast r 179 | | otherwise = return Nothing 180 | 181 | doReq :: TestReq Int -> ResultVal Int (WriteTree Int) 182 | doReq (Req 999) = ThrowHaxl (toException $ NotFound Text.empty) Nothing 183 | doReq (Req r) = Ok r Nothing 184 | 185 | doCache :: CacheableReq Int -> ResultVal Int (WriteTree Int) 186 | doCache (CacheableInt i) = Ok i Nothing 187 | 188 | req :: TestReq Int 189 | req = Req 1 190 | 191 | reqEx :: TestReq Int 192 | reqEx = Req 999 193 | 194 | reqBad :: TestReq String 195 | reqBad = Req 2 196 | 197 | 198 | -- tests :: Assertion 199 | tests = TestList [ dcSoundnessTest 200 | , dcStrictnessTest 201 | , dcFallbackTest 202 | ] 203 | -------------------------------------------------------------------------------- /tests/DataSourceDispatchTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE OverloadedStrings #-} 16 | {-# LANGUAGE ApplicativeDo #-} 17 | 18 | module DataSourceDispatchTests (tests) where 19 | import Test.HUnit hiding (State) 20 | import Control.Monad 21 | import Haxl.Core 22 | import Data.Hashable 23 | 24 | data DataSourceDispatch ty where 25 | GetBatchSize :: Int -> DataSourceDispatch Int 26 | 27 | deriving instance Eq (DataSourceDispatch ty) 28 | deriving instance Show (DataSourceDispatch ty) 29 | 30 | instance DataSourceName DataSourceDispatch where 31 | dataSourceName _ = "DataSourceDispatch" 32 | 33 | instance StateKey DataSourceDispatch where 34 | data State DataSourceDispatch = DataSourceDispatchState 35 | 36 | instance ShowP DataSourceDispatch where showp = show 37 | 38 | instance Hashable (DataSourceDispatch a) where 39 | hashWithSalt s (GetBatchSize n) = hashWithSalt s n 40 | 41 | initDataSource :: IO (State DataSourceDispatch) 42 | initDataSource = return DataSourceDispatchState 43 | 44 | instance DataSource UserEnv DataSourceDispatch where 45 | fetch _state _flags _u = SyncFetch $ \bfs -> forM_ bfs (fill $ length bfs) 46 | where 47 | fill :: Int -> BlockedFetch DataSourceDispatch -> IO () 48 | fill l (BlockedFetch (GetBatchSize _ ) rv) = putResult rv (Right l) 49 | 50 | schedulerHint Batching = TryToBatch 51 | schedulerHint NoBatching = SubmitImmediately 52 | 53 | data UserEnv = Batching | NoBatching deriving (Eq) 54 | 55 | makeTestEnv :: UserEnv -> IO (Env UserEnv ()) 56 | makeTestEnv testUsrEnv = do 57 | st <- initDataSource 58 | e <- initEnv (stateSet st stateEmpty) testUsrEnv 59 | return e { flags = (flags e) { 60 | report = setReportFlag ReportFetchStats defaultReportFlags } } 61 | 62 | schedulerTest:: Test 63 | schedulerTest = TestCase $ do 64 | let 65 | fet = do 66 | x <- dataFetch (GetBatchSize 0) 67 | y <- dataFetch (GetBatchSize 1) 68 | return [x,y] 69 | 70 | e <- makeTestEnv Batching 71 | r1 :: [Int] <- runHaxl e fet 72 | assertEqual "Failed to create batches for data fetch" [2,2] r1 73 | 74 | eNoBatching <- makeTestEnv NoBatching 75 | r2 :: [Int] <- runHaxl eNoBatching fet 76 | assertEqual "Unexpexted batches in SubmitImmediately" [1,1] r2 77 | 78 | return () 79 | 80 | tests :: Test 81 | tests = TestList 82 | [ TestLabel "schedulerTest" schedulerTest 83 | ] 84 | -------------------------------------------------------------------------------- /tests/ExampleDataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 16 | {-# LANGUAGE FlexibleInstances #-} 17 | 18 | module ExampleDataSource ( 19 | -- * initialise the state 20 | initGlobalState, 21 | 22 | -- * requests for this data source 23 | Id(..), ExampleReq(..), 24 | countAardvarks, 25 | listWombats, 26 | ) where 27 | 28 | import Haxl.Prelude 29 | import Prelude () 30 | 31 | import Haxl.Core 32 | 33 | import Data.Typeable 34 | import Data.Hashable 35 | import Control.Concurrent 36 | import qualified Control.Exception as E 37 | import System.IO 38 | 39 | -- Here is an example minimal data source. Our data source will have 40 | -- two requests: 41 | -- 42 | -- countAardvarks :: String -> Haxl Int 43 | -- listWombats :: Id -> Haxl [Id] 44 | -- 45 | -- First, the data source defines a request type, with one constructor 46 | -- for each request: 47 | 48 | newtype Id = Id Int 49 | deriving (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable) 50 | 51 | instance Show Id where 52 | show (Id i) = show i 53 | 54 | data ExampleReq a where 55 | CountAardvarks :: String -> ExampleReq Int 56 | ListWombats :: Id -> ExampleReq [Id] 57 | deriving Typeable -- requests must be Typeable 58 | 59 | -- The request type (ExampleReq) is parameterized by the result type of 60 | -- each request. Each request might have a different result, so we use a 61 | -- GADT - a data type in which each constructor may have different type 62 | -- parameters. Here CountAardvarks is a request that takes a String 63 | -- argument and its result is Int, whereas ListWombats takes an Id 64 | -- argument and returns a [Id]. 65 | 66 | -- The request type needs instances for 'Eq1' and 'Hashable1'. These 67 | -- are like 'Eq' and 'Hashable', but for types with one parameter 68 | -- where the parameter is irrelevant for hashing and equality. 69 | -- These two instances are used to support caching of requests. 70 | 71 | -- We need Eq, but we have to derive it with a standalone declaration 72 | -- like this, because plain deriving doesn't work with GADTs. 73 | deriving instance Eq (ExampleReq a) 74 | 75 | deriving instance Show (ExampleReq a) 76 | 77 | instance ShowP ExampleReq where showp = show 78 | 79 | instance Hashable (ExampleReq a) where 80 | hashWithSalt s (CountAardvarks a) = hashWithSalt s (0::Int,a) 81 | hashWithSalt s (ListWombats a) = hashWithSalt s (1::Int,a) 82 | 83 | instance StateKey ExampleReq where 84 | data State ExampleReq = ExampleState { 85 | -- in here you can put any state that the 86 | -- data source needs to maintain throughout the 87 | -- run. 88 | } 89 | 90 | -- Next we need to define an instance of DataSourceName: 91 | 92 | instance DataSourceName ExampleReq where 93 | dataSourceName _ = "ExampleDataSource" 94 | 95 | -- Next we need to define an instance of DataSource: 96 | 97 | instance DataSource u ExampleReq where 98 | -- I'll define exampleFetch below 99 | fetch = exampleFetch 100 | 101 | -- we don't want to treat NotFound as an exception for stats purposes 102 | classifyFailure _ _ e 103 | | Just NotFound{} <- E.fromException e = IgnoredForStatsFailure 104 | | otherwise = StandardFailure 105 | 106 | 107 | -- Every data source should define a function 'initGlobalState' that 108 | -- initialises the state for that data source. The arguments to this 109 | -- function might vary depending on the data source - we might need to 110 | -- pass in resources from the environment, or parameters to set up the 111 | -- data source. 112 | initGlobalState :: IO (State ExampleReq) 113 | initGlobalState = do 114 | -- initialize the state here. 115 | return ExampleState { } 116 | 117 | 118 | -- The most important bit: fetching the data. The fetching function 119 | -- takes a list of BlockedFetch, which is defined as 120 | -- 121 | -- data BlockedFetch r 122 | -- = forall a . BlockedFetch (r a) (ResultVar a) 123 | -- 124 | -- That is, each BlockedFetch is a pair of 125 | -- 126 | -- - the request to fetch (with result type a) 127 | -- - a ResultVar to store either the result or an error 128 | -- 129 | -- The job of fetch is to fetch the data and fill in all the ResultVars. 130 | -- 131 | exampleFetch :: State ExampleReq -- current state 132 | -> Flags -- tracing verbosity, etc. 133 | -> u -- user environment 134 | -> PerformFetch ExampleReq -- tells the framework how to fetch 135 | 136 | exampleFetch _state _flags _user = SyncFetch $ mapM_ fetch1 137 | 138 | -- There are two ways a data source can fetch data: synchronously or 139 | -- asynchronously. See the type 'PerformFetch' in "Haxl.Core.Types" for 140 | -- details. 141 | 142 | fetch1 :: BlockedFetch ExampleReq -> IO () 143 | fetch1 (BlockedFetch (CountAardvarks "BANG") _) = 144 | error "BANG" -- data sources should not throw exceptions, but in 145 | -- the event that one does, the framework will 146 | -- propagate the exception to the call site of 147 | -- dataFetch. 148 | fetch1 (BlockedFetch (CountAardvarks "BANG2") m) = do 149 | putSuccess m 1 150 | error "BANG2" -- the exception is propagated even if we have already 151 | -- put the result with putSuccess 152 | fetch1 (BlockedFetch (CountAardvarks "BANG3") _) = do 153 | hPutStr stderr "BANG3" 154 | killThread =<< myThreadId -- an asynchronous exception 155 | fetch1 (BlockedFetch (CountAardvarks "BANG4") r) = do 156 | putFailure r $ NotFound "BANG4" 157 | fetch1 (BlockedFetch (CountAardvarks str) m) = 158 | putSuccess m (length (filter (== 'a') str)) 159 | fetch1 (BlockedFetch (ListWombats a) r) = 160 | if a > 999999 161 | then putFailure r $ FetchError "too large" 162 | else putSuccess r $ take (fromIntegral a) [1..] 163 | 164 | 165 | -- Normally a data source will provide some convenient wrappers for 166 | -- its requests: 167 | 168 | countAardvarks :: String -> GenHaxl u w Int 169 | countAardvarks str = dataFetch (CountAardvarks str) 170 | 171 | listWombats :: Id -> GenHaxl u w [Id] 172 | listWombats i = dataFetch (ListWombats i) 173 | -------------------------------------------------------------------------------- /tests/ExceptionStackTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | 12 | module ExceptionStackTests (tests) where 13 | 14 | import Prelude () 15 | import Haxl.Core 16 | import Haxl.Prelude 17 | 18 | import Test.HUnit 19 | 20 | import qualified ExampleDataSource 21 | 22 | testEnv :: ReportFlags -> IO (Env () ()) 23 | testEnv report = do 24 | exstate <- ExampleDataSource.initGlobalState 25 | let st = stateSet exstate stateEmpty 26 | env <- initEnv st () 27 | return env{ flags = (flags env){ report = report } } 28 | 29 | reportFlags :: ReportFlags 30 | reportFlags = setReportFlag ReportExceptionLabelStack defaultReportFlags 31 | 32 | runHaxlTest 33 | :: ReportFlags 34 | -> String 35 | -> (Int -> Int -> GenHaxl () () Int) 36 | -> IO (Maybe [Text]) 37 | runHaxlTest report str func = do 38 | env <- testEnv report 39 | result <- runHaxl env $ 40 | withLabel "try" $ tryToHaxlException $ withLabel "test" $ do 41 | x <- withLabel "dummy" $ pure 1 42 | y <- withLabel "fetch" $ ExampleDataSource.countAardvarks str 43 | withLabel "func" $ func x y 44 | case result of 45 | Left (HaxlException stk _) -> return stk 46 | Right{} -> assertFailure "expected: HaxlException" 47 | 48 | fetchException :: Test 49 | fetchException = TestCase $ do 50 | result <- runHaxlTest reportFlags "BANG4" $ \i j -> return $ i + j 51 | assertEqual "stack" (Just ["fetch", "test", "try", "MAIN"]) result 52 | 53 | userException :: Test 54 | userException = TestCase $ do 55 | result <- runHaxlTest reportFlags "aaa" $ \_ _ -> withLabel "throw" $ 56 | throw $ InvalidParameter "throw" 57 | assertEqual "stack" (Just ["throw", "func", "test", "try", "MAIN"]) result 58 | 59 | #ifndef PROFILING 60 | disabledExceptionStack :: Test 61 | disabledExceptionStack = TestCase $ do 62 | result <- runHaxlTest defaultReportFlags "BANG4" $ \i j -> return $ i + j 63 | assertEqual "stack" Nothing result 64 | #endif 65 | 66 | tests :: Test 67 | tests = TestList 68 | [ TestLabel "FetchException" fetchException 69 | , TestLabel "UserException" userException 70 | #ifndef PROFILING 71 | , TestLabel "DisabledExceptionStack" disabledExceptionStack 72 | #endif 73 | ] 74 | -------------------------------------------------------------------------------- /tests/FBMain.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module FBMain (main) where 10 | 11 | import Facebook.Init 12 | import TestRunner 13 | import AllTests 14 | 15 | main :: IO () 16 | main = withFacebookUnitTest $ testRunner $ allTests 17 | -------------------------------------------------------------------------------- /tests/FullyAsyncTest.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module FullyAsyncTest where 10 | 11 | import Haxl.Prelude as Haxl 12 | import Prelude() 13 | 14 | import SleepDataSource 15 | import Haxl.DataSource.ConcurrentIO 16 | 17 | import Haxl.Core 18 | import Test.HUnit 19 | import Data.IORef 20 | import Haxl.Core.Monad (unsafeLiftIO) 21 | 22 | tests :: Test 23 | tests = sleepTest 24 | 25 | testEnv :: IO (Env () ()) 26 | testEnv = do 27 | st <- mkConcurrentIOState 28 | env <- initEnv (stateSet st stateEmpty) () 29 | return env { flags = (flags env) { 30 | report = setReportFlag ReportFetchStats defaultReportFlags } } 31 | 32 | sleepTest :: Test 33 | sleepTest = TestCase $ do 34 | env <- testEnv 35 | 36 | ref <- newIORef ([] :: [Int]) 37 | let tick n = unsafeLiftIO (modifyIORef ref (n:)) 38 | 39 | -- simulate running a selection of data fetches that complete at 40 | -- different times, overlapping them as much as possible. 41 | runHaxl env $ 42 | sequence_ 43 | [ sequence_ [sleep 100, sleep 400] `andThen` tick 5 -- A 44 | , sleep 100 `andThen` tick 2 `andThen` sleep 200 `andThen` tick 4 -- B 45 | , sleep 50 `andThen` tick 1 `andThen` sleep 150 `andThen` tick 3 -- C 46 | ] 47 | 48 | ys <- readIORef ref 49 | assertEqual "FullyAsyncTest: ordering" [1,2,3,4,5] (reverse ys) 50 | 51 | stats <- readIORef (statsRef env) 52 | print stats 53 | assertEqual "FullyAsyncTest: stats" 5 (numFetches stats) 54 | 55 | {- 56 | A B C 57 | 50 | | tick 1 58 | 100 | tick 2 | 59 | 150 | | | 60 | 200 | | tick 3 61 | 250 | | 62 | 300 | tick 4 63 | 350 | 64 | 400 | 65 | 450 | 66 | 500 tick 5 67 | -} 68 | -------------------------------------------------------------------------------- /tests/LoadCache.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE CPP, OverloadedStrings #-} 10 | module LoadCache where 11 | 12 | import Haxl.Core 13 | import ExampleDataSource 14 | 15 | #include "LoadCache.txt" 16 | -------------------------------------------------------------------------------- /tests/LoadCache.txt: -------------------------------------------------------------------------------- 1 | loadCache :: GenHaxl u w () 2 | loadCache = do 3 | cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy"))) 4 | cacheRequest (CountAardvarks "xxx") (Right (3)) 5 | cacheRequest (ListWombats 100) (Right ([1,2,3])) 6 | -------------------------------------------------------------------------------- /tests/MemoizationTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module MemoizationTests (tests) where 10 | 11 | import Data.IORef 12 | 13 | import Test.HUnit 14 | 15 | import Haxl.Core 16 | import Haxl.Core.Monad (unsafeLiftIO) 17 | 18 | import ExampleDataSource 19 | 20 | memoSoundness :: Test 21 | memoSoundness = TestCase $ do 22 | iEnv <- do 23 | exState <- ExampleDataSource.initGlobalState 24 | initEnv (stateSet exState stateEmpty) () :: IO (Env () ()) 25 | 26 | unMemoizedWombats <- runHaxl iEnv $ listWombats 100 27 | 28 | (initialGet, subsequentGet) <- runHaxl iEnv $ do 29 | wombatsMemo <- newMemoWith (listWombats 100) 30 | let memoizedWombats = runMemo wombatsMemo 31 | 32 | initialGet <- memoizedWombats 33 | subsequentGet <- memoizedWombats 34 | 35 | return (initialGet, subsequentGet) 36 | 37 | assertBool "Memo Soundness 1" $ initialGet == unMemoizedWombats 38 | assertBool "Memo Soundness 2" $ subsequentGet == unMemoizedWombats 39 | 40 | let impure runCounterRef = unsafeLiftIO $ do 41 | modifyIORef runCounterRef succ 42 | readIORef runCounterRef 43 | 44 | initialRunCounter = 0 :: Int 45 | 46 | runCounterRef <- newIORef initialRunCounter 47 | 48 | (initialImpureGet, subsequentImpureGet) <- runHaxl iEnv $ do 49 | impureMemo <- newMemoWith (impure runCounterRef) 50 | let memoizedImpure = runMemo impureMemo 51 | 52 | initialImpureGet <- memoizedImpure 53 | subsequentImpureGet <- memoizedImpure 54 | 55 | return (initialImpureGet, subsequentImpureGet) 56 | 57 | assertBool "Memo Soundness 3" $ initialImpureGet == succ initialRunCounter 58 | assertBool "Memo Soundness 4" $ subsequentImpureGet == initialImpureGet 59 | 60 | let fMemoVal = 42 :: Int 61 | 62 | dependentResult <- runHaxl iEnv $ do 63 | fMemoRef <- newMemo 64 | gMemoRef <- newMemo 65 | 66 | let f = runMemo fMemoRef 67 | g = runMemo gMemoRef 68 | 69 | prepareMemo fMemoRef $ return fMemoVal 70 | prepareMemo gMemoRef $ succ <$> f 71 | 72 | a <- f 73 | b <- g 74 | return (a + b) 75 | 76 | assertBool "Memo Soundness 5" $ dependentResult == fMemoVal + succ fMemoVal 77 | 78 | tests = TestList [TestLabel "Memo Soundness" memoSoundness] 79 | -------------------------------------------------------------------------------- /tests/MockTAO.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | {-# LANGUAGE FlexibleInstances #-} 17 | {-# LANGUAGE RecordWildCards #-} 18 | 19 | module MockTAO ( 20 | Id(..), 21 | initGlobalState, 22 | assocRangeId2s, 23 | friendsAssoc, 24 | friendsOf, 25 | ) where 26 | 27 | import Data.Hashable 28 | import Data.Map (Map) 29 | import Data.Typeable 30 | import Prelude () 31 | import qualified Data.Map as Map 32 | import qualified Data.Text as Text 33 | import Control.Concurrent 34 | import Control.Exception 35 | import Control.Monad (void) 36 | 37 | 38 | import Haxl.Prelude 39 | import Haxl.Core 40 | 41 | import TestTypes 42 | 43 | -- ----------------------------------------------------------------------------- 44 | -- Minimal mock TAO 45 | 46 | data TAOReq a where 47 | AssocRangeId2s :: Id -> Id -> TAOReq [Id] 48 | deriving Typeable 49 | 50 | deriving instance Show (TAOReq a) 51 | deriving instance Eq (TAOReq a) 52 | 53 | instance ShowP TAOReq where showp = show 54 | 55 | instance Hashable (TAOReq a) where 56 | hashWithSalt s (AssocRangeId2s a b) = hashWithSalt s (a,b) 57 | 58 | instance StateKey TAOReq where 59 | data State TAOReq = TAOState { future :: Bool } 60 | 61 | instance DataSourceName TAOReq where 62 | dataSourceName _ = "MockTAO" 63 | 64 | instance DataSource UserEnv TAOReq where 65 | fetch TAOState{..} _flags _user 66 | | future = BackgroundFetch $ \f -> do 67 | mask_ $ void . forkIO $ mapM_ (doFetch True) f 68 | | otherwise = SyncFetch $ mapM_ (doFetch False) 69 | 70 | initGlobalState :: Bool -> IO (State TAOReq) 71 | initGlobalState future = return TAOState { future=future } 72 | 73 | doFetch :: Bool -> BlockedFetch TAOReq -> IO () 74 | doFetch bg (BlockedFetch req@(AssocRangeId2s a b) r) = put result 75 | where put = if bg then putResultFromChildThread r else putResult r 76 | result = case Map.lookup (a, b) assocs of 77 | Nothing -> except . NotFound . Text.pack $ show req 78 | Just result -> Right result 79 | 80 | 81 | assocs :: Map (Id,Id) [Id] 82 | assocs = Map.fromList [ 83 | ((friendsAssoc, 1), [5..10]), 84 | ((friendsAssoc, 2), [7..12]), 85 | ((friendsAssoc, 3), [10..15]), 86 | ((friendsAssoc, 4), [15..19]) 87 | ] 88 | 89 | friendsAssoc :: Id 90 | friendsAssoc = 167367433327742 91 | 92 | assocRangeId2s :: Id -> Id -> Haxl [Id] 93 | assocRangeId2s a b = dataFetch (AssocRangeId2s a b) 94 | 95 | friendsOf :: Id -> Haxl [Id] 96 | friendsOf = assocRangeId2s friendsAssoc 97 | -------------------------------------------------------------------------------- /tests/MonadAsyncTest.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE ApplicativeDo #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE FlexibleInstances #-} 16 | {-# LANGUAGE MultiParamTypeClasses #-} 17 | 18 | module MonadAsyncTest (tests) where 19 | import Haxl.Core 20 | import Test.HUnit hiding (State) 21 | import Control.Concurrent 22 | import Control.Exception as Exception 23 | import Control.Monad 24 | import Haxl.Core.Monad (unsafeLiftIO, WriteTree) 25 | import System.IO.Unsafe 26 | import Data.Hashable 27 | import Data.IORef 28 | import Data.Text (Text) 29 | 30 | newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show) 31 | 32 | {-# NOINLINE shouldThrowRef #-} 33 | shouldThrowRef :: IORef Bool 34 | shouldThrowRef = unsafePerformIO (newIORef False) 35 | 36 | -- | This datasource contains "bad" code which can throw at the wrong 37 | -- moment. 38 | data ThrowableSleep a where 39 | Sleep :: Int -> ThrowableSleep Int 40 | 41 | deriving instance Eq (ThrowableSleep a) 42 | deriving instance Show (ThrowableSleep a) 43 | 44 | instance ShowP ThrowableSleep where showp = show 45 | 46 | instance Hashable (ThrowableSleep a) where 47 | hashWithSalt s (Sleep n) = hashWithSalt s n 48 | 49 | instance StateKey ThrowableSleep where 50 | data State ThrowableSleep = ThrowableSleepState 51 | 52 | initDataSource :: IO (State ThrowableSleep) 53 | initDataSource = return ThrowableSleepState 54 | 55 | instance DataSourceName ThrowableSleep where 56 | dataSourceName _ = "ThrowableSleep" 57 | 58 | instance DataSource u ThrowableSleep where 59 | fetch _state _flags _u = BackgroundFetch $ \bfs -> forM_ bfs fill 60 | where 61 | fill :: BlockedFetch ThrowableSleep -> IO () 62 | fill (BlockedFetch (Sleep n) rv) = do 63 | _ <- forkFinally 64 | (do 65 | threadDelay (n*1000) 66 | return n 67 | ) 68 | (\res -> do 69 | shouldThrow <- atomicModifyIORef' shouldThrowRef (\s -> (False, s)) 70 | -- Simulate case when datasource throws before putting Result into 71 | -- completions queue. 72 | when shouldThrow $ do 73 | throwIO $ ErrorCall "datasource threw an exception" 74 | -- In case the datasource throws before this point, there'll be 75 | -- nothing to put the result to the queue of 'completions', and 76 | -- therefore Haxl would block indefinitely. 77 | -- 78 | -- Note that Haxl tries to catch datasource exceptions and put the 79 | -- "exception result" into `completions` using `wrapFetchInCatch` 80 | -- function. However that doesn't work in this case because the 81 | -- datasource throws in a separate thread. 82 | putResultFromChildThread rv res 83 | ) 84 | return () 85 | 86 | tests :: Test 87 | tests = TestList 88 | [ TestLabel "exceptionTest" exceptionTest 89 | ] 90 | 91 | mkTestEnv :: IO (Env () (WriteTree SimpleWrite)) 92 | mkTestEnv = do 93 | st <- initDataSource 94 | initEnv (stateSet st stateEmpty) () 95 | 96 | exceptionTest :: Test 97 | exceptionTest = TestCase $ do 98 | e <- mkTestEnv 99 | 100 | let 101 | fet (n :: Int) (st :: Bool )= do 102 | x <- dataFetch (Sleep (fromIntegral n)) 103 | unsafeLiftIO $ writeIORef shouldThrowRef st 104 | y <- dataFetch (Sleep (fromIntegral x*2)) 105 | return (x+y) 106 | 107 | r1 :: (Either Exception.SomeException Int) 108 | <- Exception.try $ runHaxl e $ fet 10 True 109 | 110 | -- Datasources are responsible for putting the fetched result into the 111 | -- completions queue. If for some reason they fail to do so, Haxl throws a 112 | -- LogicBug since the scheduler is still expecting some request(s) to 113 | -- be completed. 114 | case r1 of 115 | Left ex | Just (LogicBug _) <- Exception.fromException ex -> return () 116 | _ -> assertFailure "r1 computation did not fail with Logic Bug!" 117 | 118 | -- Sanitize the env to get rid of all empty IVars 119 | -- While this test examines the case when there's an exception in the Haxl 120 | -- datasource itself, a similar behavior will occur in case an async 121 | -- exception is thrown to the Haxl scheduler thread. 122 | e' <- sanitizeEnv e 123 | 124 | r2 :: (Either Exception.SomeException Int) 125 | <- Exception.try $ runHaxl e' $ fet 10 False 126 | case r2 of 127 | Right _ -> return () 128 | Left ex | Just (LogicBug _) <- Exception.fromException ex -> do 129 | assertFailure $ "bad exception in r2: " ++ show ex 130 | Left _ -> return () 131 | -------------------------------------------------------------------------------- /tests/MonadBench.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | -- | Benchmarking tool for core performance characteristics of the Haxl monad. 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE ApplicativeDo, RecordWildCards #-} 12 | module MonadBench (main) where 13 | 14 | import Control.Monad 15 | import Data.List as List 16 | import Data.Maybe 17 | import Data.Time.Clock 18 | import Options.Applicative 19 | import System.Exit 20 | import System.IO 21 | import Text.Printf 22 | 23 | import Haxl.Prelude as Haxl 24 | import Prelude() 25 | 26 | import Haxl.Core 27 | import Haxl.Core.Monad (WriteTree) 28 | import Haxl.Core.Util 29 | 30 | import ExampleDataSource 31 | 32 | newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show) 33 | 34 | testEnv :: ReportFlags -> IO (Env () (WriteTree SimpleWrite)) 35 | testEnv report = do 36 | exstate <- ExampleDataSource.initGlobalState 37 | let st = stateSet exstate stateEmpty 38 | env <- initEnv st () 39 | return env { flags = (flags env) { report = report } } 40 | 41 | type Test = (String, Int, Int -> GenHaxl () (WriteTree SimpleWrite) ()) 42 | 43 | testName :: Test -> String 44 | testName (t,_,_) = t 45 | 46 | allTests :: [Test] 47 | allTests = 48 | -- parallel, identical queries 49 | [ ("par1", large, \n -> Haxl.sequence_ (replicate n (listWombats 3))) 50 | -- parallel, distinct queries 51 | , ("par2", medium, \n -> 52 | Haxl.sequence_ (map listWombats [1..fromIntegral n])) 53 | -- sequential, identical queries 54 | , ("seqr", huge, \n -> 55 | foldr andThen (return ()) (replicate n (listWombats 3))) 56 | -- sequential, left-associated, distinct queries 57 | , ("seql", medium, \n -> do 58 | _ <- foldl andThen (return []) (map listWombats [1.. fromIntegral n]) 59 | return ()) 60 | -- No memoization 61 | , ("memo0", small, \n -> Haxl.sequence_ [unionWombats | _ <- [1..n]]) 62 | -- One put, N gets. 63 | , ("memo1", medium_large, \n -> 64 | Haxl.sequence_ [memo (42 :: Int) unionWombats | _ <- [1..n]]) 65 | -- N puts, N gets. 66 | , ("memo2", small, \n -> 67 | Haxl.sequence_ [memo (i :: Int) unionWombats | i <- [1..n]]) 68 | , ("memo3", medium_large, \n -> do 69 | ref <- newMemoWith unionWombats 70 | let c = runMemo ref 71 | Haxl.sequence_ [c | _ <- [1..n]]) 72 | , ("memo4", small, \n -> do 73 | let f = unionWombatsTo 74 | Haxl.sequence_ [f x | x <- take n $ cycle [100, 200 .. 1000]]) 75 | , ("memo5", medium_large, \n -> do 76 | f <- memoize1 unionWombatsTo 77 | Haxl.sequence_ [f x | x <- take n $ cycle [100, 200 .. 1000]]) 78 | , ("memo6", small, \n -> do 79 | let f = unionWombatsFromTo 80 | Haxl.sequence_ [ f x y 81 | | x <- take n $ cycle [100, 200 .. 1000] 82 | , let y = x + 1000 83 | ]) 84 | , ("memo7", medium_large, \n -> do 85 | f <- memoize2 unionWombatsFromTo 86 | Haxl.sequence_ [ f x y 87 | | x <- take n $ cycle [100, 200 .. 1000] 88 | , let y = x + 1000 89 | ]) 90 | , ("cc1", medium_large, \n -> 91 | Haxl.sequence_ [ cachedComputation (ListWombats 1000) unionWombats 92 | | _ <- [1..n] 93 | ]) 94 | , ("tree", 20, \n -> void $ tree n (\_ act -> act)) 95 | , ("tree_labels", 20, \n -> void $ 96 | tree n (\n act -> withLabel (textShow n) act)) 97 | -- parallel writes 98 | , ("write1", large, \n -> 99 | Haxl.sequence_ (replicate n (tellWrite (SimpleWrite "haha")))) 100 | -- sequential writes 101 | , ("write2", huge, \n -> foldr 102 | andThen 103 | (return ()) 104 | (replicate n (tellWrite (SimpleWrite "haha")))) 105 | ] 106 | where 107 | huge = large * 10 108 | large = medium * 10 109 | medium_large = medium * 4 110 | medium = 200000 111 | small = 1000 112 | 113 | data Options = Options 114 | { test :: String 115 | , nOverride :: Maybe Int 116 | , reportFlag :: ReportFlags 117 | } 118 | 119 | runTest :: Options -> Test -> IO () 120 | runTest Options{..} (t, nDef, act) = do 121 | let n = fromMaybe nDef nOverride 122 | env <- testEnv reportFlag 123 | t0 <- getCurrentTime 124 | runHaxl env $ act n 125 | t1 <- getCurrentTime 126 | printf "%12s: %10d reqs: %.2fs\n" 127 | t n (realToFrac (t1 `diffUTCTime` t0) :: Double) 128 | 129 | optionsParser :: Parser Options 130 | optionsParser = do 131 | test <- argument str (metavar "TEST") 132 | reportFlag <- reportFlagParser 133 | nOverride <- optional $ argument auto (metavar "NUM") 134 | return Options{..} 135 | where 136 | reportFlagParser = foldl' (flip ($)) defaultReportFlags <$> sequenceA 137 | [ flag id (setReportFlag i) $ long $ show i 138 | | i <- enumFrom minBound 139 | ] 140 | 141 | main :: IO () 142 | main = do 143 | opts@Options{..} <- execParser $ info optionsParser mempty 144 | let tests = if test == "all" 145 | then allTests 146 | else filter ((==) test . testName) allTests 147 | when 148 | (null tests) 149 | (do 150 | hPutStrLn stderr $ "syntax: monadbench [all|" ++ 151 | intercalate "|" (map testName allTests) ++ "]" 152 | exitWith (ExitFailure 1)) 153 | Control.Monad.mapM_ (runTest opts) tests 154 | 155 | tree 156 | :: Int 157 | -> (Int -> GenHaxl () (WriteTree SimpleWrite) [Id] 158 | -> GenHaxl () (WriteTree SimpleWrite) [Id]) 159 | -> GenHaxl () (WriteTree SimpleWrite) [Id] 160 | tree 0 wrap = wrap 0 $ listWombats 0 161 | tree n wrap = wrap n $ concat <$> Haxl.sequence 162 | [ tree (n-1) wrap 163 | , listWombats (fromIntegral n), tree (n-1) wrap 164 | ] 165 | 166 | unionWombats :: GenHaxl () (WriteTree SimpleWrite) [Id] 167 | unionWombats = foldl List.union [] <$> Haxl.mapM listWombats [1..1000] 168 | 169 | unionWombatsTo :: Id -> GenHaxl () (WriteTree SimpleWrite) [Id] 170 | unionWombatsTo x = foldl List.union [] <$> Haxl.mapM listWombats [1..x] 171 | 172 | unionWombatsFromTo :: Id -> Id -> GenHaxl () (WriteTree SimpleWrite) [Id] 173 | unionWombatsFromTo x y = foldl List.union [] <$> Haxl.mapM listWombats [x..y] 174 | -------------------------------------------------------------------------------- /tests/OutgoneFetchesTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE ApplicativeDo #-} 11 | module OutgoneFetchesTests (tests) where 12 | 13 | import Haxl.Prelude as Haxl 14 | import Prelude() 15 | 16 | import Haxl.Core 17 | import Haxl.DataSource.ConcurrentIO 18 | 19 | import Data.IORef 20 | import qualified Data.Map as Map 21 | import Data.Typeable 22 | import Test.HUnit 23 | import System.Timeout 24 | 25 | import ExampleDataSource 26 | import SleepDataSource 27 | 28 | testEnv :: IO (Env () ()) 29 | testEnv = do 30 | exstate <- ExampleDataSource.initGlobalState 31 | sleepState <- mkConcurrentIOState 32 | let st = stateSet exstate $ stateSet sleepState stateEmpty 33 | e <- initEnv st () 34 | return e { flags = (flags e) { 35 | report = setReportFlag ReportOutgoneFetches defaultReportFlags } } 36 | -- report=1 to enable fetches tracking 37 | 38 | -- A cheap haxl computation we interleave b/w the @sleep@ fetches. 39 | wombats :: GenHaxl () () Int 40 | wombats = length <$> listWombats 3 41 | 42 | outgoneFetchesTest :: String -> Int -> GenHaxl () () a -> Test 43 | outgoneFetchesTest label unfinished haxl = TestLabel label $ TestCase $ do 44 | env <- testEnv 45 | _ <- timeout (100*1000) $ runHaxl env haxl -- 100ms 46 | actual <- getMapFromRCMap <$> readIORef (submittedReqsRef env) 47 | assertEqual "fetchesMap" expected actual 48 | where 49 | expected = if unfinished == 0 then Map.empty else 50 | Map.singleton (dataSourceName (Proxy :: Proxy (ConcurrentIOReq Sleep))) $ 51 | Map.singleton (typeOf1 (undefined :: ConcurrentIOReq Sleep a)) unfinished 52 | 53 | tests :: Test 54 | tests = TestList 55 | [ outgoneFetchesTest "finished" 0 $ do 56 | -- test that a completed datasource fetch doesn't show up in Env 57 | _ <- sleep 1 -- finished 58 | _ <- sleep 1 -- cached/finished 59 | _ <- sleep 1 -- cached/finished 60 | wombats 61 | , outgoneFetchesTest "unfinished" 2 $ do 62 | -- test that unfinished datasource fetches shows up in Env 63 | _ <- sleep 200 -- unfinished 64 | _ <- wombats 65 | _ <- sleep 300 -- unfinished 66 | _ <- wombats 67 | return () 68 | , outgoneFetchesTest "mixed" 2 $ do 69 | -- test for finished/unfinished fetches from the same datasource 70 | _ <- sleep 1 -- finished 71 | _ <- sleep 200 -- unfinished 72 | _ <- sleep 300 -- unfinished 73 | return () 74 | , outgoneFetchesTest "cached" 1 $ do 75 | -- test for cached requests not showing up twice in ReqCountMap 76 | _ <- sleep 200 -- unfinished 77 | _ <- sleep 200 -- cached/unfinished 78 | return () 79 | , outgoneFetchesTest "unsent" 1 $ 80 | -- test for unsent requests not showing up in ReqCountMap 81 | sleep 200 `andThen` sleep 300 -- second req should never be sent 82 | ] 83 | -------------------------------------------------------------------------------- /tests/ParallelTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | module ParallelTests where 10 | 11 | import Haxl.Prelude 12 | import Haxl.Core 13 | 14 | import Haxl.DataSource.ConcurrentIO 15 | import SleepDataSource 16 | 17 | import Data.Time.Clock 18 | 19 | import Test.HUnit 20 | 21 | testEnv :: IO (Env () ()) 22 | testEnv = do 23 | sleepState <- mkConcurrentIOState 24 | let st = stateSet sleepState stateEmpty 25 | initEnv st () 26 | 27 | sync_test :: IO () 28 | sync_test = do 29 | env <- testEnv 30 | -- This computation tests that the two arguments of the pOr can fire 31 | -- without causing an error. The reason we test for this is that the 32 | -- synchronization involved in this case is a little fragile. 33 | False <- runHaxl env $ do 34 | (fmap (const False) (sleep 50) 35 | `pOr` fmap (const False) (sleep 100)) 36 | `pOr` fmap (const False) (sleep 200) 37 | return () 38 | 39 | semantics_when_computation_is_blocked_test :: IO () 40 | semantics_when_computation_is_blocked_test = do 41 | env <- testEnv 42 | -- Test semantics of blocking 43 | let sleepReturn bool t = do 44 | _ <- sleep t 45 | return bool 46 | r <- runHaxl env $ do 47 | -- All sleep times are different so that they're not cached 48 | a <- sleepReturn False 10 `pOr` sleepReturn False 11 49 | b <- sleepReturn False 12 `pOr` sleepReturn True 13 50 | c <- sleepReturn True 14 `pOr` sleepReturn False 15 51 | d <- sleepReturn True 16 `pOr` sleepReturn True 17 52 | return (not a && b && c && d) 53 | assertBool "pOr blocked semantics" r 54 | 55 | 56 | timing_test = do 57 | env <- testEnv 58 | t0 <- getCurrentTime 59 | True <- runHaxl env $ 60 | fmap (const True) (sleep 200) `pOr` fmap (const True) (sleep 100) 61 | t1 <- getCurrentTime 62 | True <- runHaxl env $ 63 | fmap (const True) (sleep 100) `pOr` fmap (const True) (sleep 200) 64 | t2 <- getCurrentTime 65 | False <- runHaxl env $ 66 | fmap (const False) (sleep 200) `pOr` fmap (const False) (sleep 100) 67 | t3 <- getCurrentTime 68 | False <- runHaxl env $ 69 | fmap (const False) (sleep 100) `pOr` fmap (const False) (sleep 200) 70 | t4 <- getCurrentTime 71 | -- diffUTCTime returns the difference in seconds, 72 | -- while sleep expects milliseconds 73 | assert (t4 `diffUTCTime` t3 < 0.2) 74 | assert (t3 `diffUTCTime` t2 < 0.2) 75 | assert (t2 `diffUTCTime` t1 < 0.2) 76 | assert (t1 `diffUTCTime` t0 < 0.2) 77 | 78 | tests = TestList [TestLabel "sync_test" (TestCase sync_test) 79 | ,TestLabel "timing_test" (TestCase timing_test) 80 | ,TestLabel "semantics_when_computation_is_blocked_test" (TestCase semantics_when_computation_is_blocked_test) 81 | ] 82 | -------------------------------------------------------------------------------- /tests/ProfileTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE NoImplicitPrelude #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE CPP #-} 13 | 14 | module ProfileTests where 15 | 16 | import Haxl.Prelude 17 | 18 | import Haxl.Core 19 | import Haxl.Core.Monad 20 | import Haxl.Core.Stats 21 | 22 | import Test.HUnit 23 | 24 | import Control.DeepSeq (force) 25 | import Control.Exception (evaluate) 26 | import Data.Aeson 27 | import Data.IORef 28 | import qualified Data.HashMap.Strict as HashMap 29 | #if MIN_VERSION_aeson(2,0,0) 30 | import qualified Data.Aeson.KeyMap as KeyMap 31 | #else 32 | import qualified Data.HashMap.Strict as KeyMap 33 | #endif 34 | import Data.Int 35 | 36 | import TestTypes 37 | import TestUtils 38 | import WorkDataSource 39 | import SleepDataSource 40 | 41 | mkProfilingEnv :: IO HaxlEnv 42 | mkProfilingEnv = do 43 | env <- makeTestEnv False 44 | return env { flags = (flags env) { report = profilingReportFlags } } 45 | 46 | -- expects only one label to be shown 47 | labelToDataMap :: Profile -> HashMap.HashMap ProfileLabel ProfileData 48 | labelToDataMap Profile{..} = HashMap.fromList hashKeys 49 | where 50 | labelKeys = HashMap.fromList [ 51 | (k, l) | ((l, _), k) <- HashMap.toList profileTree] 52 | hashKeys = [ (l, v) 53 | | (k, v) <- HashMap.toList profile 54 | , Just l <- [HashMap.lookup k labelKeys]] 55 | 56 | collectsdata :: Assertion 57 | collectsdata = do 58 | e <- mkProfilingEnv 59 | _x <- runHaxl e $ 60 | withLabel "bar" $ 61 | withLabel "foo" $ do 62 | u <- env userEnv 63 | slp <- sum <$> mapM (\x -> withLabel "baz" $ return x) [1..5] 64 | -- do some non-trivial work that can't be lifted out 65 | -- first sleep though in order to force a Blocked result 66 | sleep slp `andThen` case fromJSON <$> KeyMap.lookup "A" u of 67 | Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5 68 | _otherwise -> return (4::Int) 69 | profCopy <- readIORef (profRef e) 70 | let 71 | profData = profile profCopy 72 | labelKeys = HashMap.fromList [ 73 | (l, k) | ((l, _), k) <- HashMap.toList (profileTree profCopy)] 74 | getData k = do 75 | k2 <- HashMap.lookup k labelKeys 76 | HashMap.lookup k2 profData 77 | assertEqual "has data" 4 $ HashMap.size profData 78 | assertBool "foo allocates" $ 79 | case profileAllocs <$> getData "foo" of 80 | Just x -> x > 10000 81 | Nothing -> False 82 | assertEqual "foo is only called once" (Just 1) $ 83 | profileLabelHits <$> getData "foo" 84 | assertEqual "baz is called 5 times" (Just 5) $ 85 | profileLabelHits <$> getData "baz" 86 | assertBool "bar does not allocate (much)" $ 87 | case profileAllocs <$> getData "bar" of 88 | Just n -> n < 5000 -- getAllocationCounter can be off by +/- 4K 89 | _otherwise -> False 90 | let fooParents = case HashMap.lookup "foo" labelKeys of 91 | Nothing -> [] 92 | Just kfoo -> 93 | [ kparent 94 | | ((_, kparent), k) <- HashMap.toList (profileTree profCopy) 95 | , k == kfoo] 96 | assertEqual "foo's parent" 1 (length fooParents) 97 | assertEqual "foo's parent is bar" (Just (head fooParents)) $ 98 | HashMap.lookup ("bar", 0) (profileTree profCopy) 99 | 100 | 101 | collectsLazyData :: Assertion 102 | collectsLazyData = do 103 | e <- mkProfilingEnv 104 | _x <- runHaxl e $ withLabel "bar" $ do 105 | u <- env userEnv 106 | withLabel "foo" $ do 107 | let start = if KeyMap.member "A" u 108 | then 10 109 | else 1 110 | return $ sum [start..10000::Integer] 111 | profCopy <- readIORef (profRef e) 112 | -- check the allocations are attributed to foo 113 | assertBool "foo has allocations" $ 114 | case profileAllocs <$> HashMap.lookup "foo" (labelToDataMap profCopy) of 115 | Just x -> x > 10000 116 | Nothing -> False 117 | 118 | exceptions :: Assertion 119 | exceptions = do 120 | env <- mkProfilingEnv 121 | _x <- runHaxl env $ 122 | withLabel "outer" $ 123 | tryToHaxlException $ withLabel "inner" $ 124 | unsafeLiftIO $ evaluate $ force (error "pure exception" :: Int) 125 | profData <- labelToDataMap <$> readIORef (profRef env) 126 | assertBool "inner label not added" $ 127 | not $ HashMap.member "inner" profData 128 | 129 | env2 <- mkProfilingEnv 130 | _x <- runHaxl env2 $ 131 | withLabel "outer" $ 132 | tryToHaxlException $ withLabel "inner" $ 133 | throw $ NotFound "haxl exception" 134 | profData <- labelToDataMap <$> readIORef (profRef env2) 135 | assertBool "inner label added" $ 136 | HashMap.member "inner" profData 137 | 138 | 139 | -- Test that we correctly attribute work done in child threads when 140 | -- using BackgroundFetch to the caller of runHaxl. This is important 141 | -- for correct accounting when relying on allocation limits. 142 | threadAlloc :: Integer -> Assertion 143 | threadAlloc batches = do 144 | env' <- initEnv (stateSet mkWorkState stateEmpty) () :: IO (Env () ()) 145 | let env = env' { flags = (flags env') { 146 | report = setReportFlag ReportFetchStats defaultReportFlags } } 147 | a0 <- getAllocationCounter 148 | let 149 | wsize = 100000 150 | w = forM [wsize..(wsize+batches-1)] work 151 | _x <- runHaxl env $ sum <$> w 152 | a1 <- getAllocationCounter 153 | let 154 | lower = fromIntegral $ 1000000 * batches 155 | upper = fromIntegral $ 25000000 * batches 156 | assertBool "threadAlloc lower bound" $ (a0 - a1) > lower 157 | assertBool "threadAlloc upper bound" $ (a0 - a1) < upper 158 | -- the result was 16MB on 64-bit, or around 25KB if we miss the allocs 159 | -- in the child thread. For batched it should be similarly scaled. 160 | -- When we do not reset the counter for each batch was 161 | -- scaled again by number of batches. 162 | 163 | stats <- readIORef (statsRef env) 164 | assertEqual 165 | "threadAlloc: batches" 166 | [fromIntegral batches] 167 | (aggregateFetchBatches length stats) 168 | -- if we actually do more than 1 batch then the above test is not useful 169 | 170 | data MemoType = Global | Local 171 | 172 | -- Test that we correctly attribute memo work 173 | memos:: MemoType -> Assertion 174 | memos memoType = do 175 | env <- mkProfilingEnv 176 | let 177 | memoAllocs = 10000000 :: Int64 178 | doWork = unsafeLiftIO $ do 179 | a0 <- getAllocationCounter 180 | setAllocationCounter $ a0 - memoAllocs 181 | return (5 :: Int) 182 | mkWork 183 | | Global <- memoType = return (memo (1 :: Int) doWork) 184 | | Local <- memoType = memoize doWork 185 | _ <- runHaxl env $ do 186 | work <- mkWork 187 | andThen 188 | (withLabel "do" work) 189 | (withLabel "cached" work) 190 | profData <- labelToDataMap <$> readIORef (profRef env) 191 | case HashMap.lookup "do" profData of 192 | Nothing -> assertFailure "do not in data" 193 | Just ProfileData{..} -> do 194 | assertEqual "has correct memo id" profileMemos [ProfileMemo 1 False] 195 | assertBool "allocs are included in 'do'" (profileAllocs >= memoAllocs) 196 | case HashMap.lookup "cached" profData of 197 | Nothing -> assertFailure "cached not in data" 198 | Just ProfileData{..} -> do 199 | assertEqual "has correct memo id" profileMemos [ProfileMemo 1 True] 200 | assertBool "allocs are *not* included in 'cached'" (profileAllocs < 50000) 201 | (Stats memoStats) <- readIORef (statsRef env) 202 | assertEqual "exactly 1 memo/fetch" 1 (length memoStats) 203 | let memoStat = head memoStats 204 | putStrLn $ "memoStat=" ++ show memoStat 205 | assertEqual "correct call id" 1 (memoStatId memoStat) 206 | assertBool "allocs are big enough" $ memoSpace memoStat >= memoAllocs 207 | assertBool "allocs are not too big" $ memoSpace memoStat < memoAllocs + 100000 208 | 209 | 210 | tests = TestList 211 | [ TestLabel "collectsdata" $ TestCase collectsdata 212 | , TestLabel "collectsdata - lazy" $ TestCase collectsLazyData 213 | , TestLabel "exceptions" $ TestCase exceptions 214 | , TestLabel "threads" $ TestCase (threadAlloc 1) 215 | , TestLabel "threads with batch" $ TestCase (threadAlloc 50) 216 | , TestLabel "memos - Global" $ TestCase (memos Global) 217 | , TestLabel "memos - Local" $ TestCase (memos Local) 218 | ] 219 | -------------------------------------------------------------------------------- /tests/SleepDataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 16 | {-# LANGUAGE FlexibleInstances #-} 17 | 18 | module SleepDataSource ( 19 | Sleep, sleep, 20 | ) where 21 | 22 | import Haxl.Prelude 23 | import Prelude () 24 | 25 | import Haxl.Core 26 | import Haxl.DataSource.ConcurrentIO 27 | 28 | import Control.Concurrent 29 | import Data.Hashable 30 | import Data.Typeable 31 | 32 | sleep :: Int -> GenHaxl u w Int 33 | sleep n = dataFetch (Sleep n) 34 | 35 | data Sleep deriving Typeable 36 | instance ConcurrentIO Sleep where 37 | data ConcurrentIOReq Sleep a where 38 | Sleep :: Int -> ConcurrentIOReq Sleep Int 39 | 40 | performIO (Sleep n) = threadDelay (n*1000) >> return n 41 | 42 | deriving instance Eq (ConcurrentIOReq Sleep a) 43 | deriving instance Show (ConcurrentIOReq Sleep a) 44 | 45 | instance ShowP (ConcurrentIOReq Sleep) where showp = show 46 | 47 | instance Hashable (ConcurrentIOReq Sleep a) where 48 | hashWithSalt s (Sleep n) = hashWithSalt s n 49 | -------------------------------------------------------------------------------- /tests/StatsTests.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 13 | 14 | module StatsTests (tests) where 15 | 16 | import Test.HUnit 17 | import Data.List 18 | import Data.Maybe 19 | 20 | import Haxl.Prelude 21 | import Haxl.Core 22 | import Prelude() 23 | 24 | import ExampleDataSource 25 | import SleepDataSource 26 | import Haxl.DataSource.ConcurrentIO 27 | 28 | import Control.Monad (void) 29 | import Data.IORef 30 | import qualified Data.HashMap.Strict as HashMap 31 | 32 | aggregateBatches :: Test 33 | aggregateBatches = TestCase $ do 34 | let 35 | statsNoBatches = [ FetchStats { fetchDataSource = "foo" 36 | , fetchBatchSize = 7 37 | , fetchStart = 0 38 | , fetchDuration = 10 39 | , fetchSpace = 1 40 | , fetchFailures = 2 41 | , fetchIgnoredFailures = 0 42 | , fetchBatchId = n 43 | , fetchIds = [1,2] } 44 | | n <- reverse [1..10] ++ [11..20] ] 45 | ++ [ FetchCall "A" ["B"] 1, FetchCall "C" ["D"] 2 ] 46 | fetchBatch = [ FetchStats { fetchDataSource = "batch" 47 | , fetchBatchSize = 1 48 | , fetchStart = 100 49 | , fetchDuration = 1000 * n 50 | , fetchSpace = 3 51 | , fetchFailures = if n <= 3 then 1 else 0 52 | , fetchIgnoredFailures = 0 53 | , fetchBatchId = 123 54 | , fetchIds = [fromIntegral n] } | n <- [1..50] ] 55 | agg (sz,bids) FetchStats{..} = (sz + fetchBatchSize, fetchBatchId:bids) 56 | agg _ _ = error "unexpected" 57 | agg' = foldl' agg (0,[]) 58 | aggNoBatch = aggregateFetchBatches agg' (Stats statsNoBatches) 59 | expectedNoBatch = [(7, [n]) | n <- reverse [1..20] :: [Int]] 60 | aggBatch = aggregateFetchBatches agg' (Stats fetchBatch) 61 | expectedResultBatch = (50, [123 | _ <- [1..50] :: [Int]]) 62 | aggInterspersedBatch = 63 | aggregateFetchBatches agg' 64 | (Stats $ intersperse (head fetchBatch) statsNoBatches) 65 | expectedResultInterspersed = 66 | (21, [123 | _ <- [1..21] :: [Int]]) : expectedNoBatch 67 | assertEqual "No batch has no change" expectedNoBatch aggNoBatch 68 | assertEqual "Batch is combined" [expectedResultBatch] aggBatch 69 | assertEqual 70 | "Grouping works as expected" expectedResultInterspersed aggInterspersedBatch 71 | 72 | testEnv :: IO (Env () ()) 73 | testEnv = do 74 | -- To use a data source, we need to initialize its state: 75 | exstate <- ExampleDataSource.initGlobalState 76 | sleepState <- mkConcurrentIOState 77 | 78 | -- And create a StateStore object containing the states we need: 79 | let st = stateSet exstate (stateSet sleepState stateEmpty) 80 | 81 | -- Create the Env: 82 | env <- initEnv st () 83 | return env{ flags = (flags env){ 84 | report = setReportFlag ReportFetchStack profilingReportFlags } } 85 | 86 | 87 | fetchIdsSync :: Test 88 | fetchIdsSync = TestCase $ do 89 | env <- testEnv 90 | _ <- runHaxl env $ 91 | sequence_ 92 | [ void $ countAardvarks "abcabc" + (length <$> listWombats 3) 93 | , void $ listWombats 100 94 | , void $ listWombats 99 95 | , void $ countAardvarks "BANG4" `catch` \NotFound{} -> return 123 96 | ] 97 | -- expect a single DS stat 98 | (Stats stats) <- readIORef (statsRef env) 99 | let 100 | fetchStats = [x | x@FetchStats{} <- stats] 101 | assertEqual "Only 1 batch" 1 (length fetchStats) 102 | let 103 | [stat] = fetchStats 104 | assertEqual "No real failures" 0 (fetchFailures stat) 105 | assertEqual "1 ignored failure" 1 (fetchIgnoredFailures stat) 106 | 107 | fetchIdsBackground :: Test 108 | fetchIdsBackground = TestCase $ do 109 | env <- testEnv 110 | _ <- runHaxl env $ 111 | sequence_ 112 | [ withLabel "short" $ sleep 1 113 | , withLabel "long" $ sleep 500 ] 114 | 115 | -- make sure that with memo'ing we still preserve the stack 116 | _ <- runHaxl env $ withLabel "base" 117 | (memo (1 :: Int) $ withLabel "child" $ sleep 102) 118 | 119 | _ <- runHaxl env $ withLabel "short_cached" $ sleep 1 120 | 121 | -- expect a single DS stat 122 | (Stats stats) <- readIORef (statsRef env) 123 | (Profile p pt _) <- readIORef (profRef env) 124 | let 125 | keyMap = 126 | HashMap.fromList [ (label, k) | ((label,_), k) <- HashMap.toList pt] 127 | revMap = HashMap.fromList [(v,k) | (k,v) <- HashMap.toList pt] 128 | parentMap = 129 | HashMap.fromList $ 130 | catMaybes 131 | [ case HashMap.lookup kp revMap of 132 | Just (lp,_) -> Just (label, lp) 133 | Nothing -> Nothing 134 | | ((label,kp), _) <- HashMap.toList pt] 135 | fetchMap = HashMap.fromList [ (fid, x) | x@FetchStats{} <- stats 136 | , fid <- fetchIds x] 137 | get l = [ (prof, wasCached, fetchStat) 138 | | Just key <- [HashMap.lookup l keyMap] 139 | , Just prof <- [HashMap.lookup key p] 140 | , ProfileFetch fid _ wasCached <- profileFetches prof 141 | , Just fetchStat <- [HashMap.lookup fid fetchMap]] 142 | [(short, shortWC, shortFetch)] = get "short" 143 | [(long, longWC, longFetch)] = get "long" 144 | [(shortCached, shortCachedWC, shortCachedFetch)] = get "short_cached" 145 | 146 | assertEqual "3 batches" 3 (HashMap.size fetchMap) 147 | assertEqual "6 labels (inc MAIN)" 6 (HashMap.size keyMap) 148 | 149 | assertEqual "child parent is base" 150 | (Just "base") 151 | (HashMap.lookup "child" parentMap) 152 | 153 | assertEqual "base parent is MAIN" 154 | (Just "MAIN") 155 | (HashMap.lookup "base" parentMap) 156 | 157 | assertEqual "long parent is MAIN" 158 | (Just "MAIN") 159 | (HashMap.lookup "long" parentMap) 160 | 161 | assertBool "original fetches not cached (short)" (not shortWC) 162 | assertBool "original fetches not cached (long)" (not longWC) 163 | assertBool "was cached short" shortCachedWC 164 | 165 | assertEqual "one fetch short" 1 (length $ profileFetches short) 166 | assertEqual "one fetch long" 1 (length $ profileFetches long) 167 | assertEqual "one fetch short_cached" 1 (length $ profileFetches shortCached) 168 | 169 | assertBool "short fetch mapped properly" (fetchDuration shortFetch < 100000) 170 | assertEqual 171 | "short cached fetch mapped properly" 172 | (fetchDuration shortFetch) 173 | (fetchDuration shortCachedFetch) 174 | assertBool "long fetch was mapped properly" (fetchDuration longFetch > 100000) 175 | 176 | 177 | ppStatsTest :: Test 178 | ppStatsTest = TestCase $ do 179 | let 180 | r = ppStats (Stats []) 181 | mc = ppStats (Stats [MemoCall 0 0]) 182 | fc = ppStats (Stats [FetchCall "" [] 0]) 183 | fw = ppStats (Stats [FetchWait HashMap.empty 0 1]) 184 | fs = ppStats (Stats [FetchStats "" 0 0 0 0 0 0 0 []]) 185 | assertEqual "empty stats -> empty string" r "" 186 | assertEqual "memo call stats -> empty string" mc "" 187 | assertEqual "fetch call stats -> empty string" fc "" 188 | assertBool "fetch wait stats -> some data" (not $ null fw) 189 | assertBool "fetch stats -> some data" (not $ null fs) 190 | 191 | 192 | tests = TestList [ TestLabel "Aggregate Batches" aggregateBatches 193 | , TestLabel "Fetch IDs Sync" fetchIdsSync 194 | , TestLabel "Fetch IDs Background" fetchIdsBackground 195 | , TestLabel "ppStats" ppStatsTest ] 196 | -------------------------------------------------------------------------------- /tests/TestBadDataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | module TestBadDataSource (tests) where 11 | 12 | import Haxl.Prelude as Haxl 13 | import Prelude() 14 | 15 | import Haxl.Core 16 | 17 | import Data.IORef 18 | import Test.HUnit 19 | import Control.Exception 20 | import System.Mem 21 | 22 | import ExampleDataSource 23 | import BadDataSource 24 | 25 | testEnv impl fn = do 26 | -- Use allocation limits, just to make sure haxl properly behaves and 27 | -- doesn't reset this internally somewhere. 28 | -- `go` will disable this 29 | setAllocationCounter 5000000 -- 5 meg should be enough, uses ~100k atm 30 | enableAllocationLimit 31 | exstate <- ExampleDataSource.initGlobalState 32 | badstate <- BadDataSource.initGlobalState impl 33 | let st = stateSet exstate $ stateSet (fn badstate) stateEmpty 34 | initEnv st () 35 | 36 | wombats :: GenHaxl () () Int 37 | wombats = length <$> listWombats 3 38 | 39 | wombatsMany :: GenHaxl () () Int 40 | wombatsMany = length <$> listWombats 7 41 | 42 | go :: FetchImpl -> Test 43 | go impl = TestCase $ flip finally disableAllocationLimit $ do 44 | -- test that a failed acquire doesn't fail the other requests 45 | ref <- newIORef False 46 | env <- testEnv impl $ \st -> 47 | st { failAcquire = throwIO (DataSourceError "acquire") 48 | , failRelease = writeIORef ref True } 49 | 50 | x <- runHaxl env $ 51 | (dataFetch (FailAfter 0) + wombatsMany) 52 | `Haxl.catch` \DataSourceError{} -> wombats 53 | 54 | assertEqual "badDataSourceTest1" 3 x 55 | 56 | -- We should *not* have called release 57 | assertEqual "badDataSourceTest2" False =<< readIORef ref 58 | 59 | -- test that a failed dispatch doesn't fail the other requests 60 | ref <- newIORef False 61 | env <- testEnv impl $ \st -> 62 | st { failDispatch = throwIO (DataSourceError "dispatch") 63 | , failRelease = writeIORef ref True } 64 | 65 | x <- runHaxl env $ 66 | (dataFetch (FailAfter 0) + wombatsMany) 67 | `Haxl.catch` \DataSourceError{} -> wombats 68 | 69 | assertEqual "badDataSourceTest3" x 3 70 | 71 | -- We *should* have called release 72 | assertEqual "badDataSourceTest4" True =<< readIORef ref 73 | 74 | -- test that a failed wait is a DataSourceError 75 | env <- testEnv impl $ \st -> 76 | st { failWait = throwIO (DataSourceError "wait") } 77 | 78 | x <- runHaxl env $ 79 | (dataFetch (FailAfter 0) + wombatsMany) 80 | `Haxl.catch` \DataSourceError{} -> wombats 81 | 82 | assertEqual "badDataSourceTest5" x 3 83 | 84 | -- We *should* have called release 85 | assertEqual "badDataSourceTest6" True =<< readIORef ref 86 | 87 | -- test that a failed release is still a DataSourceError, even 88 | -- though the request will have completed successfully 89 | env <- testEnv impl $ \st -> 90 | st { failRelease = throwIO (DataSourceError "release") } 91 | 92 | let 93 | -- In background fetches the scheduler might happen to process the data 94 | -- source result (FetchError in this case) before it processes the exception 95 | -- from release. So we have to allow both cases. 96 | isBg = case impl of 97 | Background -> True 98 | BackgroundMVar -> True 99 | _ -> False 100 | releaseCatcher e 101 | | Just DataSourceError{} <- fromException e = wombats 102 | | Just FetchError{} <- fromException e = 103 | if isBg then wombats else Haxl.throw e 104 | | otherwise = Haxl.throw e 105 | 106 | x <- runHaxl env $ 107 | (dataFetch (FailAfter 0) + wombatsMany) 108 | `Haxl.catch` releaseCatcher 109 | 110 | assertEqual "badDataSourceTest7" x 3 111 | 112 | -- test that if we don't throw anything we get the result 113 | -- (which is a fetch error for this source) 114 | env <- testEnv impl id 115 | x <- runHaxl env $ 116 | (dataFetch (FailAfter 0) + wombatsMany) 117 | `Haxl.catch` \FetchError{} -> wombats 118 | 119 | assertEqual "badDataSourceTest8" x 3 120 | 121 | 122 | 123 | 124 | tests = TestList 125 | [ TestLabel "badDataSourceTest async" (go Async) 126 | , TestLabel "badDataSourceTest background" (go Background) 127 | , TestLabel "badDataSourceTest backgroundMVar" (go BackgroundMVar) 128 | , TestLabel "badDataSourceTest backgroundFetchSeq" (go BackgroundSeq) 129 | , TestLabel "badDataSourceTest backgroundFetchPar" (go BackgroundPar) 130 | ] 131 | -------------------------------------------------------------------------------- /tests/TestExampleDataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE CPP, OverloadedStrings, RebindableSyntax, MultiWayIf #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | module TestExampleDataSource (tests) where 12 | 13 | import Haxl.Prelude as Haxl 14 | import Prelude() 15 | 16 | import Haxl.Core.Monad (unsafeLiftIO) 17 | import Haxl.Core 18 | 19 | import Test.HUnit 20 | import Data.IORef 21 | import Data.Maybe 22 | import Control.Exception 23 | import System.Environment 24 | import System.FilePath 25 | 26 | import ExampleDataSource 27 | import LoadCache 28 | 29 | testEnv :: IO (Env () ()) 30 | testEnv = do 31 | -- To use a data source, we need to initialize its state: 32 | exstate <- ExampleDataSource.initGlobalState 33 | 34 | -- And create a StateStore object containing the states we need: 35 | let st = stateSet exstate stateEmpty 36 | 37 | -- Create the Env: 38 | env <- initEnv st () 39 | return env{ flags = (flags env){ 40 | report = setReportFlag ReportFetchStats defaultReportFlags } } 41 | 42 | 43 | tests = TestList [ 44 | TestLabel "exampleTest" exampleTest, 45 | TestLabel "orderTest" orderTest, 46 | TestLabel "preCacheTest" preCacheTest, 47 | TestLabel "cachedComputationTest" cachedComputationTest, 48 | TestLabel "cacheResultTest" cacheResultTest, 49 | TestLabel "memoTest" memoTest, 50 | TestLabel "dataSourceExceptionTest" dataSourceExceptionTest, 51 | TestLabel "dumpCacheAsHaskell" dumpCacheTest, 52 | TestLabel "fetchError" fetchError 53 | ] 54 | 55 | -- Let's test ExampleDataSource. 56 | 57 | exampleTest :: Test 58 | exampleTest = TestCase $ do 59 | env <- testEnv 60 | 61 | -- Run an example expression with two fetches: 62 | x <- runHaxl env $ 63 | countAardvarks "abcabc" + (length <$> listWombats 3) 64 | 65 | assertEqual "runTests" x (2 + 3) 66 | 67 | -- Should be just one fetching round: 68 | Stats stats <- readIORef (statsRef env) 69 | putStrLn (ppStats (Stats stats)) 70 | assertEqual "rounds" 1 (length stats) 71 | 72 | -- With two fetches: 73 | assertBool "reqs" $ 74 | case stats of 75 | [FetchStats{..}] -> 76 | fetchDataSource == "ExampleDataSource" && fetchBatchSize == 2 77 | _otherwise -> False 78 | 79 | -- Test side-effect ordering 80 | 81 | orderTest = TestCase $ do 82 | env <- testEnv 83 | 84 | ref <- newIORef ([] :: [Int]) 85 | 86 | let tick n = unsafeLiftIO (modifyIORef ref (n:)) 87 | 88 | let left = do tick 1 89 | r <- countAardvarks "abcabc" 90 | tick 2 91 | return r 92 | 93 | let right = do tick 3 94 | r <- length <$> listWombats 3 95 | tick 4 96 | return r 97 | 98 | x <- runHaxl env $ left + right 99 | assertEqual "TestExampleDataSource2" x (2 + 3) 100 | 101 | -- The order of the side effects is 1,3,2,4. First we see 1, then 102 | -- left gets blocked, then we explore right, we see 3, then right 103 | -- gets blocked. The data fetches are performed, then we see 2 and 104 | -- then 4. 105 | 106 | ys <- readIORef ref 107 | assertEqual "TestExampleDataSource: ordering" (reverse ys) [1,3,2,4] 108 | 109 | 110 | preCacheTest = TestCase $ do 111 | env <- testEnv 112 | 113 | x <- runHaxl env $ do 114 | cacheRequest (CountAardvarks "xxx") (Right 3) 115 | cacheRequest (ListWombats 1000000) (Right [1,2,3]) 116 | countAardvarks "xxx" + (length <$> listWombats 1000000) 117 | assertEqual "preCacheTest1" x (3 + 3) 118 | 119 | y <- Control.Exception.try $ runHaxl env $ do 120 | cacheRequest (CountAardvarks "yyy") $ except (NotFound "yyy") 121 | countAardvarks "yyy" 122 | assertBool "preCacheTest2" $ 123 | case y of 124 | Left (NotFound "yyy") -> True 125 | _other -> False 126 | 127 | -- Pretend CountAardvarks is a request computed by some Haxl code 128 | cachedComputationTest = TestCase $ do 129 | env <- testEnv 130 | let env' = env { flags = (flags env){trace = 3} } 131 | 132 | let x = cachedComputation (CountAardvarks "ababa") $ do 133 | a <- length <$> listWombats 10 134 | b <- length <$> listWombats 20 135 | return (a + b) 136 | 137 | r <- runHaxl env' $ x + x + countAardvarks "baba" 138 | 139 | assertEqual "cachedComputationTest1" 62 r 140 | 141 | stats <- readIORef (statsRef env) 142 | assertEqual "fetches" 3 (numFetches stats) 143 | 144 | cacheResultTest = TestCase $ do 145 | env <- testEnv 146 | ref <- newIORef 0 147 | let request = cacheResult (CountAardvarks "ababa") $ do 148 | modifyIORef ref (+1) 149 | readIORef ref 150 | r <- runHaxl env $ (+) <$> request <*> request 151 | assertEqual "cacheResult" 2 r 152 | 153 | 154 | -- Pretend CountAardvarks is a request computed by some Haxl code 155 | memoTest = TestCase $ do 156 | env <- testEnv 157 | let env' = env { flags = (flags env){trace = 3} } 158 | 159 | let x = memo (CountAardvarks "ababa") $ do 160 | a <- length <$> listWombats 10 161 | b <- length <$> listWombats 20 162 | return (a + b) 163 | 164 | r <- runHaxl env' $ x + x + countAardvarks "baba" 165 | 166 | assertEqual "memoTest1" 62 r 167 | 168 | stats <- readIORef (statsRef env) 169 | assertEqual "fetches" 3 (numFetches stats) 170 | 171 | -- Test that the FetchError gets returned properly, and that we have 172 | -- a failure logged in the stats. 173 | fetchError = TestCase $ do 174 | env <- testEnv 175 | r <- runHaxl env $ Haxl.try $ 176 | (++) <$> listWombats 1000000 <*> listWombats 1000001 177 | assertBool "fetchError1" $ case r of 178 | Left FetchError{} -> True 179 | Right _ -> False 180 | Stats stats <- readIORef (statsRef env) 181 | assertEqual "fetchError2" 2 (sum [ fetchFailures | FetchStats{..} <- stats ]) 182 | 183 | dataSourceExceptionTest = TestCase $ do 184 | env <- testEnv 185 | 186 | r <- runHaxl env $ Haxl.try $ countAardvarks "BANG" 187 | assertBool "exception1" $ 188 | case r of 189 | Left (ErrorCall "BANG") -> True 190 | _ -> False 191 | r <- runHaxl env $ Haxl.try $ countAardvarks "BANG2" 192 | assertBool "exception2" $ 193 | case r of 194 | Left (ErrorCall "BANG2") -> True 195 | _ -> False 196 | 197 | -- In this test, BANG3 is an asynchronous exception (ThreadKilled), 198 | -- so we should see that instead of the exception on the left. 199 | -- Furthermore, it doesn't get caught by Haxl.try, and we have to 200 | -- catch it outside of runHaxl. 201 | env <- testEnv 202 | r <- Control.Exception.try $ runHaxl env $ Haxl.try $ 203 | (length <$> listWombats 100) + countAardvarks "BANG3" 204 | print r 205 | assertBool "exception3" $ 206 | case (r :: Either AsyncException (Either SomeException Int)) of 207 | Left ThreadKilled -> True 208 | _ -> False 209 | 210 | -- Test that we can load the cache from a dumped copy of it, and then dump it 211 | -- again to get the same result. 212 | dumpCacheTest = TestCase $ do 213 | env <- testEnv 214 | runHaxl env loadCache 215 | str <- runHaxl env dumpCacheAsHaskell 216 | lcPath <-loadCachePath 217 | loadcache <- readFile lcPath 218 | -- The order of 'cacheRequest ...' calls is nondeterministic and 219 | -- differs among GHC versions, so we sort the lines for comparison. 220 | assertEqual "dumpCacheAsHaskell" (sort $ lines loadcache) (sort $ lines str) 221 | where 222 | loadCachePath = do 223 | lcEnv <- lookupEnv "LOADCACHE" 224 | return $ fromMaybe (dropFileName __FILE__ "LoadCache.txt") lcEnv 225 | -------------------------------------------------------------------------------- /tests/TestMain.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE CPP, OverloadedStrings #-} 10 | module Main where 11 | 12 | import Test.Framework (defaultMain) 13 | import Test.Framework.Providers.HUnit (hUnitTestToTests) 14 | import AllTests 15 | 16 | main :: IO () 17 | main = defaultMain $ hUnitTestToTests allTests 18 | -------------------------------------------------------------------------------- /tests/TestTypes.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE DeriveDataTypeable #-} 12 | {-# LANGUAGE CPP #-} 13 | 14 | module TestTypes 15 | ( UserEnv 16 | , Haxl 17 | , HaxlEnv 18 | , lookupInput 19 | , Id(..) 20 | ) where 21 | 22 | import Data.Aeson 23 | import Data.Binary (Binary) 24 | import qualified Data.Text as Text 25 | #if MIN_VERSION_aeson(2,0,0) 26 | import qualified Data.Aeson.KeyMap as KeyMap 27 | import Data.Aeson.Key (toText) 28 | #else 29 | import qualified Data.HashMap.Strict as KeyMap 30 | #endif 31 | import Data.Hashable 32 | import Data.Typeable 33 | 34 | import Haxl.Core 35 | 36 | #if !MIN_VERSION_aeson(2,0,0) 37 | type Key = Text.Text 38 | 39 | toText :: Key -> Text.Text 40 | toText = id 41 | #endif 42 | 43 | type UserEnv = Object 44 | type Haxl a = GenHaxl UserEnv () a 45 | type HaxlEnv = Env UserEnv () 46 | 47 | lookupInput :: FromJSON a => Key -> Haxl a 48 | lookupInput field = do 49 | mb_val <- env (KeyMap.lookup field . userEnv) 50 | case mb_val of 51 | Nothing -> 52 | throw (NotFound (Text.concat ["field ", toText field, " was not found."])) 53 | Just val -> 54 | case fromJSON val of 55 | Error str -> 56 | throw (UnexpectedType (Text.concat 57 | ["field ", toText field, ": ", Text.pack str])) 58 | Success a -> return a 59 | 60 | 61 | newtype Id = Id Int 62 | deriving (Eq, Ord, Binary, Enum, Num, Integral, Real, Hashable, Typeable, 63 | ToJSON, FromJSON) 64 | 65 | instance Show Id where 66 | show (Id i) = show i 67 | -------------------------------------------------------------------------------- /tests/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE CPP #-} 11 | module TestUtils 12 | ( makeTestEnv 13 | , expectResultWithEnv 14 | , expectResult 15 | , expectFetches 16 | , testinput 17 | , id1, id2, id3, id4 18 | ) where 19 | 20 | import TestTypes 21 | import MockTAO 22 | import Haxl.DataSource.ConcurrentIO 23 | 24 | import Data.IORef 25 | import Data.Aeson 26 | import Test.HUnit 27 | #if MIN_VERSION_aeson(2,0,0) 28 | import qualified Data.Aeson.KeyMap as KeyMap 29 | #else 30 | import qualified Data.HashMap.Strict as KeyMap 31 | #endif 32 | 33 | import Haxl.Core 34 | 35 | import Prelude() 36 | import Haxl.Prelude 37 | 38 | testinput :: Object 39 | testinput = KeyMap.fromList [ 40 | "A" .= (1 :: Int), 41 | "B" .= (2 :: Int), 42 | "C" .= (3 :: Int), 43 | "D" .= (4 :: Int) ] 44 | 45 | id1 :: Haxl Id 46 | id1 = lookupInput "A" 47 | 48 | id2 :: Haxl Id 49 | id2 = lookupInput "B" 50 | 51 | id3 :: Haxl Id 52 | id3 = lookupInput "C" 53 | 54 | id4 :: Haxl Id 55 | id4 = lookupInput "D" 56 | 57 | makeTestEnv :: Bool -> IO HaxlEnv 58 | makeTestEnv future = do 59 | tao <- MockTAO.initGlobalState future 60 | stio <- mkConcurrentIOState 61 | let st = stateSet stio $ stateSet tao stateEmpty 62 | env <- initEnv st testinput 63 | return env { flags = (flags env) { 64 | report = setReportFlag ReportFetchStats defaultReportFlags } } 65 | 66 | expectResultWithEnv 67 | :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion 68 | expectResultWithEnv result haxl env = do 69 | a <- runHaxl env haxl 70 | assertEqual "result" result a 71 | 72 | expectResult :: (Eq a, Show a) => a -> Haxl a -> Bool -> Assertion 73 | expectResult result haxl future = do 74 | env <- makeTestEnv future 75 | expectResultWithEnv result haxl env 76 | 77 | expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Bool -> Assertion 78 | expectFetches n haxl future = do 79 | env <- makeTestEnv future 80 | _ <- runHaxl env haxl 81 | stats <- readIORef (statsRef env) 82 | assertEqual "fetches" n (numFetches stats) 83 | -------------------------------------------------------------------------------- /tests/WorkDataSource.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright (c) Meta Platforms, Inc. and affiliates. 3 | All rights reserved. 4 | 5 | This source code is licensed under the BSD-style license found in the 6 | LICENSE file in the root directory of this source tree. 7 | -} 8 | 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | {-# LANGUAGE OverloadedStrings #-} 16 | 17 | module WorkDataSource ( 18 | mkWorkState, 19 | work, 20 | ) where 21 | 22 | import Haxl.Prelude 23 | import Prelude () 24 | 25 | import Haxl.Core 26 | 27 | import Control.Exception 28 | import Data.Hashable 29 | import Data.Typeable 30 | import Control.Monad (void) 31 | import Control.Concurrent.MVar 32 | 33 | 34 | data Work a where 35 | Work :: Integer -> Work Integer 36 | deriving Typeable 37 | 38 | deriving instance Eq (Work a) 39 | deriving instance Show (Work a) 40 | instance ShowP Work where showp = show 41 | 42 | instance Hashable (Work a) where 43 | hashWithSalt s (Work a) = hashWithSalt s (0::Int,a) 44 | 45 | instance DataSourceName Work where 46 | dataSourceName _ = "Work" 47 | 48 | instance StateKey Work where 49 | data State Work = WorkState 50 | 51 | newtype Service = Service (MVar [IO ()]) 52 | 53 | run :: Work a -> IO a 54 | run (Work n) = evaluate (sum [1..n]) >> return n 55 | 56 | mkService :: IO Service 57 | mkService = Service <$> newMVar [] 58 | 59 | process :: Service -> IO () 60 | process (Service q) = do 61 | r <- swapMVar q [] 62 | sequence_ r 63 | 64 | enqueue :: Service -> Work a -> IO (IO (Either SomeException a)) 65 | enqueue (Service q) w = do 66 | res <- newEmptyMVar 67 | let r = do 68 | v <- Control.Exception.try $ run w 69 | putMVar res v 70 | modifyMVar_ q (return . (:) r) 71 | return (takeMVar res) 72 | 73 | instance DataSource u Work where 74 | fetch = backgroundFetchAcquireReleaseMVar 75 | mkService 76 | (\_ -> return ()) 77 | -- pretend we are ready so that process does the work 78 | (\_ _ m -> void $ tryPutMVar m ()) 79 | process 80 | enqueue 81 | 82 | 83 | mkWorkState :: State Work 84 | mkWorkState = WorkState 85 | 86 | work :: Integer -> GenHaxl u w Integer 87 | work n = dataFetch (Work n) 88 | --------------------------------------------------------------------------------