diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [1.0.0] - 2026-07-15 + +### Added + +- Initial release. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,287 @@ + EUROPEAN UNION PUBLIC LICENCE v. 1.2 + EUPL © the European Union 2007, 2016 + +This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined +below) which is provided under the terms of this Licence. Any use of the Work, +other than as authorised under this Licence is prohibited (to the extent such +use is covered by a right of the copyright holder of the Work). + +The Work is provided under the terms of this Licence when the Licensor (as +defined below) has placed the following notice immediately following the +copyright notice for the Work: + + Licensed under the EUPL + +or has expressed by any other means his willingness to license under the EUPL. + +1. Definitions + +In this Licence, the following terms have the following meaning: + +- ‘The Licence’: this Licence. + +- ‘The Original Work’: the work or software distributed or communicated by the + Licensor under this Licence, available as Source Code and also as Executable + Code as the case may be. + +- ‘Derivative Works’: the works or software that could be created by the + Licensee, based upon the Original Work or modifications thereof. This Licence + does not define the extent of modification or dependence on the Original Work + required in order to classify a work as a Derivative Work; this extent is + determined by copyright law applicable in the country mentioned in Article 15. + +- ‘The Work’: the Original Work or its Derivative Works. + +- ‘The Source Code’: the human-readable form of the Work which is the most + convenient for people to study and modify. + +- ‘The Executable Code’: any code which has generally been compiled and which is + meant to be interpreted by a computer as a program. + +- ‘The Licensor’: the natural or legal person that distributes or communicates + the Work under the Licence. + +- ‘Contributor(s)’: any natural or legal person who modifies the Work under the + Licence, or otherwise contributes to the creation of a Derivative Work. + +- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of + the Work under the terms of the Licence. + +- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending, + renting, distributing, communicating, transmitting, or otherwise making + available, online or offline, copies of the Work or providing access to its + essential functionalities at the disposal of any other natural or legal + person. + +2. Scope of the rights granted by the Licence + +The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, +sublicensable licence to do the following, for the duration of copyright vested +in the Original Work: + +- use the Work in any circumstance and for all usage, +- reproduce the Work, +- modify the Work, and make Derivative Works based upon the Work, +- communicate to the public, including the right to make available or display + the Work or copies thereof to the public and perform publicly, as the case may + be, the Work, +- distribute the Work or copies thereof, +- lend and rent the Work or copies thereof, +- sublicense rights in the Work or copies thereof. + +Those rights can be exercised on any media, supports and formats, whether now +known or later invented, as far as the applicable law permits so. + +In the countries where moral rights apply, the Licensor waives his right to +exercise his moral right to the extent allowed by law in order to make effective +the licence of the economic rights here above listed. + +The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to +any patents held by the Licensor, to the extent necessary to make use of the +rights granted on the Work under this Licence. + +3. Communication of the Source Code + +The Licensor may provide the Work either in its Source Code form, or as +Executable Code. If the Work is provided as Executable Code, the Licensor +provides in addition a machine-readable copy of the Source Code of the Work +along with each copy of the Work that the Licensor distributes or indicates, in +a notice following the copyright notice attached to the Work, a repository where +the Source Code is easily and freely accessible for as long as the Licensor +continues to distribute or communicate the Work. + +4. Limitations on copyright + +Nothing in this Licence is intended to deprive the Licensee of the benefits from +any exception or limitation to the exclusive rights of the rights owners in the +Work, of the exhaustion of those rights or of other applicable limitations +thereto. + +5. Obligations of the Licensee + +The grant of the rights mentioned above is subject to some restrictions and +obligations imposed on the Licensee. Those obligations are the following: + +Attribution right: The Licensee shall keep intact all copyright, patent or +trademarks notices and all notices that refer to the Licence and to the +disclaimer of warranties. The Licensee must include a copy of such notices and a +copy of the Licence with every copy of the Work he/she distributes or +communicates. The Licensee must cause any Derivative Work to carry prominent +notices stating that the Work has been modified and the date of modification. + +Copyleft clause: If the Licensee distributes or communicates copies of the +Original Works or Derivative Works, this Distribution or Communication will be +done under the terms of this Licence or of a later version of this Licence +unless the Original Work is expressly distributed only under this version of the +Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee +(becoming Licensor) cannot offer or impose any additional terms or conditions on +the Work or Derivative Work that alter or restrict the terms of the Licence. + +Compatibility clause: If the Licensee Distributes or Communicates Derivative +Works or copies thereof based upon both the Work and another work licensed under +a Compatible Licence, this Distribution or Communication can be done under the +terms of this Compatible Licence. For the sake of this clause, ‘Compatible +Licence’ refers to the licences listed in the appendix attached to this Licence. +Should the Licensee's obligations under the Compatible Licence conflict with +his/her obligations under this Licence, the obligations of the Compatible +Licence shall prevail. + +Provision of Source Code: When distributing or communicating copies of the Work, +the Licensee will provide a machine-readable copy of the Source Code or indicate +a repository where this Source will be easily and freely available for as long +as the Licensee continues to distribute or communicate the Work. + +Legal Protection: This Licence does not grant permission to use the trade names, +trademarks, service marks, or names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the copyright notice. + +6. Chain of Authorship + +The original Licensor warrants that the copyright in the Original Work granted +hereunder is owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each Contributor warrants that the copyright in the modifications he/she brings +to the Work are owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each time You accept the Licence, the original Licensor and subsequent +Contributors grant You a licence to their contributions to the Work, under the +terms of this Licence. + +7. Disclaimer of Warranty + +The Work is a work in progress, which is continuously improved by numerous +Contributors. It is not a finished work and may therefore contain defects or +‘bugs’ inherent to this type of development. + +For the above reason, the Work is provided under the Licence on an ‘as is’ basis +and without warranties of any kind concerning the Work, including without +limitation merchantability, fitness for a particular purpose, absence of defects +or errors, accuracy, non-infringement of intellectual property rights other than +copyright as stated in Article 6 of this Licence. + +This disclaimer of warranty is an essential part of the Licence and a condition +for the grant of any rights to the Work. + +8. Disclaimer of Liability + +Except in the cases of wilful misconduct or damages directly caused to natural +persons, the Licensor will in no event be liable for any direct or indirect, +material or moral, damages of any kind, arising out of the Licence or of the use +of the Work, including without limitation, damages for loss of goodwill, work +stoppage, computer failure or malfunction, loss of data or any commercial +damage, even if the Licensor has been advised of the possibility of such damage. +However, the Licensor will be liable under statutory product liability laws as +far such laws apply to the Work. + +9. Additional agreements + +While distributing the Work, You may choose to conclude an additional agreement, +defining obligations or services consistent with this Licence. However, if +accepting obligations, You may act only on your own behalf and on your sole +responsibility, not on behalf of the original Licensor or any other Contributor, +and only if You agree to indemnify, defend, and hold each Contributor harmless +for any liability incurred by, or claims asserted against such Contributor by +the fact You have accepted any warranty or additional liability. + +10. Acceptance of the Licence + +The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ +placed under the bottom of a window displaying the text of this Licence or by +affirming consent in any other similar way, in accordance with the rules of +applicable law. Clicking on that icon indicates your clear and irrevocable +acceptance of this Licence and all of its terms and conditions. + +Similarly, you irrevocably accept this Licence and all of its terms and +conditions by exercising any rights granted to You by Article 2 of this Licence, +such as the use of the Work, the creation by You of a Derivative Work or the +Distribution or Communication by You of the Work or copies thereof. + +11. Information to the public + +In case of any Distribution or Communication of the Work by means of electronic +communication by You (for example, by offering to download the Work from a +remote location) the distribution channel or media (for example, a website) must +at least provide to the public the information requested by the applicable law +regarding the Licensor, the Licence and the way it may be accessible, concluded, +stored and reproduced by the Licensee. + +12. Termination of the Licence + +The Licence and the rights granted hereunder will terminate automatically upon +any breach by the Licensee of the terms of the Licence. + +Such a termination will not terminate the licences of any person who has +received the Work from the Licensee under the Licence, provided such persons +remain in full compliance with the Licence. + +13. Miscellaneous + +Without prejudice of Article 9 above, the Licence represents the complete +agreement between the Parties as to the Work. + +If any provision of the Licence is invalid or unenforceable under applicable +law, this will not affect the validity or enforceability of the Licence as a +whole. Such provision will be construed or reformed so as necessary to make it +valid and enforceable. + +The European Commission may publish other linguistic versions or new versions of +this Licence or updated versions of the Appendix, so far this is required and +reasonable, without reducing the scope of the rights granted by the Licence. New +versions of the Licence will be published with a unique version number. + +All linguistic versions of this Licence, approved by the European Commission, +have identical value. Parties can take advantage of the linguistic version of +their choice. + +14. Jurisdiction + +Without prejudice to specific agreement between parties, + +- any litigation resulting from the interpretation of this License, arising + between the European Union institutions, bodies, offices or agencies, as a + Licensor, and any Licensee, will be subject to the jurisdiction of the Court + of Justice of the European Union, as laid down in article 272 of the Treaty on + the Functioning of the European Union, + +- any litigation arising between other parties and resulting from the + interpretation of this License, will be subject to the exclusive jurisdiction + of the competent court where the Licensor resides or conducts its primary + business. + +15. Applicable Law + +Without prejudice to specific agreement between parties, + +- this Licence shall be governed by the law of the European Union Member State + where the Licensor has his seat, resides or has his registered office, + +- this licence shall be governed by Belgian law if the Licensor has no seat, + residence or registered office inside a European Union Member State. + +Appendix + +‘Compatible Licences’ according to Article 5 EUPL are: + +- GNU General Public License (GPL) v. 2, v. 3 +- GNU Affero General Public License (AGPL) v. 3 +- Open Software License (OSL) v. 2.1, v. 3.0 +- Eclipse Public License (EPL) v. 1.0 +- CeCILL v. 2.0, v. 2.1 +- Mozilla Public Licence (MPL) v. 2 +- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3 +- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for + works other than software +- European Union Public Licence (EUPL) v. 1.1, v. 1.2 +- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong + Reciprocity (LiLiQ-R+). + +The European Commission may update this Appendix to later versions of the above +licences without producing a new version of the EUPL, as long as they provide +the rights granted in Article 2 of this Licence and protect the covered Source +Code from exclusive appropriation. + +All other changes or additions to this Appendix require the production of a new +EUPL version. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haxl-effectful.cabal b/haxl-effectful.cabal new file mode 100644 --- /dev/null +++ b/haxl-effectful.cabal @@ -0,0 +1,95 @@ +cabal-version: 3.0 +name: haxl-effectful +version: 1.0.0 +category: Concurrency +synopsis: Effectful bindings for Haxl +description: + Adaptation of the @@ library for the @@ ecosystem. + +license: EUPL-1.2 +license-file: LICENCE +author: IDA +maintainer: IDA +homepage: https://digital-autonomy.institute +bug-reports: https://issues.digital-autonomy.institute +build-type: Simple +extra-doc-files: + CHANGELOG.md + +extra-source-files: + test/LoadCache.txt + +common common + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-unsafe + -Wno-all-missed-specialisations + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-poly-kind-signatures + -Wno-missing-role-annotations + -Wno-missing-safe-haskell-mode + -Wno-name-shadowing + + default-extensions: + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + GADTs + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + TemplateHaskell + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + + build-depends: + base >=4.10 && <5, + effectful >=2.6 && <2.7, + hashable >=1.5 && <1.6, + +library + import: common + hs-source-dirs: src + build-depends: + haxl >=2.5 && <2.6 + + exposed-modules: + Effectful.Haxl + +test-suite test + import: common + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: test + main-is: Main.hs + other-modules: + ExampleDataSource + LoadCache + + build-depends: + filepath >=1.5 && <1.6, + haxl-effectful, + hspec-effectful >=1.0 && <1.1, + text >=2.1 && <2.2, diff --git a/src/Effectful/Haxl.hs b/src/Effectful/Haxl.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Haxl.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Effectful.Haxl +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- is a library for +-- concurrent, batched, and cached data fetching. +-- +-- This library provides the 'Haxl' effect can initialise an 'Env', as well +-- as a lifted 'GenHaxl' monad that runs computation with a single @Env@. +-- +-- Haxl can parallelise independent requests using the 'Applicative' instance, +-- but not the 'Monad' instance. +-- To benefit from parallelisation in @do@ blocks, enable the @ApplicativeDo@ +-- language extension. +-- +-- = Example usage +-- +-- == Defining a data source +-- +-- A data source describes one kind of request and how to fetch it. At +-- minimum this means a request type indexed by its result, and instances of +-- 'DataSourceName' and 'DataSource': +-- +-- > data ExampleReq a where +-- > CountAardvarks :: String -> ExampleReq Int +-- > +-- > deriving stock instance Eq (ExampleReq a) +-- > deriving stock instance Show (ExampleReq a) +-- > instance ShowP ExampleReq where showp = show +-- > instance Hashable (ExampleReq a) where +-- > hashWithSalt s (CountAardvarks a) = hashWithSalt s a +-- > +-- > instance StateKey ExampleReq where +-- > data State ExampleReq = ExampleState +-- > +-- > instance DataSourceName ExampleReq where +-- > dataSourceName _ = "ExampleDataSource" +-- > +-- > instance DataSource u ExampleReq where +-- > fetch _state _flags _user = SyncFetch $ mapM_ \(BlockedFetch (CountAardvarks str) result) -> +-- > putSuccess result (length (filter (== 'a') str)) +-- > +-- > countAardvarks :: String -> GenHaxl u w es Int +-- > countAardvarks = dataFetch . CountAardvarks +-- +-- See the package documentation +-- for the full 'DataSource' contract, including asynchronous fetching and batching +-- multiple requests per round. +-- +-- == Running a computation +-- +-- Build the 'StateStore' from every data source's 'State', then use +-- 'runHaxlWith' to discharge the 'Haxl' effect and 'haxl' to run a 'GenHaxl' +-- computation inside it: +-- +-- > import Effectful +-- > import Effectful.Haxl +-- > +-- > main :: IO () +-- > main = runEff . runHaxlWith initialState () defaultFlags $ do +-- > n <- inject . haxl @() @() $ countAardvarks "abcabc" +-- > liftIO $ print n +-- > where +-- > initialState = pure $ stateSet ExampleState stateEmpty +-- +-- If you only have one data source and no user environment or writes, 'runHaxl' +-- is a shorter alternative to 'runHaxlWith'. +-- +-- == Batching independent fetches +-- +-- Requests combined applicatively (with @('<*>')@, @('+')@ via the 'Num' +-- instance, 'traverse', etc.) run in parallel in a single round trip: +-- +-- > -- One round: both fetches are independent. +-- > total :: GenHaxl u w es Int +-- > total = countAardvarks "abc" + countAardvarks "def" +-- +-- Requests sequenced with @('>>=')@ each wait for the previous result and so +-- take a separate round: +-- +-- > -- Two rounds: the second fetch depends on the first result. +-- > chained :: GenHaxl u w es Int +-- > chained = countAardvarks "abc" >>= \n -> countAardvarks (replicate n 'a') +-- +-- These functions can also be expressed with @ApplicativeDo@: +-- +-- > -- One round with ApplicativeDo, two rounds otherwise +-- > total :: GenHaxl u w es Int +-- > total = do +-- > a <- countAardvarks "abc" +-- > b <- countAardvarks "def" +-- > pure (a + b) +-- > +-- > -- Two rounds even with ApplicativeDo +-- > chained :: GenHaxl u w es Int +-- > chained = do +-- > n <- countAardvarks "abc" +-- > countAardvarks (replicate n 'a') +-- +-- Use 'haxlWithStats' to inspect 'Stats' and confirm how many rounds and +-- fetches a computation actually used: +-- +-- > (_, totalStats) <- inject $ haxlWithStats @() @() total +-- > numFetches totalStats `shouldBe` 1 -- one round: 1 fetch batch of size 2 +-- > +-- > (_, chainedStats) <- inject $ haxlWithStats @() @() chained +-- > numFetches chainedStats `shouldBe` 2 -- two rounds: 1 fetch each +-- +-- == Caching and memoization +-- +-- Haxl automatically caches each unique request within a run, so fetching +-- the same request twice only issues one fetch. 'cacheRequest' seeds the +-- cache with a known result to skip a fetch entirely, and 'cachedComputation' +-- \/ 'memo' deduplicate an entire sub-computation (not just a single request) +-- across multiple uses: +-- +-- > deduped :: GenHaxl u w es Int +-- > deduped = memo (CountAardvarks "ababa") $ do +-- > -- runs only once even if `deduped` itself is used more than once +-- > countAardvarks "ababa" +-- +-- == Handling exceptions +-- +-- 'GenHaxl' has its own 'catch' and 'try', distinct from the ones in +-- @Effectful.Exception@ or @Control.Exception@. +-- An exception thrown inside a 'GenHaxl' computation will not stop execution +-- at the point of the call, but only when its round of concurrent, batched +-- fetches is dispatched and completed. +-- Demanding the corresponding result will re-raise the exception. +-- +-- > safeCount :: GenHaxl u w es (Either SomeException Int) +-- > safeCount = try (countAardvarks "BANG") +module Effectful.Haxl + ( -- * Effect + Haxl + , runHaxlWith + , runHaxl + , haxl + , haxlWithStats + , haxlWithWrites + + -- * Env + , initEnv + , env + , withEnv + , GenHaxl (..) + , liftGenHaxl + , dataFetch + , uncachedRequest + , cacheRequest + , dupableCacheRequest + , cacheResult + , cacheResultWithShow + , cachedComputation + , preCacheComputation + , memoize + , memoize1 + , memoize2 + , memo + , memoFingerprint + + -- * Exceptions + , throw + , catch + , catchIf + , try + , rethrowAsyncExceptions + , tryWithRethrow + + -- * Dumping the cache + , dumpCacheAsHaskell + , dumpCacheAsHaskellFn + + -- * Re-exports + , module Haxl.Core + , module Haxl.Core.DataSource + , module Haxl.Core.Exception + , module Haxl.Core.Flags + , module Haxl.Core.Monad + , module Haxl.Core.ShowP + , module Haxl.Core.StateStore + , module Haxl.Core.Stats + ) +where + +import Data.Functor ((<&>)) +import Data.Hashable (Hashable) +import Data.IORef (readIORef) +import Data.Kind (Type) +import Data.Typeable (Typeable) +import Effectful +import Effectful.Dispatch.Static +import Effectful.Exception (Exception, SomeException) +import Effectful.Exception qualified as Effectful +import Haxl.Core (Env (..), Request) +import Haxl.Core qualified as Haxl +import Haxl.Core.DataSource +import Haxl.Core.Exception hiding (MonadFail (..), rethrowAsyncExceptions, tryWithRethrow) +import Haxl.Core.Fetch (ShowReq) +import Haxl.Core.Flags +import Haxl.Core.Memo (MemoFingerprintKey) +import Haxl.Core.Monad (Result (..)) +import Haxl.Core.Monad qualified as Env +import Haxl.Core.Monad qualified as Haxl +import Haxl.Core.ShowP +import Haxl.Core.StateStore +import Haxl.Core.Stats +import Haxl.Prelude (IfThenElse (..)) +import Prelude + +data Haxl (u :: Type) (w :: Type) :: Effect + +type instance DispatchOf (Haxl _ _) = 'Static 'WithSideEffects + +data instance StaticRep (Haxl u _) = Haxl + { stateStore :: !StateStore + , userEnv :: !u + , flags :: !Flags + } + +-- | Discharge the 'Haxl' effect for the duration of an action. +-- +-- Use this when you need a user environment (@u@), collected writes (@w@), +-- non-default 'Flags', or non-trivial state store initialisation. +-- If none of that applies, 'runHaxl' is a shorter alternative. +runHaxlWith + :: forall u w es a + . (IOE :> es) + => Eff es StateStore + -> u + -> Flags + -> Eff (Haxl u w ': es) a + -> Eff es a +runHaxlWith initialiseStore userEnv flags eff = do + stateStore <- initialiseStore + evalStaticRep Haxl{..} eff + +-- | Discharge the 'Haxl' effect for a single data source, with no user +-- environment, no writes, and default 'Flags'. +-- +-- This covers the common case of one data source and no need to tune +-- fetch reporting or batching behaviour. +runHaxl + :: (StateKey k, IOE :> es) + => State k + -> Eff (Haxl () () ': es) a + -> Eff es a +runHaxl s = runHaxlWith (pure $ stateSet s stateEmpty) () defaultFlags + +-- | Run a 'GenHaxl' computation to completion inside the 'Haxl' effect with a fresh 'Env'. +haxl :: forall u w es a. (Monoid w) => GenHaxl u w es a -> Eff (Haxl u w ': es) a +haxl g = do + env <- initEnv + inject $ unsafeConcUnliftIO Persistent Unlimited \unlift -> + Haxl.runHaxl env $ Haxl.GenHaxl (unlift . unHaxl g) + +-- | Like 'haxl', but also return everything written via the 'w' monoid during the run. +haxlWithWrites :: forall u w es a. (Monoid w) => GenHaxl u w es a -> Eff (Haxl u w ': es) (a, w) +haxlWithWrites g = do + env <- initEnv + inject $ unsafeConcUnliftIO Persistent Unlimited \unlift -> + Haxl.runHaxlWithWrites env $ Haxl.GenHaxl (unlift . unHaxl g) + +-- | Like 'haxl', but also return the 'Stats' collected during the run. +-- +-- Use this when you want to inspect batching behaviour, +-- e.g. asserting that a computation fetches in one round rather than many. +haxlWithStats :: forall u w es a. (Monoid w) => GenHaxl u w es a -> Eff (Haxl u w ': es) (a, Stats) +haxlWithStats g = do + env <- initEnv + a <- inject $ unsafeConcUnliftIO Persistent Unlimited \unlift -> + Haxl.runHaxl env $ Haxl.GenHaxl (unlift . unHaxl g) + stats <- unsafeEff_ . readIORef $ statsRef env + pure (a, stats) + +-- | Build a fresh 'Env' from the current 'Haxl' effect's state store, user +-- environment, and 'Flags'. +-- +-- Each 'Env' has its own request cache, so an 'Env' obtained here starts +-- with an empty cache even if other 'Env's have already been used within +-- the same 'Haxl' effect scope. +-- You normally don't need this directly, as 'haxl' and @haxlWith*@ call it for you. +initEnv :: forall u w es. (Monoid w, Haxl u w :> es) => Eff es (Env u w) +initEnv = do + Haxl{..} <- getStaticRep @(Haxl u w) + unsafeEff_ $ Haxl.initEnv stateStore userEnv <&> \env -> env{Env.flags} + +-- | The monad in which data-fetching computations are written. +-- +-- Note that 'GenHaxl' is not expressed in terms of 'Eff'. +-- Its 'Applicative' instance batches independent fetches combined with @('<*>')@ into a single round trip. +newtype GenHaxl u w es a = GenHaxl {unHaxl :: Env u w -> Eff es (Haxl.Result u w a)} + +instance Functor (GenHaxl u w es) where + fmap f (GenHaxl m) = GenHaxl $ (fmap . fmap . fmap) f m + +instance Applicative (GenHaxl u w es) where + pure = GenHaxl . const . pure . Done + f <*> a = GenHaxl $ \env -> do + unsafeConcUnliftIO Ephemeral Unlimited $ \unlift -> + Haxl.unHaxl + ( Haxl.GenHaxl (unlift . unHaxl f) + <*> Haxl.GenHaxl (unlift . unHaxl a) + ) + env + +instance Monad (GenHaxl u w es) where + return = pure + m >>= k = GenHaxl $ \env -> do + unsafeConcUnliftIO Ephemeral Unlimited $ \unlift -> + Haxl.unHaxl + ( Haxl.GenHaxl (unlift . unHaxl m) + >>= \a -> Haxl.GenHaxl (unlift . unHaxl (k a)) + ) + env + +instance MonadFail (GenHaxl u w es) where + fail = liftGenHaxl . fail + +instance (Semigroup a) => Semigroup (GenHaxl u w es a) where + (<>) = liftA2 (<>) + +instance (Monoid a) => Monoid (GenHaxl u w es a) where + mempty = pure mempty + +instance IfThenElse (GenHaxl u w es Bool) (GenHaxl u w es a) where + ifThenElse fb t e = do + b <- fb + if b then t else e + +instance (Num a) => Num (GenHaxl u w es a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + negate = fmap negate + +instance (Fractional a) => Fractional (GenHaxl u w es a) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = return . fromRational + +-- | Lift a plain 'Haxl.GenHaxl' computation into 'GenHaxl'. +-- +-- This is an escape hatch for the rare cases where you need to work directly +-- with 'Haxl.GenHaxl'; for example when you need precise control over +-- Haxl's fetch scheduling that the 'Eff' wrapper does not preserve, or when +-- integrating with third-party code that returns 'Haxl.GenHaxl' values +-- directly. +-- +-- Warning: 'Haxl.GenHaxl' exposes functions such as 'Haxl.unsafeLiftIO' +-- that allow arbitrary 'IO' to be injected without it being reflected in @es@. +liftGenHaxl :: Haxl.GenHaxl u w a -> GenHaxl u w es a +liftGenHaxl = GenHaxl . (unsafeEff_ .) . Haxl.unHaxl + +unliftGenHaxl :: GenHaxl u w es a -> Eff es (Haxl.GenHaxl u w a) +unliftGenHaxl g = + unsafeConcUnliftIO Ephemeral Unlimited $ pure . Haxl.GenHaxl . (. unHaxl g) + +unliftGenHaxl1 :: (a -> GenHaxl u w es b) -> Eff es (a -> Haxl.GenHaxl u w b) +unliftGenHaxl1 f = + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> pure \a -> + Haxl.GenHaxl $ unlift . unHaxl (f a) + +unliftGenHaxl2 :: (a -> b -> GenHaxl u w es c) -> Eff es (a -> b -> Haxl.GenHaxl u w c) +unliftGenHaxl2 f = + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> pure \a b -> + Haxl.GenHaxl $ unlift . unHaxl (f a b) + +mapGenHaxl :: (Haxl.GenHaxl u w a -> Haxl.GenHaxl u w b) -> GenHaxl u w es a -> GenHaxl u w es b +mapGenHaxl f g = GenHaxl \env -> do + g <- unliftGenHaxl g + unsafeEff_ $ Haxl.unHaxl (f g) env + +mapGenHaxl1 + :: ((a -> Haxl.GenHaxl u w b) -> Haxl.GenHaxl u w c) + -> (a -> GenHaxl u w es b) + -> GenHaxl u w es c +mapGenHaxl1 f g = GenHaxl \env -> do + g <- unliftGenHaxl1 g + unsafeEff_ $ Haxl.unHaxl (f g) env + +mapGenHaxl2 + :: ((a -> b -> Haxl.GenHaxl u w c) -> Haxl.GenHaxl u w d) + -> (a -> b -> GenHaxl u w es c) + -> GenHaxl u w es d +mapGenHaxl2 f g = GenHaxl \env -> do + g <- unliftGenHaxl2 g + unsafeEff_ $ Haxl.unHaxl (f g) env + +mapGenHaxlCatch + :: (Haxl.GenHaxl u w a -> (e -> Haxl.GenHaxl u w a) -> Haxl.GenHaxl u w a) + -> GenHaxl u w es a + -> (e -> GenHaxl u w es a) + -> GenHaxl u w es a +mapGenHaxlCatch f g h = GenHaxl \env -> do + g <- unliftGenHaxl g + h <- unliftGenHaxl1 h + unsafeEff_ $ Haxl.unHaxl (f g h) env + +-- | Lifted 'Haxl.env' +env :: (Env u w -> a) -> GenHaxl u w es a +env = liftGenHaxl . Haxl.env + +-- | Lifted 'Haxl.withEnv' +withEnv :: Env u w -> GenHaxl u w es a -> GenHaxl u w es a +withEnv = mapGenHaxl . Haxl.withEnv + +-- | Lifted 'Haxl.dataFetch' +dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w es a +dataFetch = liftGenHaxl . Haxl.dataFetch + +-- | Lifted 'Haxl.uncachedRequest' +uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u w es a +uncachedRequest = liftGenHaxl . Haxl.uncachedRequest + +-- | Lifted 'Haxl.cacheRequest' +cacheRequest :: (Request req a) => req a -> Either SomeException a -> GenHaxl u w es () +cacheRequest = (liftGenHaxl .) . Haxl.cacheRequest + +-- | Lifted 'Haxl.dupableCacheRequest' +dupableCacheRequest :: (Request req a) => req a -> Either SomeException a -> GenHaxl u w es () +dupableCacheRequest = (liftGenHaxl .) . Haxl.dupableCacheRequest + +-- | Lifted 'Haxl.cacheResult' +cacheResult :: (Request r a) => r a -> Eff es a -> GenHaxl u w es a +cacheResult r eff = + GenHaxl \env -> + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + Haxl.unHaxl (Haxl.cacheResult r (unlift eff)) env + +-- | Lifted 'Haxl.cacheResultWithShow' +cacheResultWithShow + :: (Hashable (r a), Typeable (r a)) + => ShowReq r a + -> r a + -> Eff es a + -> GenHaxl u w es a +cacheResultWithShow showReq req eff = + GenHaxl \env -> + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + Haxl.unHaxl (Haxl.cacheResultWithShow showReq req (unlift eff)) env + +-- | Lifted 'Haxl.cachedComputation' +cachedComputation + :: (Hashable (req a), Typeable (req a), Monoid w) + => req a + -> GenHaxl u w es a + -> GenHaxl u w es a +cachedComputation = mapGenHaxl . Haxl.cachedComputation + +-- | Lifted 'Haxl.preCacheComputation' +preCacheComputation + :: (Hashable (req a), Typeable (req a), Monoid w) + => req a + -> GenHaxl u w es a + -> GenHaxl u w es a +preCacheComputation = mapGenHaxl . Haxl.preCacheComputation + +-- | Lifted 'Haxl.memoize' +memoize :: (Monoid w) => GenHaxl u w es a -> GenHaxl u w es (GenHaxl u w es a) +memoize = fmap liftGenHaxl . mapGenHaxl Haxl.memoize + +-- | Lifted 'Haxl.memoize1' +memoize1 + :: (Hashable a, Monoid w) + => (a -> GenHaxl u w es b) + -> GenHaxl u w es (a -> GenHaxl u w es b) +memoize1 = fmap (liftGenHaxl .) . mapGenHaxl1 Haxl.memoize1 + +-- | Lifted 'Haxl.memoize2' +memoize2 + :: (Hashable a, Hashable b, Monoid w) + => (a -> b -> GenHaxl u w es c) + -> GenHaxl u w es (a -> b -> GenHaxl u w es c) +memoize2 = fmap ((liftGenHaxl .) .) . mapGenHaxl2 Haxl.memoize2 + +-- | Lifted 'Haxl.memo' +memo + :: ( Typeable a + , Typeable k + , Hashable k + , Monoid w + ) + => k + -> GenHaxl u w es a + -> GenHaxl u w es a +memo = mapGenHaxl . Haxl.memo + +-- | Lifted 'Haxl.memoFingerprint' +memoFingerprint + :: (Typeable a, Monoid w) + => MemoFingerprintKey a + -> GenHaxl u w es a + -> GenHaxl u w es a +memoFingerprint = mapGenHaxl . Haxl.memoFingerprint + +-- | Lifted 'Haxl.rethrowAsyncExceptions' +rethrowAsyncExceptions :: SomeException -> Eff es () +rethrowAsyncExceptions = unsafeEff_ . Haxl.rethrowAsyncExceptions + +tryWithRethrow :: Eff es a -> Eff es (Either SomeException a) +tryWithRethrow eff = (Right <$> eff) `Effectful.catch` \e -> rethrowAsyncExceptions e >> pure (Left e) + +-- | Lifted 'Haxl.throw' +throw :: (Exception e) => e -> GenHaxl u w es a +throw = liftGenHaxl . Haxl.throw + +-- | Lifted 'Haxl.catch' +catch :: (Exception e) => GenHaxl u w es a -> (e -> GenHaxl u w es a) -> GenHaxl u w es a +catch = mapGenHaxlCatch Haxl.catch + +-- | Lifted 'Haxl.catchIf' +catchIf + :: (Exception e) + => (e -> Bool) + -> GenHaxl u w es a + -> (e -> GenHaxl u w es a) + -> GenHaxl u w es a +catchIf = mapGenHaxlCatch . Haxl.catchIf + +-- | Lifted 'Haxl.try' +try :: (Exception e) => GenHaxl u w es a -> GenHaxl u w es (Either e a) +try = mapGenHaxl Haxl.try + +-- | Lifted 'Haxl.dumpCacheAsHaskell' +dumpCacheAsHaskell :: GenHaxl u w es String +dumpCacheAsHaskell = dumpCacheAsHaskellFn "loadCache" "GenHaxl u w es ()" "cacheRequest" + +-- | Lifted 'Haxl.dumpCacheAsHaskellFn' +dumpCacheAsHaskellFn :: String -> String -> String -> GenHaxl u w es String +dumpCacheAsHaskellFn = ((liftGenHaxl .) .) . Haxl.dumpCacheAsHaskellFn diff --git a/test/ExampleDataSource.hs b/test/ExampleDataSource.hs new file mode 100644 --- /dev/null +++ b/test/ExampleDataSource.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module ExampleDataSource + ( -- * initialise the state + initGlobalState + + -- * requests for this data source + , Id (..) + , ExampleReq (..) + , countAardvarks + , listWombats + ) +where + +import Control.Concurrent +import Control.Exception qualified as E +import Data.Hashable +import Effectful +import Effectful.Haxl +import System.IO (hPutStr, stderr) +import Prelude + +-- Here is an example minimal data source. Our data source will have +-- two requests: +-- +-- countAardvarks :: String -> Haxl Int +-- listWombats :: Id -> Haxl [Id] +-- +-- First, the data source defines a request type, with one constructor +-- for each request: + +newtype Id = Id Int + deriving newtype (Eq, Ord, Enum, Num, Integral, Real, Hashable) + +instance Show Id where + show (Id i) = show i + +data ExampleReq a where + CountAardvarks :: String -> ExampleReq Int + ListWombats :: Id -> ExampleReq [Id] + +-- The request type (ExampleReq) is parameterized by the result type of +-- each request. Each request might have a different result, so we use a +-- GADT - a data type in which each constructor may have different type +-- parameters. Here CountAardvarks is a request that takes a String +-- argument and its result is Int, whereas ListWombats takes an Id +-- argument and returns a [Id]. + +-- The request type needs instances for 'Eq1' and 'Hashable1'. These +-- are like 'Eq' and 'Hashable', but for types with one parameter +-- where the parameter is irrelevant for hashing and equality. +-- These two instances are used to support caching of requests. + +-- We need Eq, but we have to derive it with a standalone declaration +-- like this, because plain deriving doesn't work with GADTs. +deriving stock instance Eq (ExampleReq a) + +deriving stock instance Show (ExampleReq a) + +instance ShowP ExampleReq where showp = show + +instance Hashable (ExampleReq a) where + hashWithSalt s (CountAardvarks a) = hashWithSalt s (0 :: Int, a) + hashWithSalt s (ListWombats a) = hashWithSalt s (1 :: Int, a) + +instance StateKey ExampleReq where + data State ExampleReq = ExampleState + { + } + +-- in here you can put any state that the +-- data source needs to maintain throughout the +-- run. + +-- Next we need to define an instance of DataSourceName: + +instance DataSourceName ExampleReq where + dataSourceName _ = "ExampleDataSource" + +-- Next we need to define an instance of DataSource: + +instance DataSource u ExampleReq where + -- I'll define exampleFetch below + fetch = exampleFetch + + -- we don't want to treat NotFound as an exception for stats purposes + classifyFailure _ _ e + | Just NotFound{} <- E.fromException e = IgnoredForStatsFailure + | otherwise = StandardFailure + +-- Every data source should define a function 'initGlobalState' that +-- initialises the state for that data source. The arguments to this +-- function might vary depending on the data source - we might need to +-- pass in resources from the environment, or parameters to set up the +-- data source. +initGlobalState :: Eff es (State ExampleReq) +initGlobalState = pure ExampleState{} + +-- The most important bit: fetching the data. The fetching function +-- takes a list of BlockedFetch, which is defined as +-- +-- data BlockedFetch r +-- = forall a . BlockedFetch (r a) (ResultVar a) +-- +-- That is, each BlockedFetch is a pair of +-- +-- - the request to fetch (with result type a) +-- - a ResultVar to store either the result or an error +-- +-- The job of fetch is to fetch the data and fill in all the ResultVars. +-- +exampleFetch + :: State ExampleReq -- current state + -> Flags -- tracing verbosity, etc. + -> u -- user environment + -> PerformFetch ExampleReq -- tells the framework how to fetch +exampleFetch _state _flags _user = SyncFetch $ mapM_ fetch1 + +-- There are two ways a data source can fetch data: synchronously or +-- asynchronously. See the type 'PerformFetch' in "Haxl.Core.Types" for +-- details. + +fetch1 :: BlockedFetch ExampleReq -> IO () +fetch1 (BlockedFetch (CountAardvarks "BANG") _) = + error "BANG" -- data sources should not throw exceptions, but in + -- the event that one does, the framework will + -- propagate the exception to the call site of + -- dataFetch. +fetch1 (BlockedFetch (CountAardvarks "BANG2") m) = do + putSuccess m 1 + error "BANG2" -- the exception is propagated even if we have already + -- put the result with putSuccess +fetch1 (BlockedFetch (CountAardvarks "BANG3") _) = do + hPutStr stderr "BANG3" + killThread =<< myThreadId -- an asynchronous exception +fetch1 (BlockedFetch (CountAardvarks "BANG4") r) = do + putFailure r $ NotFound "BANG4" +fetch1 (BlockedFetch (CountAardvarks str) m) = + putSuccess m (length (filter (== 'a') str)) +fetch1 (BlockedFetch (ListWombats a) r) = + if a > 999999 + then putFailure r $ FetchError "too large" + else putSuccess r $ take (fromIntegral a) [1 ..] + +-- Normally a data source will provide some convenient wrappers for +-- its requests: + +countAardvarks :: String -> GenHaxl u w es Int +countAardvarks str = dataFetch (CountAardvarks str) + +listWombats :: Id -> GenHaxl u w es [Id] +listWombats i = dataFetch (ListWombats i) diff --git a/test/LoadCache.hs b/test/LoadCache.hs new file mode 100644 --- /dev/null +++ b/test/LoadCache.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} + +{- HLINT ignore "Redundant bracket" -} + +module LoadCache where + +import Effectful.Haxl +import ExampleDataSource +import Prelude + +#include "./LoadCache.txt" diff --git a/test/LoadCache.txt b/test/LoadCache.txt new file mode 100644 --- /dev/null +++ b/test/LoadCache.txt @@ -0,0 +1,5 @@ +loadCache :: GenHaxl u w es () +loadCache = do + cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy"))) + cacheRequest (CountAardvarks "xxx") (Right (3)) + cacheRequest (ListWombats 100) (Right ([1,2,3])) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,388 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main where + +import Data.Functor ((<&>)) +import Data.List qualified as List +import Data.Maybe (mapMaybe) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Effectful +import Effectful.Exception (AsyncException (..), ErrorCall (..), SomeException) +import Effectful.Exception qualified as Effectful +import Effectful.FileSystem (FileSystem, runFileSystem) +import Effectful.FileSystem.IO.ByteString (readFile) +import Effectful.Haxl as Haxl +import Effectful.Hspec +import Effectful.Prim (Prim, runPrim) +import Effectful.Prim.IORef (modifyIORef', newIORef, readIORef) +import ExampleDataSource (Id (..)) +import ExampleDataSource qualified +import LoadCache (loadCache) +import System.FilePath (dropFileName, ()) +import Prelude hiding (readFile) + +initialState :: Eff es StateStore +initialState = flip stateSet stateEmpty <$> ExampleDataSource.initGlobalState + +withFetchStats :: Flags +withFetchStats = + defaultFlags + { report = setReportFlag ReportFetchStats defaultReportFlags + } + +main :: IO () +main = + runEff + . runPrim + . runFileSystem + . runHspec + . runHaxlWith @() @() initialState () withFetchStats + $ do + describe "env" do + envTest + withEnvTest + describe "batching" do + describe "single round" do + applicativeBatchingTest + numBatchingTest + largeBatchTest + describe "multi-round" do + sequentialRoundsTest + dependentFanOutTest + deepChainTest + describe "caching" do + preCacheTest + preCacheExceptionTest + cachedComputationTest + cacheResultTest + memoTest + describe "exceptions" do + syncExceptionTest + asyncExceptionTest + describe "cache dump" do + dumpCacheTest + +-- * Helpers + +-- Run a 'GenHaxl' action and return the result alongside the per-round +-- 'FetchStats'. +withStats + :: forall es a + . (Haxl () () :> es) + => GenHaxl () () es a + -> Eff es (a, [FetchStats]) +withStats g = do + (a, Stats stats) <- inject $ haxlWithStats @() @() g + pure (a, stats) + +rounds :: [FetchStats] -> Int +rounds = length + +fetchBatchSizes :: [FetchStats] -> [Int] +fetchBatchSizes = + reverse . mapMaybe \case + FetchStats{..} -> Just fetchBatchSize + _ -> Nothing + +totalFetches :: [FetchStats] -> Int +totalFetches = sum . fetchBatchSizes + +-- Assert that a computation completes in exactly @n@ fetch rounds. +shouldUseRounds + :: (HasCallStack, Haxl () () :> es, Hspec :> es) + => GenHaxl () () es a -> Int -> Eff es () +g `shouldUseRounds` n = do + (_, stats) <- withStats g + rounds stats `shouldBe` n + +-- Assert that a computation issues exactly @n@ fetches in total across all +-- rounds. +shouldUseFetches + :: (HasCallStack, Haxl () () :> es, Hspec :> es) + => GenHaxl () () es a -> Int -> Eff es () +g `shouldUseFetches` n = do + (_, stats) <- withStats g + totalFetches stats `shouldBe` n + +-- Assert that a computation completes in exactly @r@ rounds issuing exactly +-- @f@ fetches in total. +shouldUseRoundsAndFetches + :: (HasCallStack, Haxl () () :> es, Hspec :> es) + => GenHaxl () () es a -> (Int, Int) -> Eff es () +g `shouldUseRoundsAndFetches` (r, f) = do + (_, stats) <- withStats g + rounds stats `shouldBe` r + totalFetches stats `shouldBe` f + +deriving stock instance Eq Flags + +instance Eq ReportFlags where + r1 == r2 = show r1 == show r2 + +deriving stock instance Show Flags + +-- * Env + +-- 'env' should extract data from the current 'Env'. +envTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +envTest = it "extracts data from the Env" do + flags <- inject . haxl @() @() $ env Haxl.flags + flags `shouldBe` withFetchStats + +-- 'withEnv' should override the 'Env' for the duration of a computation, +-- then restore it afterwards. +withEnvTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +withEnvTest = it "overrides the Env for the duration of a computation" do + newEnv <- initEnv <&> \env -> env{Haxl.flags = defaultFlags} + (inner, outer) <- inject . haxl @() @() $ do + let newEnv' = newEnv{Haxl.flags = defaultFlags} + inner <- withEnv newEnv' $ env Haxl.flags + outer <- env Haxl.flags + pure (inner, outer) + inner `shouldBe` defaultFlags + outer `shouldBe` withFetchStats + +-- * Single-round batching + +-- Two independent applicative fetches should be batched into one round. +applicativeBatchingTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +applicativeBatchingTest = it "batches two independent applicative fetches" do + let g :: GenHaxl () () es Int + g = + ExampleDataSource.countAardvarks "abcabc" + + (length <$> ExampleDataSource.listWombats 3) + (result, stats) <- withStats g + result `shouldBe` 2 + 3 + rounds stats `shouldBe` 1 + totalFetches stats `shouldBe` 2 + +-- The 'Num' instance uses 'liftA2', so arithmetic over fetched values should +-- also batch into one round. +numBatchingTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +numBatchingTest = it "batches fetches combined with Num arithmetic" do + let g :: GenHaxl () () es Int + g = + ExampleDataSource.countAardvarks "abcabc" + + (length <$> ExampleDataSource.listWombats 3) + g `shouldUseRoundsAndFetches` (1, 2) + +-- Many independent fetches should all land in a single round regardless of +-- how many there are. +largeBatchTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +largeBatchTest = it "batches many independent fetches into one round" do + let queries = take 8 $ flip replicate 'a' <$> [1 ..] + let g :: GenHaxl () () es Int + g = sum <$> traverse ExampleDataSource.countAardvarks queries + g `shouldUseRoundsAndFetches` (1, 8) + +-- * Multi-round batching + +-- A monadic bind forces a second round: the second fetch cannot be issued +-- until the first result is known. +sequentialRoundsTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +sequentialRoundsTest = it "uses two rounds for a monadic sequence" do + let g :: GenHaxl () () es Int + g = do + n <- ExampleDataSource.countAardvarks "abcabc" + length <$> ExampleDataSource.listWombats (Id n) + g `shouldUseRoundsAndFetches` (2, 2) + +-- After one blocking fetch, multiple independent fetches in the next round +-- should still be batched together. +dependentFanOutTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +dependentFanOutTest = it "batches a fan-out of fetches in round 2" do + let g :: GenHaxl () () es Int + g = do + n <- ExampleDataSource.countAardvarks "abcabc" -- round 1 + -- Both listWombats calls are independent of each other, so they + -- should be batched into a single round 2. + (length <$> ExampleDataSource.listWombats (Id n)) + + (length <$> ExampleDataSource.listWombats (Id $ n + 1)) + (result, stats) <- withStats g + result `shouldBe` 2 + 3 + rounds stats `shouldBe` 2 + fetchBatchSizes stats `shouldBe` [1, 2] + +-- A large fan-out after an initial fetch: all N dependent fetches should +-- land in round 2, not spread across N rounds. +largeFanOutTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +largeFanOutTest = it "batches a large fan-out into round 2" do + let g :: GenHaxl () () es Int + g = do + n <- ExampleDataSource.countAardvarks "abcabc" -- round 1, n == 2 + -- Fan out to n+6 = 8 independent fetches in round 2 + let queries = take (n + 6) $ flip replicate 'a' <$> [1 ..] + sum <$> traverse ExampleDataSource.countAardvarks queries + (_, stats) <- withStats g + rounds stats `shouldBe` 2 + fetchBatchSizes stats `shouldBe` [1, 8] + +-- A chain of dependent fetches should take exactly one round per step, with +-- no spurious extra rounds. +deepChainTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +deepChainTest = it "uses one round per step in a dependent chain" do + let g :: GenHaxl () () es Int + g = do + n1 <- ExampleDataSource.countAardvarks "ab" -- round 1 + n2 <- ExampleDataSource.countAardvarks (replicate n1 'a') -- round 2 + length <$> ExampleDataSource.listWombats (Id n2) -- round 3 + g `shouldUseRounds` 3 + +-- Mixing applicative and monadic style: applicative branches within each +-- monadic step should still batch. +mixedStyleTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +mixedStyleTest = it "batches applicative branches within each monadic step" do + let g :: GenHaxl () () es Int + g = do + -- Round 1: two fetches batched + (n1, n2) <- + (,) + <$> ExampleDataSource.countAardvarks "ab" + <*> ExampleDataSource.countAardvarks "abc" + -- Round 2: two fetches batched + (w1, w2) <- + (,) + <$> ExampleDataSource.listWombats (Id n1) + <*> ExampleDataSource.listWombats (Id n2) + pure (length w1 + length w2) + (_, stats) <- withStats g + rounds stats `shouldBe` 2 + fetchBatchSizes stats `shouldBe` [2, 2] + +-- * Caching + +-- Results pre-seeded with 'cacheRequest' are returned without issuing any +-- fetches. +preCacheTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +preCacheTest = it "returns pre-cached results without fetching" do + let g :: GenHaxl () () es Int + g = do + cacheRequest (ExampleDataSource.CountAardvarks "xxx") (Right 3) + cacheRequest (ExampleDataSource.ListWombats 1000000) (Right [1, 2, 3]) + ExampleDataSource.countAardvarks "xxx" + (length <$> ExampleDataSource.listWombats 1000000) + (result, stats) <- withStats g + result `shouldBe` 6 + rounds stats `shouldBe` 0 + +preCacheExceptionTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +preCacheExceptionTest = it "re-throws pre-cached exceptions" do + r <- Effectful.try . inject . haxl @() @() $ do + cacheRequest (ExampleDataSource.CountAardvarks "yyy") $ + except (NotFound "yyy") + ExampleDataSource.countAardvarks "yyy" + r `shouldSatisfy` \case + Left (NotFound "yyy") -> True + _ -> False + +-- 'cachedComputation' deduplicates a sub-computation across uses, reducing +-- the total number of fetches. +cachedComputationTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +cachedComputationTest = it "deduplicates cachedComputation across uses" do + let g :: GenHaxl () () es Int + g = + cachedComputation (ExampleDataSource.CountAardvarks "ababa") $ + (length <$> ExampleDataSource.listWombats 10) + + (length <$> ExampleDataSource.listWombats 20) + -- x used twice: second use hits the cache, so only 2 + 1 = 3 fetches total + -- rather than 2 + 2 + 1 = 5. + (r, stats) <- withStats $ g + g + ExampleDataSource.countAardvarks "baba" + r `shouldBe` 62 + totalFetches stats `shouldBe` 3 + +-- 'cacheResult' runs its 'Eff' action exactly once even when used +-- applicatively, which would otherwise execute it twice. +cacheResultTest + :: forall es + . (Haxl () () :> es, Hspec :> es, Prim :> es) + => Expectation es +cacheResultTest = it "executes cacheResult action exactly once" do + ref <- newIORef (0 :: Int) + let request = cacheResult (ExampleDataSource.CountAardvarks "ababa") $ do + modifyIORef' ref (+ 1) + readIORef ref + r <- inject . haxl @() @() $ request + request + -- The action increments and reads ref; it should run once, giving 1. + -- Both uses of `request` return 1, so the sum is 2. + r `shouldBe` 2 + +-- 'memo' deduplicates across uses in the same run, same as +-- 'cachedComputation'. +memoTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +memoTest = it "deduplicates memo'd computations" do + let g :: GenHaxl () () es Int + g = + memo (ExampleDataSource.CountAardvarks "ababa") $ + (length <$> ExampleDataSource.listWombats 10) + + (length <$> ExampleDataSource.listWombats 20) + (r, stats) <- withStats $ g + g + ExampleDataSource.countAardvarks "baba" + r `shouldBe` 62 + totalFetches stats `shouldBe` 3 + +-- * Exceptions + +syncExceptionTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +syncExceptionTest = do + it "catches synchronous data-source exceptions with Haxl.try" do + r <- + inject . haxl @() @() . Haxl.try $ + ExampleDataSource.countAardvarks "BANG" + r `shouldSatisfy` \case + Left (ErrorCall "BANG") -> True + _ -> False + + it "catches a second independent sync exception" do + r <- + inject . haxl @() @() . Haxl.try $ + ExampleDataSource.countAardvarks "BANG2" + r `shouldSatisfy` \case + Left (ErrorCall "BANG2") -> True + _ -> False + + it "still batches both fetches when one branch throws" do + (r, Stats stats) <- + inject . haxlWithStats @() @() $ + Haxl.try $ + (<>) + <$> ExampleDataSource.listWombats 1000000 + <*> ExampleDataSource.listWombats 1000001 + r `shouldSatisfy` \case + Left FetchError{} -> True + Right _ -> False + sum [fetchBatchSize | FetchStats{..} <- stats] `shouldBe` 2 + sum [fetchFailures | FetchStats{..} <- stats] `shouldBe` 2 + +-- Asynchronous exceptions (e.g. 'ThreadKilled') escape 'Haxl.try' and must +-- be caught outside 'runHaxl'. +asyncExceptionTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es +asyncExceptionTest = it "propagates async exceptions past Haxl.try" do + r :: Either AsyncException (Either SomeException Int) <- + Effectful.try $ + inject . haxl @() @() . Haxl.try $ + (length <$> ExampleDataSource.listWombats 100) + + ExampleDataSource.countAardvarks "BANG3" + r `shouldSatisfy` \case + Left ThreadKilled -> True + _ -> False + +-- * Cache dump + +-- Load a known cache then dump it; the output should match the fixture file. +-- Both operations run in the same 'haxl' call so they share the 'Env'. +dumpCacheTest + :: forall es + . (FileSystem :> es, Haxl () () :> es, Hspec :> es) + => Expectation es +dumpCacheTest = it "round-trips the cache through dumpCacheAsHaskell" do + str <- inject . haxl @() @() $ do + loadCache + dumpCacheAsHaskell + fixture <- + Text.unpack . Text.decodeUtf8 + <$> readFile (dropFileName __FILE__ "LoadCache.txt") + -- Line order is non-deterministic across GHC versions, so sort before + -- comparing. + List.sort (lines str) `shouldBe` List.sort (lines fixture)