diff --git a/Haxl/Core.hs b/Haxl/Core.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core.hs @@ -0,0 +1,24 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +-- | Everything needed to define data sources and to invoke the +-- engine. This module should not be imported by user code. +module Haxl.Core + ( module Haxl.Core.Env + , module Haxl.Core.Monad + , module Haxl.Core.Types + , module Haxl.Core.Exception + , module Haxl.Core.StateStore + , module Haxl.Core.Show1 + ) where + +import Haxl.Core.Env +import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -}) +import Haxl.Core.Types +import Haxl.Core.Exception +import Haxl.Core.Show1 (Show1(..)) +import Haxl.Core.StateStore diff --git a/Haxl/Core/DataCache.hs b/Haxl/Core/DataCache.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/DataCache.hs @@ -0,0 +1,113 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | A cache mapping data requests to their results. +module Haxl.Core.DataCache + ( DataCache + , empty + , insert + , lookup + , showCache + ) where + +import Data.HashMap.Strict (HashMap) +import Data.Hashable +import Prelude hiding (lookup) +import Unsafe.Coerce +import qualified Data.HashMap.Strict as HashMap +import Data.Typeable.Internal +import Data.Maybe +import Control.Applicative hiding (empty) +import Control.Exception + +import Haxl.Core.Types + +-- | The 'DataCache' maps things of type @f a@ to @'ResultVar' a@, for +-- any @f@ and @a@ provided @f a@ is an instance of 'Typeable'. In +-- practice @f a@ will be a request type parameterised by its result. +-- +-- See the definition of 'ResultVar' for more details. + +newtype DataCache = DataCache (HashMap TypeRep SubCache) + +-- | The implementation is a two-level map: the outer level maps the +-- types of requests to 'SubCache', which maps actual requests to their +-- results. So each 'SubCache' contains requests of the same type. +-- This works well because we only have to store the dictionaries for +-- 'Hashable' and 'Eq' once per request type. +data SubCache = + forall req a . (Hashable (req a), Eq (req a), Show (req a), Show a) => + SubCache ! (HashMap (req a) (ResultVar a)) + -- NB. the inner HashMap is strict, to avoid building up + -- a chain of thunks during repeated insertions. + +-- | A new, empty 'DataCache'. +empty :: DataCache +empty = DataCache HashMap.empty + +-- | Inserts a request-result pair into the 'DataCache'. +insert + :: (Hashable (r a), Typeable (r a), Eq (r a), Show (r a), Show a) + => r a + -- ^ Request + -> ResultVar a + -- ^ Result + -> DataCache + -> DataCache + +insert req result (DataCache m) = + DataCache $ + HashMap.insertWith fn (typeOf req) + (SubCache (HashMap.singleton req result)) m + where + fn (SubCache new) (SubCache old) = + SubCache (unsafeCoerce new `HashMap.union` old) + +-- | Looks up the cached result of a request. +lookup + :: Typeable (r a) + => r a + -- ^ Request + -> DataCache + -> Maybe (ResultVar a) + +lookup req (DataCache m) = + case HashMap.lookup (typeOf req) m of + Nothing -> Nothing + Just (SubCache sc) -> + unsafeCoerce (HashMap.lookup (unsafeCoerce req) sc) + +-- | Dumps the contents of the cache, with requests and responses +-- converted to 'String's using 'show'. The entries are grouped by +-- 'TypeRep'. +-- +showCache + :: DataCache + -> IO [(TypeRep, [(String, Either SomeException String)])] + +showCache (DataCache cache) = mapM goSubCache (HashMap.toList cache) + where + goSubCache + :: (TypeRep,SubCache) + -> IO (TypeRep,[(String, Either SomeException String)]) + goSubCache (ty, SubCache hmap) = do + elems <- catMaybes <$> mapM go (HashMap.toList hmap) + return (ty, elems) + + go :: (Show (req a), Show a) + => (req a, ResultVar a) + -> IO (Maybe (String, Either SomeException String)) + go (req, rvar) = do + maybe_r <- tryReadResult rvar + case maybe_r of + Nothing -> return Nothing + Just (Left e) -> return (Just (show req, Left e)) + Just (Right result) -> return (Just (show req, Right (show result))) diff --git a/Haxl/Core/Env.hs b/Haxl/Core/Env.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Env.hs @@ -0,0 +1,65 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE OverloadedStrings #-} + +-- | The Haxl monad environment. +module Haxl.Core.Env + ( Env(..) + , emptyEnv + , initEnv + , initEnvWithData + , caches + ) where + +import Haxl.Core.DataCache as DataCache +import Haxl.Core.StateStore +import Haxl.Core.Types + +import Data.IORef + +-- | The data we carry around in the Haxl monad. +data Env u = Env + { cacheRef :: IORef DataCache -- cached data fetches + , memoRef :: IORef DataCache -- memoized computations + , flags :: Flags + , userEnv :: u + , statsRef :: IORef Stats + , states :: StateStore + -- ^ Data sources and other components can store their state in + -- here. Items in this store must be instances of 'StateKey'. + } + +type Caches = (IORef DataCache, IORef DataCache) + +caches :: Env u -> Caches +caches env = (cacheRef env, memoRef env) + +-- | Initialize an environment with a 'StateStore', an input map, a +-- preexisting 'DataCache', and a seed for the random number generator. +initEnvWithData :: StateStore -> u -> Caches -> IO (Env u) +initEnvWithData states e (cref, mref) = do + sref <- newIORef emptyStats + return Env + { cacheRef = cref + , memoRef = mref + , flags = defaultFlags + , userEnv = e + , states = states + , statsRef = sref + } + +-- | Initializes an environment with 'DataStates' and an input map. +initEnv :: StateStore -> u -> IO (Env u) +initEnv states e = do + cref <- newIORef DataCache.empty + mref <- newIORef DataCache.empty + initEnvWithData states e (cref,mref) + +-- | A new, empty environment. +emptyEnv :: u -> IO (Env u) +emptyEnv = initEnv stateEmpty diff --git a/Haxl/Core/Exception.hs b/Haxl/Core/Exception.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Exception.hs @@ -0,0 +1,260 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | An exception hierarchy that can be used with the 'Haxl' monad. +-- +-- The Haxl framework may throw exceptions from this hierarchy: for +-- example, a misbehaving data source causes 'dataFetch' to throw a +-- 'DataSourceError'. The combinator 'withDefault' from +-- "Haxl.Core.Prelude" uses this hierarchy to provide default values +-- for expressions that raise 'TransientError' or 'LogicError' +-- exceptions. +-- +-- You are under no obligations to use this hierarchy for your own +-- exceptions, but you might find it useful nonetheless; for +-- 'withDefault' to be useful, for example, you'll want your +-- exceptions to be children of 'LogicError' or 'TransientError' as +-- appropriate. + +module Haxl.Core.Exception ( + + HaxlException(..), + + -- * Exception categories + InternalError(..), + internalErrorToException, + internalErrorFromException, + + LogicError(..), + logicErrorToException, + logicErrorFromException, + + TransientError(..), + transientErrorToException, + transientErrorFromException, + + -- ** Internal exceptions + CriticalError(..), + DataSourceError(..), + + -- ** Logic exceptions + NotFound(..), + UnexpectedType(..), + EmptyList(..), + JSONError(..), + InvalidParameter(..), + + -- ** Transient exceptions + FetchError(..), + + -- * Exception utilities + asHaxlException, + + ) where + +import Control.Exception +import Data.Aeson +import Data.Typeable +import Data.Text (Text) + +import Haxl.Core.Util + +-- | We have a 3-tiered hierarchy of exceptions, with 'HaxlException' at +-- the top, and all Haxl exceptions as children of this. Users should +-- never deal directly with 'HaxlException's. +-- +-- The main types of exceptions are: +-- +-- ['InternalError'] Something is wrong with Haxl core. +-- +-- ['LogicError'] Something is wrong with Haxl client code. +-- +-- ['TransientError'] Something is temporarily failing (usually in a fetch). +-- +-- These are not meant to be thrown (but likely be caught). Thrown +-- exceptions should be a subclass of one of these. There are some +-- generic leaf exceptions defined below this, such as 'FetchError' +-- (generic transient failure) or 'CriticalError' (internal failure). +-- +data HaxlException + = forall e. (Exception e, MiddleException e) => HaxlException e + deriving (Typeable) + +instance Show HaxlException where + show (HaxlException e) = show e + +instance Exception HaxlException + +-- | These need to be serializable to JSON to cross FFI boundaries. +instance ToJSON HaxlException where + toJSON (HaxlException e) = object + [ "type" .= show (typeOf e) + , "name" .= eName e + , "txt" .= show e + ] + +haxlExceptionToException + :: (Exception e, MiddleException e) => e -> SomeException +haxlExceptionToException = toException . HaxlException + +haxlExceptionFromException + :: (Exception e, MiddleException e) => SomeException -> Maybe e +haxlExceptionFromException x = do + HaxlException a <- fromException x + cast a + +class (Exception a) => MiddleException a where + eName :: a -> String + +-- | For transient failures. +data TransientError = forall e . (Exception e) => TransientError e + deriving (Typeable) + +deriving instance Show TransientError + +instance Exception TransientError where + toException = haxlExceptionToException + fromException = haxlExceptionFromException + +instance MiddleException TransientError where + eName (TransientError e) = show $ typeOf e + +transientErrorToException :: (Exception e) => e -> SomeException +transientErrorToException = toException . TransientError + +transientErrorFromException + :: (Exception e) => SomeException -> Maybe e +transientErrorFromException x = do + TransientError a <- fromException x + cast a + +-- | For errors in Haxl core code. +data InternalError = forall e . (Exception e) => InternalError e + deriving (Typeable) + +deriving instance Show InternalError + +instance Exception InternalError where + toException = haxlExceptionToException + fromException = haxlExceptionFromException + +instance MiddleException InternalError where + eName (InternalError e) = show $ typeOf e + +internalErrorToException :: (Exception e) => e -> SomeException +internalErrorToException = toException . InternalError + +internalErrorFromException + :: (Exception e) => SomeException -> Maybe e +internalErrorFromException x = do + InternalError a <- fromException x + cast a + +-- | For errors in Haxl client code. +data LogicError = forall e . (Exception e) => LogicError e + deriving (Typeable) + +deriving instance Show LogicError + +instance Exception LogicError where + toException = haxlExceptionToException + fromException = haxlExceptionFromException + +instance MiddleException LogicError where + eName (LogicError e) = show $ typeOf e + +logicErrorToException :: (Exception e) => e -> SomeException +logicErrorToException = toException . LogicError + +logicErrorFromException + :: (Exception e) => SomeException -> Maybe e +logicErrorFromException x = do + LogicError a <- fromException x + cast a + +------------------------------------------------------------------------ +-- Leaf exceptions. You should throw these. Or make your own. +------------------------------------------------------------------------ + +-- | Generic \"critical\" exception. Something internal is +-- borked. Panic. +data CriticalError = CriticalError Text + deriving (Typeable, Show) + +instance Exception CriticalError where + toException = internalErrorToException + fromException = internalErrorFromException + +-- | Generic \"something was not found\" exception. +data NotFound = NotFound Text + deriving (Typeable, Show) + +instance Exception NotFound where + toException = logicErrorToException + fromException = logicErrorFromException + +-- | Generic \"something had the wrong type\" exception. +data UnexpectedType = UnexpectedType Text + deriving (Typeable, Show) + +instance Exception UnexpectedType where + toException = logicErrorToException + fromException = logicErrorFromException + +-- | Generic \"input list was empty\" exception. +data EmptyList = EmptyList Text + deriving (Typeable,Show) + +instance Exception EmptyList where + toException = logicErrorToException + fromException = logicErrorFromException + +-- | Generic \"Incorrect assumptions about JSON data\" exception. +data JSONError = JSONError Text + deriving (Typeable, Show) + +instance Exception JSONError where + toException = logicErrorToException + fromException = logicErrorFromException + +-- | Generic \"passing some invalid parameter\" exception. +data InvalidParameter = InvalidParameter Text + deriving (Typeable, Show) + +instance Exception InvalidParameter where + toException = logicErrorToException + fromException = logicErrorFromException + +-- | Generic transient fetching exceptions. +data FetchError = FetchError Text + deriving (Typeable, Eq, Show) + +instance Exception FetchError where + toException = transientErrorToException + fromException = transientErrorFromException + +-- | A data source did something wrong +data DataSourceError = DataSourceError Text + deriving (Typeable, Eq, Show) + +instance Exception DataSourceError where + toException = internalErrorToException + fromException = internalErrorFromException + +-- | Converts all exceptions that are not derived from 'HaxlException' +-- into 'CriticalError', using 'show'. +asHaxlException :: SomeException -> HaxlException +asHaxlException e + | Just haxl_exception <- fromException e = -- it's a HaxlException + haxl_exception + | otherwise = + HaxlException (InternalError (CriticalError (textShow e))) diff --git a/Haxl/Core/Fetch.hs b/Haxl/Core/Fetch.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Fetch.hs @@ -0,0 +1,172 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Generic fetching infrastructure, used by 'Haxl.Core.Monad'. +module Haxl.Core.Fetch + ( CacheResult(..) + , cached + , memoized + , performFetches + ) where + +import Haxl.Core.DataCache as DataCache +import Haxl.Core.Env +import Haxl.Core.Exception +import Haxl.Core.RequestStore +import Haxl.Core.Show1 +import Haxl.Core.StateStore +import Haxl.Core.Types +import Haxl.Core.Util + +import Control.Exception +import Control.Monad +import Data.IORef +import Data.List +import Data.Time +import Text.Printf +import Data.Monoid +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text + +-- | Issues a batch of fetches in a 'RequestStore'. After +-- 'performFetches', all the requests in the 'RequestStore' are +-- complete, and all of the 'ResultVar's are full. +performFetches :: forall u. Env u -> RequestStore u -> IO () +performFetches env reqs = do + let f = flags env + sref = statsRef env + jobs = contents reqs + + t0 <- getCurrentTime + + let + roundstats = + [ (dataSourceName (getReq reqs), length reqs) + | BlockedFetches reqs <- jobs ] + where + getReq :: [BlockedFetch r] -> r a + getReq = undefined + + modifyIORef' sref $ \(Stats rounds) -> + Stats (RoundStats (HashMap.fromList roundstats) : rounds) + + ifTrace f 1 $ + printf "Batch data fetch (%s)\n" $ + intercalate (", "::String) $ + map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats + + ifTrace f 3 $ + forM_ jobs $ \(BlockedFetches reqs) -> + forM_ reqs $ \(BlockedFetch r _) -> putStrLn (show1 r) + + let + applyFetch (BlockedFetches (reqs :: [BlockedFetch r])) = + case stateGet (states env) of + Nothing -> + return (SyncFetch (mapM_ (setError (const e)) reqs)) + where req :: r a; req = undefined + e = DataSourceError $ + "data source not initialized: " <> dataSourceName req + Just state -> + return $ wrapFetch reqs $ fetch state f (userEnv env) reqs + + fetches <- mapM applyFetch jobs + + scheduleFetches fetches + + ifTrace f 1 $ do + t1 <- getCurrentTime + printf "Batch data fetch done (%.2fs)\n" + (realToFrac (diffUTCTime t1 t0) :: Double) + +-- Catch exceptions arising from the data source and stuff them into +-- the appropriate requests. We don't want any exceptions propagating +-- directly from the data sources, because we want the exception to be +-- thrown by dataFetch instead. +-- +wrapFetch :: [BlockedFetch req] -> PerformFetch -> PerformFetch +wrapFetch reqs fetch = + case fetch of + SyncFetch io -> SyncFetch (io `catch` handler) + AsyncFetch fio -> AsyncFetch (\io -> fio io `catch` handler) + where + handler :: SomeException -> IO () + handler e = mapM_ (forceError e) reqs + + -- Set the exception even if the request already had a result. + -- Otherwise we could be discarding an exception. + forceError e (BlockedFetch _ rvar) = do + void $ tryTakeResult rvar + putResult rvar (except e) + +-- | Start all the async fetches first, then perform the sync fetches before +-- getting the results of the async fetches. +scheduleFetches :: [PerformFetch] -> IO() +scheduleFetches fetches = async_fetches sync_fetches + where + async_fetches :: IO () -> IO () + async_fetches = compose [f | AsyncFetch f <- fetches] + + sync_fetches :: IO () + sync_fetches = sequence_ [io | SyncFetch io <- fetches] + +-- | Possible responses when checking the cache. +data CacheResult a + -- | The request hadn't been seen until now. + = Uncached (ResultVar a) + + -- | The request has been seen before, but its result has not yet been + -- fetched. + | CachedNotFetched (ResultVar a) + + -- | The request has been seen before, and its result has already been + -- fetched. + | Cached (Either SomeException a) + + +-- | Checks the data cache for the result of a request. +cached :: (Request r a) => Env u -> r a -> IO (CacheResult a) +cached env = checkCache (flags env) (cacheRef env) + +-- | Checks the memo cache for the result of a computation. +memoized :: (Request r a) => Env u -> r a -> IO (CacheResult a) +memoized env = checkCache (flags env) (memoRef env) + +-- | Common guts of 'cached' and 'memoized'. +checkCache + :: (Request r a) + => Flags + -> IORef DataCache + -> r a + -> IO (CacheResult a) + +checkCache flags ref req = do + cache <- readIORef ref + let + do_fetch = do + rvar <- newEmptyResult + writeIORef ref (DataCache.insert req rvar cache) + return (Uncached rvar) + case DataCache.lookup req cache of + Nothing -> do_fetch + Just rvar -> do + mb <- tryReadResult rvar + case mb of + Nothing -> return (CachedNotFetched rvar) + -- Use the cached result, even if it was an error. + Just r -> do + ifTrace flags 3 $ putStrLn $ case r of + Left _ -> "Cached error: " ++ show req + Right _ -> "Cached request: " ++ show req + return (Cached r) diff --git a/Haxl/Core/Monad.hs b/Haxl/Core/Monad.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Monad.hs @@ -0,0 +1,351 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The implementation of the 'Haxl' monad. +module Haxl.Core.Monad ( + -- * The monad + GenHaxl (..), runHaxl, + env, + + -- * Exceptions + throw, catch, try, tryToHaxlException, + + -- * Data fetching and caching + dataFetch, uncachedRequest, + cacheRequest, cacheResult, cachedComputation, + dumpCacheAsHaskell, + + -- * Unsafe operations + unsafeLiftIO, unsafeToHaxlException, + ) where + +import Haxl.Core.Types +import Haxl.Core.Fetch +import Haxl.Core.Env +import Haxl.Core.Exception +import Haxl.Core.RequestStore +import Haxl.Core.Util +import Haxl.Core.DataCache + +import qualified Data.Text as Text +import Control.Exception (Exception(..), SomeException) +import qualified Control.Exception +import Control.Applicative hiding (Const) +import GHC.Exts (IsString(..)) +#if __GLASGOW_HASKELL__ < 706 +import Prelude hiding (catch) +#endif +import Data.IORef +import Data.Monoid +import Text.Printf +import Text.PrettyPrint hiding ((<>)) +import Control.Arrow (left) + +-- ----------------------------------------------------------------------------- +-- | The Haxl monad, which does several things: +-- +-- * It is a reader monad for 'Env' and 'IORef' 'RequestStore', The +-- latter is the current batch of unsubmitted data fetch requests. +-- +-- * It is a concurrency, or resumption, monad. A computation may run +-- partially and return 'Blocked', in which case the framework should +-- perform the outstanding requests in the 'RequestStore', and then +-- resume the computation. +-- +-- * The Applicative combinator '<*>' explores /both/ branches in the +-- event that the left branch is 'Blocked', so that we can collect +-- multiple requests and submit them as a batch. +-- +-- * It contains IO, so that we can perform real data fetching. +-- +newtype GenHaxl u a = GenHaxl + { unHaxl :: Env u -> IORef (RequestStore u) -> IO (Result u a) } + +-- | The result of a computation is either 'Done' with a value, 'Throw' +-- with an exception, or 'Blocked' on the result of a data fetch with +-- a continuation. +data Result u a + = Done a + | Throw SomeException + | Blocked (GenHaxl u a) + +instance (Show a) => Show (Result u a) where + show (Done a) = printf "Done(%s)" $ show a + show (Throw e) = printf "Throw(%s)" $ show e + show Blocked{} = "Blocked" + +instance Monad (GenHaxl u) where + return a = GenHaxl $ \_env _ref -> return (Done a) + GenHaxl m >>= k = GenHaxl $ \env ref -> do + e <- m env ref + case e of + Done a -> unHaxl (k a) env ref + Throw e -> return (Throw e) + Blocked cont -> return (Blocked (cont >>= k)) + +instance Functor (GenHaxl u) where + fmap f m = pure f <*> m + +instance Applicative (GenHaxl u) where + pure = return + GenHaxl f <*> GenHaxl a = GenHaxl $ \env ref -> do + r <- f env ref + case r of + Throw e -> return (Throw e) + Done f' -> do + ra <- a env ref + case ra of + Done a' -> return (Done (f' a')) + Throw e -> return (Throw e) + Blocked a' -> return (Blocked (f' <$> a')) + Blocked f' -> do + ra <- a env ref -- left is blocked, explore the right + case ra of + Done a' -> return (Blocked (f' <*> return a')) + Throw e -> return (Blocked (f' <*> throw e)) + Blocked a' -> return (Blocked (f' <*> a')) + +-- | Runs a 'Haxl' computation in an 'Env'. +runHaxl :: Env u -> GenHaxl u a -> IO a +runHaxl env (GenHaxl haxl) = do + ref <- newIORef noRequests + e <- haxl env ref + case e of + Done a -> return a + Throw e -> Control.Exception.throw e + Blocked cont -> do + bs <- readIORef ref + performFetches env bs + runHaxl env cont + +-- | Extracts data from the 'Env'. +env :: (Env u -> a) -> GenHaxl u a +env f = GenHaxl $ \env _ref -> return (Done (f env)) + +-- ----------------------------------------------------------------------------- +-- Exceptions + +-- | Throw an exception in the Haxl monad +throw :: (Exception e) => e -> GenHaxl u a +throw e = GenHaxl $ \_env _ref -> raise e + +raise :: (Exception e) => e -> IO (Result u a) +raise = return . Throw . toException + +catch :: Exception e => GenHaxl u a -> (e -> GenHaxl u a) -> GenHaxl u a +catch (GenHaxl m) h = GenHaxl $ \env ref -> do + r <- m env ref + case r of + Done a -> return (Done a) + Throw e | Just e' <- fromException e -> unHaxl (h e') env ref + | otherwise -> return (Throw e) + Blocked k -> return (Blocked (catch k h)) + +try :: Exception e => GenHaxl u a -> GenHaxl u (Either e a) +try haxl = (Right <$> haxl) `catch` (return . Left) + +-- ----------------------------------------------------------------------------- +-- Unsafe operations + +-- | Under ordinary circumstances this is unnecessary; users of the Haxl +-- monad should generally /not/ perform arbitrary IO. +unsafeLiftIO :: IO a -> GenHaxl u a +unsafeLiftIO m = GenHaxl $ \_env _ref -> Done <$> m + +-- | Convert exceptions in the underlying IO monad to exceptions in +-- the Haxl monad. This is morally unsafe, because you could then +-- catch those exceptions in Haxl and observe the underlying execution +-- order. Not to be exposed to user code. +unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a +unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env ref -> do + r <- m env ref `Control.Exception.catch` \e -> return (Throw e) + case r of + Blocked c -> return (Blocked (unsafeToHaxlException c)) + other -> return other + +-- | Like 'try', but lifts all exceptions into the 'HaxlException' +-- hierarchy. Uses 'unsafeToHaxlException' internally. Typically +-- this is used at the top level of a Haxl computation, to ensure that +-- all exceptions are caught. +tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a) +tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h) + +-- ----------------------------------------------------------------------------- +-- Data fetching and caching + +-- | Performs actual fetching of data for a 'Request' from a 'DataSource'. +dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a +dataFetch req = GenHaxl $ \env ref -> do + -- First, check the cache + res <- cached env req + case res of + -- Not seen before: add the request to the RequestStore, so it + -- will be fetched in the next round. + Uncached rvar -> do + modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs + return $ Blocked (continueFetch req rvar) + + -- Seen before but not fetched yet. We're blocked, but we don't have + -- to add the request to the RequestStore. + CachedNotFetched rvar -> return + $ Blocked (continueFetch req rvar) + + -- Cached: either a result, or an exception + Cached (Left ex) -> return (Throw ex) + Cached (Right a) -> return (Done a) + +-- | A data request that is not cached. This is not what you want for +-- normal read requests, because then multiple identical requests may +-- return different results, and this invalidates some of the +-- properties that we expect Haxl computations to respect: that data +-- fetches can be aribtrarily reordered, and identical requests can be +-- commoned up, for example. +-- +-- 'uncachedRequest' is useful for performing writes, provided those +-- are done in a safe way - that is, not mixed with reads that might +-- conflict in the same Haxl computation. +-- +uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u a +uncachedRequest req = GenHaxl $ \_env ref -> do + rvar <- newEmptyResult + modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs + return $ Blocked (continueFetch req rvar) + +continueFetch + :: (DataSource u r, Request r a, Show a) + => r a -> ResultVar a -> GenHaxl u a +continueFetch req rvar = GenHaxl $ \_env _ref -> do + m <- tryReadResult rvar + case m of + Nothing -> raise . DataSourceError $ + textShow req <> " did not set contents of result var" + Just (Left e) -> return (Throw e) + Just (Right a) -> return (Done a) + +-- | Transparently provides caching. Useful for datasources that can +-- return immediately, but also caches values. +cacheResult :: (Request r a) => r a -> IO a -> GenHaxl u a +cacheResult req val = GenHaxl $ \env _ref -> do + cachedResult <- cached env req + case cachedResult of + Uncached rvar -> do + result <- Control.Exception.try val + putResult rvar result + done result + Cached result -> done result + CachedNotFetched _ -> corruptCache + where + corruptCache = raise . DataSourceError $ Text.concat + [ textShow req + , " has a corrupted cache value: these requests are meant to" + , " return immediately without an intermediate value. Either" + , " the cache was updated incorrectly, or you're calling" + , " cacheResult on a query that involves a blocking fetch." + ] + +-- | Inserts a request/result pair into the cache. Throws an exception +-- if the request has already been issued, either via 'dataFetch' or +-- 'cacheRequest'. +-- +-- This can be used to pre-populate the cache when running tests, to +-- avoid going to the actual data source and ensure that results are +-- deterministic. +-- +cacheRequest + :: (Request req a) => req a -> Either SomeException a -> GenHaxl u () +cacheRequest request result = GenHaxl $ \env _ref -> do + res <- cached env request + case res of + Uncached rvar -> do + -- request was not in the cache: insert the result and continue + putResult rvar result + return $ Done () + + -- It is an error if the request is already in the cache. We can't test + -- whether the cached result is the same without adding an Eq constraint, + -- and we don't necessarily have Eq for all results. + _other -> raise $ + DataSourceError "cacheRequest: request is already in the cache" + +instance IsString a => IsString (GenHaxl u a) where + fromString s = return (fromString s) + +-- | 'cachedComputation' memoizes a Haxl computation. The key is a +-- request. +-- +-- /Note:/ These cached computations will /not/ be included in the output +-- of 'dumpCacheAsHaskell'. +-- +cachedComputation + :: forall req u a. (Request req a) + => req a -> GenHaxl u a -> GenHaxl u a +cachedComputation req haxl = GenHaxl $ \env ref -> do + res <- memoized env req + case res of + -- Uncached: we must compute the result and store it in the ResultVar. + Uncached rvar -> do + let + with_result :: Either SomeException a -> GenHaxl u a + with_result r = GenHaxl $ \_ _ -> do putResult rvar r; done r + + unHaxl (try haxl >>= with_result) env ref + + -- CachedNotFetched: this request is already being computed, we just + -- have to block until the result is available. Note that we might + -- have to block repeatedly, because the Haxl computation might block + -- multiple times before it has a result. + CachedNotFetched rvar -> return $ Blocked (continueCached rvar) + Cached r -> done r + +continueCached :: ResultVar a -> GenHaxl u a +continueCached rvar = GenHaxl $ \_env _ref -> do + m <- tryReadResult rvar + case m of + -- Unlike dataFetch, Nothing is not an error here: the computation + -- is being worked on elsewhere and probably got blocked in a + -- datafetch, we just have to keep waiting for the result. + Nothing -> return $ Blocked (continueCached rvar) + Just r -> done r + +-- | Lifts an 'Either' into either 'Throw' or 'Done'. +done :: Either SomeException a -> IO (Result u a) +done = return . either Throw Done + +-- | Dump the contents of the cache as Haskell code that, when +-- compiled and run, will recreate the same cache contents. For +-- example, the generated code looks something like this: +-- +-- > loadCache :: GenHaxl u () +-- > loadCache = do +-- > cacheRequest (ListWombats 3) (Right ([1,2,3])) +-- > cacheRequest (CountAardvarks "abcabc") (Right (2)) +-- +dumpCacheAsHaskell :: GenHaxl u String +dumpCacheAsHaskell = do + ref <- env cacheRef -- NB. cacheRef, not memoRef. We ignore memoized + -- results when dumping the cache. + entries <- unsafeLiftIO $ readIORef ref >>= showCache + let + mk_cr (req, res) = + text "cacheRequest" <+> parens (text req) <+> parens (result res) + result (Left e) = text "except" <+> parens (text (show e)) + result (Right s) = text "Right" <+> parens (text s) + + return $ show $ + text "loadCache :: GenHaxl u ()" $$ + text "loadCache = do" $$ + nest 2 (vcat (map mk_cr (concatMap snd entries))) $$ + text "" -- final newline diff --git a/Haxl/Core/RequestStore.hs b/Haxl/Core/RequestStore.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/RequestStore.hs @@ -0,0 +1,70 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Bucketing requests by 'DataSource'. +-- +-- When a request is issued by the client via 'dataFetch', it is placed +-- in the 'RequestStore'. When we are ready to fetch the current batch +-- of requests, the 'contents' operation extracts the fetches, bucketed +-- by 'DataSource'. +-- +module Haxl.Core.RequestStore ( + BlockedFetches(..), RequestStore, + noRequests, addRequest, contents + ) where + +import Haxl.Core.Types +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Typeable +import Unsafe.Coerce + +-- | A container for multiple 'BlockedFetch' objects. +newtype RequestStore u = RequestStore (Map TypeRep (BlockedFetches u)) + -- Since we don't know which data sources we will be using, the store + -- is dynamically-typed. It maps the TypeRep of the request to the + -- 'BlockedFetches' for that 'DataSource'. + +-- | A batch of 'BlockedFetch' objects for a single 'DataSource' +data BlockedFetches u = + forall r. (DataSource u r) => BlockedFetches [BlockedFetch r] + +-- | A new empty 'RequestStore'. +noRequests :: RequestStore u +noRequests = RequestStore Map.empty + +-- | Adds a 'BlockedFetch' to a 'RequestStore'. +addRequest + :: forall u r. (DataSource u r) + => BlockedFetch r -> RequestStore u -> RequestStore u +addRequest bf (RequestStore m) = + RequestStore $ Map.insertWith combine ty (BlockedFetches [bf]) m + where + combine :: BlockedFetches u -> BlockedFetches u -> BlockedFetches u + combine _ (BlockedFetches bfs) + | typeOf1 (getR bfs) == ty = BlockedFetches (unsafeCoerce bf:bfs) + | otherwise = error "RequestStore.insert" + -- the dynamic type check here should be unnecessary, but if + -- there are bugs in `Typeable` or `Map` then we'll get an + -- error instead of a crash. The overhead is negligible. + + -- a type conversion only, so we can get the type of the reqeusts from + -- the list of BlockedFetch. + getR :: [BlockedFetch r1] -> r1 a + getR _ = undefined + + -- The TypeRep of requests for this data source + ty :: TypeRep + ty = typeOf1 (undefined :: r a) + +-- | Retrieves the whole contents of the 'RequestStore'. +contents :: RequestStore u -> [BlockedFetches u] +contents (RequestStore m) = Map.elems m diff --git a/Haxl/Core/Show1.hs b/Haxl/Core/Show1.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Show1.hs @@ -0,0 +1,15 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +module Haxl.Core.Show1 + ( Show1(..) + ) where + +-- | A class of type constructors for which we can show all +-- parameterizations. +class Show1 f where + show1 :: f a -> String diff --git a/Haxl/Core/StateStore.hs b/Haxl/Core/StateStore.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/StateStore.hs @@ -0,0 +1,67 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} + +module Haxl.Core.StateStore ( + StateKey(..), StateStore, stateGet, stateSet, stateEmpty + ) where + +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Typeable +import Unsafe.Coerce + +-- | 'StateKey' maps one type to another type. A type that is an +-- instance of 'StateKey' can store and retrieve information from a +-- 'StateStore'. +-- +#if __GLASGOW_HASKELL__ >= 708 +class Typeable f => StateKey (f :: * -> *) where + data State f +#else +class Typeable1 f => StateKey (f :: * -> *) where + data State f +#endif + +-- | The 'StateStore' maps a 'StateKey' to the 'State' for that type. +newtype StateStore = StateStore (Map TypeRep StateStoreData) + +-- | Encapsulates the type of 'StateStore' data so we can have a +-- heterogeneous collection. +data StateStoreData = forall f. StateKey f => StateStoreData (State f) + +-- | A `StateStore` with no entries. +stateEmpty :: StateStore +stateEmpty = StateStore Map.empty + +-- | Inserts a `State` in the `StateStore` container. +stateSet :: forall f . StateKey f => State f -> StateStore -> StateStore +stateSet st (StateStore m) = + StateStore (Map.insert (getType st) (StateStoreData st) m) + +-- | Retrieves a `State` from the `StateStore` container. +stateGet :: forall r . StateKey r => StateStore -> Maybe (State r) +stateGet (StateStore m) = + case Map.lookup ty m of + Nothing -> Nothing + Just (StateStoreData st) + | getType st == ty -> Just (unsafeCoerce st) + | otherwise -> Nothing + -- the dynamic type check here should be unnecessary, but if + -- there are bugs in `Typeable` or `Map` then we'll get an + -- error instead of a crash. The overhead is a few percent. + where + ty = getType (undefined :: State r) + +-- | Returns the 'TypeRep' associated with a particular 'State'. +getType :: forall f . StateKey f => State f -> TypeRep +getType _ = typeOf1 (undefined :: f a) diff --git a/Haxl/Core/Types.hs b/Haxl/Core/Types.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Types.hs @@ -0,0 +1,363 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Base types used by all of Haxl. +module Haxl.Core.Types ( + + -- * Initialization strategies + InitStrategy(..), + + -- * Tracing flags + Flags(..), + defaultFlags, + ifTrace, + + -- * Statistics + Stats(..), + RoundStats(..), + emptyStats, + numRounds, + numFetches, + + -- * Data fetching + DataSource(..), + DataSourceName(..), + Request, + BlockedFetch(..), + PerformFetch(..), + + -- * Result variables + ResultVar(..), + newEmptyResult, + newResult, + putFailure, + putResult, + putSuccess, + takeResult, + tryReadResult, + tryTakeResult, + + -- * Default fetch implementations + asyncFetch, asyncFetchWithDispatch, + stubFetch, + syncFetch, + + -- * Utilities + except, + setError, + + ) where + +import Control.Applicative +import Control.Exception +import Data.Typeable +import Data.Text (Text) +import Data.Aeson +import Data.Hashable +import Control.Concurrent.MVar +import Control.Monad +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (HashMap) + +#if __GLASGOW_HASKELL__ < 708 +import Haxl.Core.Util (tryReadMVar) +#endif +import Haxl.Core.Show1 +import Haxl.Core.StateStore + +-- | Initialization strategy. 'FullInit' will do as much initialization as +-- possible. 'FastInit' will postpone part of initialization or omit part of +-- initialization by sharing more resources. Use 'FastInit' if you want +-- fast initialization but don't care much about performance, for example, in +-- interactive environment. +data InitStrategy + = FullInit + | FastInit + deriving (Enum, Eq, Show) + +-- | Flags that control the operation of the engine. +data Flags = Flags + { trace :: Int + -- ^ Tracing level (0 = quiet, 3 = very verbose). + } + +defaultFlags :: Flags +defaultFlags = Flags { trace = 0 } + +-- | Runs an action if the tracing level is above the given threshold. +ifTrace :: (Functor m, Monad m) => Flags -> Int -> m a -> m () +ifTrace flags i m + | trace flags >= i = void m + | otherwise = return () + +-- | Stats that we collect along the way. +newtype Stats = Stats [RoundStats] + deriving ToJSON + +-- | Maps data source name to the number of requests made in that round. +-- The map only contains entries for sources that made requests in that +-- round. +newtype RoundStats = RoundStats (HashMap Text Int) + deriving ToJSON + +fetchesInRound :: RoundStats -> Int +fetchesInRound (RoundStats hm) = sum $ HashMap.elems hm + +emptyStats :: Stats +emptyStats = Stats [] + +numRounds :: Stats -> Int +numRounds (Stats rs) = length rs + +numFetches :: Stats -> Int +numFetches (Stats rs) = sum (map fetchesInRound rs) + +-- | The class of data sources, parameterised over the request type for +-- that data source. Every data source must implement this class. +-- +-- A data source keeps track of its state by creating an instance of +-- 'StateKey' to map the request type to its state. In this case, the +-- type of the state should probably be a reference type of some kind, +-- such as 'IORef'. +-- +-- For a complete example data source, see +-- . +-- +class (DataSourceName req, StateKey req, Show1 req) => DataSource u req where + + -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch' + -- objects contain both the request and the 'MVar's into which to put + -- the results. + fetch + :: State req + -- ^ Current state. + -> Flags + -- ^ Tracing flags. + -> u + -- ^ User environment. + -> [BlockedFetch req] + -- ^ Requests to fetch. + -> PerformFetch + -- ^ Fetch the data; see 'PerformFetch'. + +class DataSourceName req where + -- | The name of this 'DataSource', used in tracing and stats. Must + -- take a dummy request. + dataSourceName :: req a -> Text + +-- The 'Show1' class is a workaround for the fact that we can't write +-- @'Show' (req a)@ as a superclass of 'DataSource', without also +-- parameterizing 'DataSource' over @a@, which is a pain (I tried +-- it). 'Show1' seems fairly benign, though. + +-- | A convenience only: package up 'Eq', 'Hashable', 'Typeable', and 'Show' +-- for requests into a single constraint. +type Request req a = + ( Eq (req a) + , Hashable (req a) + , Typeable (req a) + , Show (req a) + , Show a + ) + +-- | A data source can fetch data in one of two ways. +-- +-- * Synchronously ('SyncFetch'): the fetching operation is an +-- @'IO' ()@ that fetches all the data and then returns. +-- +-- * Asynchronously ('AsyncFetch'): we can do something else while the +-- data is being fetched. The fetching operation takes an @'IO' ()@ as +-- an argument, which is the operation to perform while the data is +-- being fetched. +-- +-- See 'syncFetch' and 'asyncFetch' for example usage. +-- +data PerformFetch + = SyncFetch (IO ()) + | AsyncFetch (IO () -> IO ()) + +-- | A 'BlockedFetch' is a pair of +-- +-- * The request to fetch (with result type @a@) +-- +-- * An 'MVar' to store either the result or an error +-- +-- We often want to collect together multiple requests, but they return +-- different types, and the type system wouldn't let us put them +-- together in a list because all the elements of the list must have the +-- same type. So we wrap up these types inside the 'BlockedFetch' type, +-- so that they all look the same and we can put them in a list. +-- +-- When we unpack the 'BlockedFetch' and get the request and the 'MVar' +-- out, the type system knows that the result type of the request +-- matches the type parameter of the 'MVar', so it will let us take the +-- result of the request and store it in the 'MVar'. +-- +data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a) + +-- | Function for easily setting a fetch to a particular exception +setError :: (Exception e) => (forall a. r a -> e) -> BlockedFetch r -> IO () +setError e (BlockedFetch req m) = putFailure m (e req) + +except :: (Exception e) => e -> Either SomeException a +except = Left . toException + +-- | A sink for the result of a data fetch, used by 'BlockedFetch' and the +-- 'DataCache'. Why do we need an 'MVar' here? The reason is that the cache +-- serves two purposes: +-- +-- 1. To cache the results of requests that were submitted in a previous round. +-- +-- 2. To remember requests that have been encountered in the current round but +-- are not yet submitted, so that if we see the request again we can make +-- sure that we only submit it once. +-- +-- Storing the result as an 'MVar' gives two benefits: +-- +-- * We can tell the difference between (1) and (2) by testing whether the +-- 'MVar' is empty. See 'Haxl.Fetch.cached'. +-- +-- * In the case of (2), we don't have to update the cache again after the +-- current round, and after the round we can read the result of each request +-- from its 'MVar'. All instances of identical requests will share the same +-- 'MVar' to obtain the result. +-- +newtype ResultVar a = ResultVar (MVar (Either SomeException a)) + +newResult :: a -> IO (ResultVar a) +newResult x = ResultVar <$> newMVar (Right x) + +newEmptyResult :: IO (ResultVar a) +newEmptyResult = ResultVar <$> newEmptyMVar + +putFailure :: (Exception e) => ResultVar a -> e -> IO () +putFailure r = putResult r . except + +putSuccess :: ResultVar a -> a -> IO () +putSuccess r = putResult r . Right + +putResult :: ResultVar a -> Either SomeException a -> IO () +putResult (ResultVar var) = putMVar var + +takeResult :: ResultVar a -> IO (Either SomeException a) +takeResult (ResultVar var) = takeMVar var + +tryReadResult :: ResultVar a -> IO (Maybe (Either SomeException a)) +tryReadResult (ResultVar var) = tryReadMVar var + +tryTakeResult :: ResultVar a -> IO (Maybe (Either SomeException a)) +tryTakeResult (ResultVar var) = tryTakeMVar var + +-- Fetch templates + +stubFetch + :: (Exception e) => (forall a. r a -> e) + -> State r -> Flags -> u -> [BlockedFetch r] -> PerformFetch +stubFetch e _state _flags _si bfs = SyncFetch $ mapM_ (setError e) bfs + +-- | Common implementation templates for 'fetch' of 'DataSource'. +-- +-- Example usage: +-- +-- > fetch = syncFetch MyDS.withService MyDS.retrieve +-- > $ \service request -> case request of +-- > This x -> MyDS.fetchThis service x +-- > That y -> MyDS.fetchThat service y +-- +asyncFetchWithDispatch + :: ((service -> IO ()) -> IO ()) + -- ^ Wrapper to perform an action in the context of a service. + + -> (service -> IO ()) + -- ^ Dispatch all the pending requests + + -> (service -> IO ()) + -- ^ Wait for the results + + -> (forall a. service -> request a -> IO (IO (Either SomeException a))) + -- ^ Enqueue an individual request to the service. + + -> State request + -- ^ Currently unused. + + -> Flags + -- ^ Currently unused. + + -> u + -- ^ Currently unused. + + -> [BlockedFetch request] + -- ^ Requests to submit. + + -> PerformFetch + +asyncFetch, syncFetch + :: ((service -> IO ()) -> IO ()) + -- ^ Wrapper to perform an action in the context of a service. + + -> (service -> IO ()) + -- ^ Dispatch all the pending requests and wait for the results + + -> (forall a. service -> request a -> IO (IO (Either SomeException a))) + -- ^ Submits an individual request to the service. + + -> State request + -- ^ Currently unused. + + -> Flags + -- ^ Currently unused. + + -> u + -- ^ Currently unused. + + -> [BlockedFetch request] + -- ^ Requests to submit. + + -> PerformFetch + +asyncFetchWithDispatch + withService dispatch wait enqueue _state _flags _si requests = + AsyncFetch $ \inner -> withService $ \service -> do + getResults <- mapM (submitFetch service enqueue) requests + dispatch service + inner + wait service + sequence_ getResults + +asyncFetch withService wait enqueue _state _flags _si requests = + AsyncFetch $ \inner -> withService $ \service -> do + getResults <- mapM (submitFetch service enqueue) requests + inner + wait service + sequence_ getResults + +syncFetch withService dispatch enqueue _state _flags _si requests = + SyncFetch . withService $ \service -> do + getResults <- mapM (submitFetch service enqueue) requests + dispatch service + sequence_ getResults + +-- | Used by 'asyncFetch' and 'syncFetch' to retrieve the results of +-- requests to a service. +submitFetch + :: service + -> (forall a. service -> request a -> IO (IO (Either SomeException a))) + -> BlockedFetch request + -> IO (IO ()) +submitFetch service fetch (BlockedFetch request result) + = (putResult result =<<) <$> fetch service request diff --git a/Haxl/Core/Util.hs b/Haxl/Core/Util.hs new file mode 100644 --- /dev/null +++ b/Haxl/Core/Util.hs @@ -0,0 +1,40 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE CPP #-} + +module Haxl.Core.Util + ( compose + , textShow + , tryReadMVar + ) where + +#if __GLASGOW_HASKELL__ >= 708 +import Control.Concurrent (tryReadMVar) +#else +import Control.Concurrent +#endif + +import Data.Text (Text) + +import qualified Data.Text as Text + +-- | Composes a list of endofunctions. +compose :: [a -> a] -> a -> a +compose = foldr (.) id + +#if __GLASGOW_HASKELL__ < 708 +tryReadMVar :: MVar a -> IO (Maybe a) +tryReadMVar m = do + mb <- tryTakeMVar m + case mb of + Nothing -> return Nothing + Just a -> putMVar m a >> return (Just a) +#endif + +textShow :: (Show a) => a -> Text +textShow = Text.pack . show diff --git a/Haxl/Prelude.hs b/Haxl/Prelude.hs new file mode 100644 --- /dev/null +++ b/Haxl/Prelude.hs @@ -0,0 +1,210 @@ +-- Copyright (c) 2014, Facebook, Inc. +-- All rights reserved. +-- +-- This source code is distributed under the terms of a BSD license, +-- found in the LICENSE file. An additional grant of patent rights can +-- be found in the PATENTS file. + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Support for using Haxl as a DSL. This module provides most of +-- the standard Prelude, plus a selection of stuff that makes it +-- Haxl client code cleaner and more concise. +-- +-- We intend Haxl client code to: +-- +-- * Import @Haxl.Prelude@ +-- +-- * Use @RebindableSyntax@. This implies @NoImplicitPrelude@, and +-- allows @if@-@then@-@else@ to be used with a monadic condition. +-- +-- * Use @OverloadedStrings@ (we use @Text@ a lot) +-- +module Haxl.Prelude ( + -- * The Standard Haskell Prelude + -- | Everything from "Prelude" except 'mapM', 'mapM_', + -- 'sequence', and 'sequence' + module Prelude, + + -- * Haxl and Fetching data + GenHaxl, dataFetch, DataSource, + + -- * Extra Monad and Applicative things + Applicative(..), + mapM, mapM_, sequence, sequence_, (<$>), filterM, foldM, + forM, forM_, + foldl', sort, + Monoid(..), + join, + + -- * Lifted operations + IfThenElse(..), + (.>), (.<), (.>=), (.<=), + (.==), (./=), (.&&), (.||), + (.++), + pair, + + -- * Text things + Text, + IsString(..), + + -- * Exceptions + throw, catch, try, withDefault, catchAny, + HaxlException(..), TransientError(..), LogicError(..), + NotFound(..), UnexpectedType(..), FetchError(..), + EmptyList(..), InvalidParameter(..) + + ) where + +import Haxl.Core.Types +import Haxl.Core.Exception +import Haxl.Core.Monad + +import Control.Applicative +import Control.Monad (foldM, join) +import Data.List (foldl', sort) +import Data.Text (Text) +import Data.Traversable hiding (forM, mapM, sequence) +import GHC.Exts (IsString(..)) +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Monoid +import Data.Maybe +import Control.Exception (fromException) + +infixr 3 .&& +infixr 2 .|| +infix 4 .>, .<, .>=, .<=, .==, ./= + +-- ----------------------------------------------------------------------------- +-- Haxl versions of Haskell Prelude stuff + +-- Using overloading and RebindableSyntax to hide the monad as far as +-- possible. + +class IfThenElse a b where + ifThenElse :: a -> b -> b -> b + +instance IfThenElse Bool a where + ifThenElse b t e = case b of True -> t; False -> e + +-- The equality constraint is necessary to convince the typechecker that +-- this is valid: +-- +-- > if getCountry ip .== "us" then ... else ... +-- +instance (u1 ~ u2) => IfThenElse (GenHaxl u1 Bool) (GenHaxl u2 a) where + ifThenElse fb t e = do + b <- fb + if b then t else e + +instance Num a => Num (GenHaxl u a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + fromInteger = pure . fromInteger + abs = liftA abs + signum = liftA signum + negate = liftA negate + +instance Fractional a => Fractional (GenHaxl u a) where + (/) = liftA2 (/) + recip = liftA recip + fromRational = return . fromRational + +-- ----------------------------------------------------------------------------- +-- Convenience functions for avoiding do-notation boilerplate + +-- convention is to prefix the name with a '.'. We could change this, +-- or even just not provide these at all. + +(.>) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool +(.>) = liftA2 (Prelude.>) + +(.<) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool +(.<) = liftA2 (Prelude.<) + +(.>=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool +(.>=) = liftA2 (Prelude.>=) + +(.<=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool +(.<=) = liftA2 (Prelude.<=) + +(.==) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool +(.==) = liftA2 (Prelude.==) + +(./=) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool +(./=) = liftA2 (Prelude./=) + +(.++) :: GenHaxl u [a] -> GenHaxl u [a] -> GenHaxl u [a] +(.++) = liftA2 (Prelude.++) + +-- short-circuiting Bool operations +(.&&):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool +fa .&& fb = do a <- fa; if a then fb else return False + +(.||):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool +fa .|| fb = do a <- fa; if a then return True else fb + +pair :: GenHaxl u a -> GenHaxl u b -> GenHaxl u (a, b) +pair = liftA2 (,) + +-- ----------------------------------------------------------------------------- +-- Applicative traversals + +-- | We don't want the monadic 'mapM', because that doesn't do batching. +-- There doesn't seem to be a way to make 'Data.Traversable.mapM' have +-- the right behaviour when used with Haxl, so instead we define 'mapM' +-- to be 'traverse' in Haxl code. +mapM :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) +mapM = traverse + +forM :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) +forM = flip mapM + +-- | See 'mapM'. +mapM_ :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f () +mapM_ f t = const () <$> traverse f t + +forM_ :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f () +forM_ = flip mapM_ + +-- | See 'mapM'. +sequence :: (Traversable t, Applicative f) => t (f a) -> f (t a) +sequence = sequenceA + +-- | See 'mapM'. +sequence_ :: (Traversable t, Applicative f) => t (f a) -> f () +sequence_ t = const () <$> sequenceA t + +-- | See 'mapM'. +filterM :: (Applicative f, Monad f) => (a -> f Bool) -> [a] -> f [a] +filterM pred xs = do + bools <- mapM pred xs + return [ x | (x,True) <- zip xs bools ] + +-------------------------------------------------------------------------------- + +-- | Runs the given 'GenHaxl' computation, and if it throws a +-- 'TransientError' or 'LogicError' exception (see +-- "Haxl.Core.Exception"), the exception is ignored and the supplied +-- default value is returned instead. +withDefault :: a -> GenHaxl u a -> GenHaxl u a +withDefault d a = catchAny a (return d) + +-- | Catch 'LogicError's and 'TransientError's and perform an alternative action +catchAny + :: GenHaxl u a -- ^ run this first + -> GenHaxl u a -- ^ if it throws 'LogicError' or 'TransientError', run this + -> GenHaxl u a +catchAny haxl handler = + haxl `catch` \e -> + if isJust (fromException e :: Maybe LogicError) || + isJust (fromException e :: Maybe TransientError) + then + handler + else + throw e diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014, Facebook, Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + 3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/PATENTS b/PATENTS new file mode 100644 --- /dev/null +++ b/PATENTS @@ -0,0 +1,23 @@ +Additional Grant of Patent Rights + +"Software" means the Haxl software distributed by Facebook, Inc. + +Facebook hereby grants you a perpetual, worldwide, royalty-free, non-exclusive, +irrevocable (subject to the termination provision below) license under any +rights in any patent claims owned by Facebook, to make, have made, use, sell, +offer to sell, import, and otherwise transfer the Software. For avoidance of +doubt, no license is granted under Facebook's rights in any patent claims that +are infringed by (i) modifications to the Software made by you or a third party, +or (ii) the Software in combination with any software or other technology +provided by you or a third party. + +The license granted hereunder will terminate, automatically and without notice, +for anyone that makes any claim (including by filing any lawsuit, assertion or +other action) alleging (a) direct, indirect, or contributory infringement or +inducement to infringe any patent: (i) by Facebook or any of its subsidiaries or +affiliates, whether or not such claim is related to the Software, (ii) by any +party if such claim arises in whole or in part from any software, product or +service of Facebook or any of its subsidiaries or affiliates, whether or not +such claim is related to the Software, or (iii) by any party relating to the +Software; or (b) that any right in any patent claim of Facebook is invalid or +unenforceable. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haxl.cabal b/haxl.cabal new file mode 100644 --- /dev/null +++ b/haxl.cabal @@ -0,0 +1,101 @@ +name: haxl +version: 0.1.0.0 +synopsis: A Haskell library for efficient, concurrent, + and concise data access. +homepage: https://github.com/facebook/Haxl +bug-reports: https://github.com/facebook/Haxl/issues +license: BSD3 +license-file: LICENSE +author: Facebook, Inc. +maintainer: The Haxl Team +copyright: 2014 (C) 2014 Facebook, Inc. +category: Concurrency +build-type: Simple +stability: alpha +cabal-version: >= 1.10 + +description: + Haxl is a library and EDSL for efficient scheduling of concurrent data + accesses with a concise applicative API. + +extra-source-files: + readme.md + PATENTS + tests/LoadCache.txt + +library + + build-depends: + HUnit == 1.2.*, + aeson >= 0.6 && <0.8, + base == 4.*, + bytestring >= 0.9 && <0.11, + containers == 0.5.*, + directory >= 1.1 && <1.3, + filepath == 1.3.*, + hashable == 1.2.*, + pretty == 1.1.*, + text == 1.1.*, + time == 1.4.*, + unordered-containers == 0.2.*, + vector == 0.10.* + + exposed-modules: + Haxl.Core, + Haxl.Core.DataCache, + Haxl.Core.Exception, + Haxl.Core.Env, + Haxl.Core.Fetch, + Haxl.Core.Monad, + Haxl.Core.RequestStore, + Haxl.Core.StateStore, + Haxl.Core.Show1, + Haxl.Core.Types, + Haxl.Prelude + + other-modules: + Haxl.Core.Util + + default-language: Haskell2010 + + ghc-options: + -Wall + -fno-warn-name-shadowing + + +test-suite test + + build-depends: + HUnit, + aeson, + base == 4.*, + bytestring, + containers, + hashable, + haxl, + text, + unordered-containers + + ghc-options: + -Wall + -fno-warn-name-shadowing + -fno-warn-missing-signatures + + hs-source-dirs: + tests + + main-is: + Main.hs + + other-modules: + BatchTests + CoreTests + DataCacheTest + ExampleDataSource + LoadCache + MockTAO + TestExampleDataSource + TestTypes + + type: + exitcode-stdio-1.0 diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,49 @@ +![Haxl Logo](http://github.com/facebook/Haxl/raw/master/logo.png) + +# Haxl + +Haxl is a Haskell library that simplifies access to remote data, such +as databases or web-based services. Haxl can automatically + + * batch multiple requests to the same data source, + * request data from multiple data sources concurrently, + * cache previous requests. + +Having all this handled for you behind the scenes means that your +data-fetching code can be much cleaner and clearer than it would +otherwise be if it had to worry about optimizing data-fetching. We'll +give some examples of how this works in the pages linked below. + +There are two Haskell packages here: + + * `haxl`: The core Haxl framework + * `haxl-facebook` (in [example/facebook](example/facebook)): An (incomplete) example data source for accessing the Facebook Graph API + +To use Haxl in your own application, you will likely need to build one or more +*data sources*: the thin layer between Haxl and the data that you want +to fetch, be it a database, a web API, a cloud service, or whatever. +The `haxl-facebook` package shows how we might build a Haxl data +source based on the existing `fb` package for talking to the Facebook +Graph API. + +## Where to go next? + + * *The Story of Haxl* (a blog post to be published very soon!) + explains how Haxl came about at Facebook, and discusses our + particular use case. + + * [An example Facebook data source](example/facebook/readme.md) walks + through building an example data source that queries the Facebook + Graph API concurrently. + + * [The N+1 Selects Problem](example/sql/readme.md) explains how Haxl + can address a common performance problem with SQL queries by + automatically batching multiple queries into a single query, + completely invisibly to the programmer. + + * [Haxl Documentation](http://hackage.haskell.org/package/haxl) on + Hackage. + + * *There is no Fork: An Abstraction for Efficient, Concurrent, and + Concise Data Access*, our paper on Haxl, accepted for publication + at ICFP'14. Online version coming soon (June 12). diff --git a/tests/BatchTests.hs b/tests/BatchTests.hs new file mode 100644 --- /dev/null +++ b/tests/BatchTests.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE RebindableSyntax, OverloadedStrings #-} +module BatchTests (tests) where + +import TestTypes +import MockTAO + +import Control.Applicative +import Data.IORef +import Data.Aeson +import Test.HUnit +import qualified Data.HashMap.Strict as HashMap + +import Haxl.Core + +import Prelude() +import Haxl.Prelude + +-- ----------------------------------------------------------------------------- + +testinput :: Object +testinput = HashMap.fromList [ + "A" .= (1 :: Int), + "B" .= (2 :: Int), + "C" .= (3 :: Int), + "D" .= (4 :: Int) ] + +makeTestEnv :: IO (Env UserEnv) +makeTestEnv = do + tao <- MockTAO.initGlobalState + let st = stateSet tao stateEmpty + initEnv st testinput + +expectRoundsWithEnv + :: (Eq a, Show a) => Int -> a -> Haxl a -> Env UserEnv -> Assertion +expectRoundsWithEnv n result haxl env = do + a <- runHaxl env haxl + assertEqual "result" result a + stats <- readIORef (statsRef env) + assertEqual "rounds" n (numRounds stats) + +expectRounds :: (Eq a, Show a) => Int -> a -> Haxl a -> Assertion +expectRounds n result haxl = do + env <- makeTestEnv + expectRoundsWithEnv n result haxl env + +expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Assertion +expectFetches n haxl = do + env <- makeTestEnv + _ <- runHaxl env haxl + stats <- readIORef (statsRef env) + assertEqual "fetches" n (numFetches stats) + +friendsOf :: Id -> Haxl [Id] +friendsOf = assocRangeId2s friendsAssoc + +id1 :: Haxl Id +id1 = lookupInput "A" + +id2 :: Haxl Id +id2 = lookupInput "B" + +id3 :: Haxl Id +id3 = lookupInput "C" + +-- +-- Test batching over multiple arguments in liftA2 +-- +batching1 = expectRounds 1 12 batching1_ + +batching1_ = do + a <- id1 + b <- id2 + length <$> liftA2 (++) (friendsOf a) (friendsOf b) + +-- +-- Test batching in mapM (which is really traverse) +-- +batching2 = expectRounds 1 12 batching2_ + +batching2_ = do + a <- id1 + b <- id2 + fs <- mapM friendsOf [a,b] + return (sum (map length fs)) + +-- +-- Test batching when we have a monadic bind in each branch +-- +batching3 = expectRounds 1 12 batching3_ + +batching3_ = do + let a = id1 >>= friendsOf + b = id2 >>= friendsOf + length <$> a .++ b + +-- +-- Test batching over both arguments of (+) +-- +batching4 = expectRounds 1 12 batching4_ + +batching4_ = do + let a = length <$> (id1 >>= friendsOf) + b = length <$> (id2 >>= friendsOf) + a + b + +-- +-- Test batching over both arguments of (+) +-- +batching5 = expectRounds 1 2 batching5_ + +batching5_ :: Haxl Int +batching5_ = if a .> b then 1 else 2 + where + a = length <$> (id1 >>= friendsOf) + b = length <$> (id2 >>= friendsOf) + +-- +-- Test batching when we perform all batching tests together with sequence +-- +batching6 = expectRounds 1 [12,12,12,12,2] batching6_ + +batching6_ = sequence [batching1_,batching2_,batching3_,batching4_,batching5_] + +-- +-- Ensure if/then/else and bool operators break batching +-- +batching7 = expectRounds 2 12 batching7_ + +batching7_ :: Haxl Int +batching7_ = if a .> 0 then a+b else 0 + where + a = length <$> (id1 >>= friendsOf) + b = length <$> (id2 >>= friendsOf) + +-- We expect 3 rounds here due to boolean operators +batching8 = expectRounds 3 12 batching8_ + +batching8_ :: Haxl Int +batching8_ = if (c .== 0) .|| (a .> 0 .&& b .> 0) then a+b else 0 + where + a = length <$> (id1 >>= friendsOf) + b = length <$> (id2 >>= friendsOf) + c = length <$> (id3 >>= friendsOf) + +-- +-- Test data caching, numFetches +-- + +-- simple (one cache hit) +caching1 = expectFetches 3 caching1_ +caching1_ = nf id1 + nf id2 + nf id3 + nf id3 + where + nf id = length <$> (id >>= friendsOf) + +-- simple, in rounds (no cache hits) +caching2 = expectFetches 3 caching2_ +caching2_ = if nf id1 .> 0 then nf id2 + nf id3 else 0 + where + nf id = length <$> (id >>= friendsOf) + +-- rounds (one cache hit) +caching3 = expectFetches 3 caching3_ +caching3_ = if nf id1 .> 0 then nf id1 + nf id2 + nf id3 else 0 + where + nf id = length <$> (id >>= friendsOf) + +-- +-- Basic sanity check on data-cache re-use +-- +cacheReuse = do + env <- makeTestEnv + expectRoundsWithEnv 2 12 batching7_ env + + -- make a new env + tao <- MockTAO.initGlobalState + let st = stateSet tao stateEmpty + env2 <- initEnvWithData st testinput (caches env) + + -- ensure no more data fetching rounds needed + expectRoundsWithEnv 0 12 batching7_ env2 + +tests = TestList + [ TestLabel "batching1" $ TestCase batching1 + , TestLabel "batching2" $ TestCase batching2 + , TestLabel "batching3" $ TestCase batching3 + , TestLabel "batching4" $ TestCase batching4 + , TestLabel "batching5" $ TestCase batching5 + , TestLabel "batching6" $ TestCase batching6 + , TestLabel "batching7" $ TestCase batching7 + , TestLabel "batching8" $ TestCase batching8 + , TestLabel "caching1" $ TestCase caching1 + , TestLabel "caching2" $ TestCase caching2 + , TestLabel "caching3" $ TestCase caching3 + , TestLabel "CacheReuse" $ TestCase cacheReuse + , TestLabel "exceptionTest1" $ TestCase exceptionTest1 + , TestLabel "exceptionTest2" $ TestCase exceptionTest2 + , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions + ] + +exceptionTest1 = expectRounds 1 [] + $ withDefault [] $ friendsOf 101 + +exceptionTest2 = expectRounds 1 [7..12] $ liftA2 (++) + (withDefault [] (friendsOf 101)) + (withDefault [] (friendsOf 2)) + +deterministicExceptions = do + env <- makeTestEnv + let haxl = + sequence [ do _ <- friendsOf =<< id1; throw (NotFound "xxx") + , throw (NotFound "yyy") + ] + -- the first time, friendsOf should block, but we should still get the + -- "xxx" exception. + r <- runHaxl env $ try haxl + assertBool "exceptionTest3" $ + case r of + Left (NotFound "xxx") -> True + _ -> False + -- the second time, friendsOf will be cached, and we should get the "xxx" + -- exception as before. + r <- runHaxl env $ try haxl + assertBool "exceptionTest3" $ + case r of + Left (NotFound "xxx") -> True + _ -> False diff --git a/tests/CoreTests.hs b/tests/CoreTests.hs new file mode 100644 --- /dev/null +++ b/tests/CoreTests.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE RebindableSyntax, OverloadedStrings #-} +module CoreTests where + +import Haxl.Prelude +import Prelude () + +import Haxl.Core + +import Test.HUnit + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BS + +import Control.Exception (Exception(..)) + +useless :: String -> GenHaxl u Bool +useless _ = throw (NotFound "ha ha") + +en = error "no env" + +exceptions :: Assertion +exceptions = + do + a <- runHaxl en $ try (useless "input") + assertBool "NotFound -> HaxlException" $ + isLeft (a :: Either HaxlException Bool) + + b <- runHaxl en $ try (useless "input") + assertBool "NotFound -> Logic Error" $ + isLeft (b :: Either LogicError Bool) + + c <- runHaxl en $ try (useless "input") + assertBool "NotFound -> NotFound" $ + isLeft (c :: Either NotFound Bool) + + -- Make sure TransientError -doesn't- catch our NotFound + d <- runHaxl en $ + (useless "input" + `catch` \TransientError{} -> return False) + `catch` \LogicError{} -> return True + assertBool "Transient != NotFound" d + + -- test catch + e <- runHaxl en $ + throw (NotFound "haha") `catch` \NotFound{} -> return True + assertBool "catch1" e + + f <- runHaxl en $ + throw (NotFound "haha") `catch` \LogicError{} -> return True + assertBool "catch2" f + where + isLeft Left{} = True + isLeft _ = False + +-- This is mostly a compile test, to make sure all the plumbing +-- makes the compiler happy. +base :: (Exception a) => a -> IO HaxlException +base e = runHaxl en $ throw e `catch` \x -> return x + +printing :: Assertion +printing = do + a <- base $ NotFound "notfound!" + print a + + b <- base $ CriticalError "ohthehumanity!" + print b + + c <- base $ FetchError "timeout!" + print c + + BS.putStrLn $ encode a + BS.putStrLn $ encode b + BS.putStrLn $ encode c + + +tests = TestList + [ TestLabel "exceptions" $ TestCase exceptions, + TestLabel "print_stuff" $ TestCase printing + ] diff --git a/tests/DataCacheTest.hs b/tests/DataCacheTest.hs new file mode 100644 --- /dev/null +++ b/tests/DataCacheTest.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-} +module DataCacheTest (tests) where + +import Haxl.Core.DataCache as DataCache +import Haxl.Core.Types + +import Control.Exception +import Data.Hashable +import Data.Traversable +import Data.Typeable +import Prelude hiding (mapM) +import Test.HUnit + +data TestReq a where + Req :: Int -> TestReq a -- polymorphic result + deriving Typeable + +deriving instance Eq (TestReq a) +deriving instance Show (TestReq a) + +instance Hashable (TestReq a) where + hashWithSalt salt (Req i) = hashWithSalt salt i + + +dcSoundnessTest :: Test +dcSoundnessTest = TestLabel "DataCache soundness" $ TestCase $ do + m1 <- newResult 1 + m2 <- newResult "hello" + let cache = + DataCache.insert (Req 1 :: TestReq Int) m1 $ + DataCache.insert (Req 2 :: TestReq String) m2 $ + DataCache.empty + + -- "Req 1" has a result of type Int, so if we try to look it up + -- with a result of type String, we should get Nothing, not a crash. + r <- mapM takeResult $ DataCache.lookup (Req 1) cache + assertBool "dcSoundness1" $ + case r :: Maybe (Either SomeException String) of + Nothing -> True + _something_else -> False + + r <- mapM takeResult $ DataCache.lookup (Req 1) cache + assertBool "dcSoundness2" $ + case r :: Maybe (Either SomeException Int) of + Just (Right 1) -> True + _something_else -> False + + r <- mapM takeResult $ DataCache.lookup (Req 2) cache + assertBool "dcSoundness3" $ + case r :: Maybe (Either SomeException String) of + Just (Right "hello") -> True + _something_else -> False + + r <- mapM takeResult $ DataCache.lookup (Req 2) cache + assertBool "dcSoundness4" $ + case r :: Maybe (Either SomeException Int) of + Nothing -> True + _something_else -> False + + +-- tests :: Assertion +tests = TestList [dcSoundnessTest] diff --git a/tests/ExampleDataSource.hs b/tests/ExampleDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleDataSource.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +module ExampleDataSource ( + -- * initialise the state + initGlobalState, + + -- * requests for this data source + ExampleReq(..), + countAardvarks, + listWombats, + ) where + +import Haxl.Prelude +import Prelude () + +import Haxl.Core + +import Data.Typeable +import Data.Hashable + +-- 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 (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable) + +instance Show Id where + show (Id i) = show i + +data ExampleReq a where + CountAardvarks :: String -> ExampleReq Int + ListWombats :: Id -> ExampleReq [Id] + deriving Typeable -- requests must be Typeable + +-- 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 instance Eq (ExampleReq a) + +deriving instance Show (ExampleReq a) + +instance Show1 ExampleReq where show1 = 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 + + +-- 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 :: IO (State ExampleReq) +initGlobalState = do + -- initialize the state here. + return 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 + -> [BlockedFetch ExampleReq] -- requests to fetch + -> PerformFetch -- tells the framework how to fetch + +exampleFetch _state _flags _user bfs = SyncFetch $ mapM_ fetch1 bfs + + -- 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 str) m) = + putSuccess m (length (filter (== 'a') str)) +fetch1 (BlockedFetch (ListWombats a) r) = + if a > 99 then putFailure r $ FetchError "too large" + else putSuccess r $ take (fromIntegral a) [1..] + + +-- Normally a data source will provide some convenient wrappers for +-- its requests: + +countAardvarks :: String -> GenHaxl () Int +countAardvarks str = dataFetch (CountAardvarks str) + +listWombats :: Id -> GenHaxl () [Id] +listWombats id = dataFetch (ListWombats id) diff --git a/tests/LoadCache.hs b/tests/LoadCache.hs new file mode 100644 --- /dev/null +++ b/tests/LoadCache.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +module LoadCache where + +import Haxl.Core +import ExampleDataSource + +#include "LoadCache.txt" diff --git a/tests/LoadCache.txt b/tests/LoadCache.txt new file mode 100644 --- /dev/null +++ b/tests/LoadCache.txt @@ -0,0 +1,5 @@ +loadCache :: GenHaxl u () +loadCache = do + cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy"))) + cacheRequest (CountAardvarks "xxx") (Right (3)) + cacheRequest (ListWombats 100) (Right ([1,2,3])) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE RebindableSyntax, OverloadedStrings #-} +module Main where + +import TestExampleDataSource +import BatchTests +import CoreTests +import DataCacheTest + +import Data.String +import Test.HUnit + +import Haxl.Prelude + +main :: IO Counts +main = runTestTT $ TestList + [ TestLabel "ExampleDataSource" TestExampleDataSource.tests + , TestLabel "BatchTests" BatchTests.tests + , TestLabel "CoreTests" CoreTests.tests + , TestLabel "DataCacheTests" DataCacheTest.tests + ] diff --git a/tests/MockTAO.hs b/tests/MockTAO.hs new file mode 100644 --- /dev/null +++ b/tests/MockTAO.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module MockTAO ( + Id(..), + initGlobalState, + assocRangeId2s, + friendsAssoc, + ) where + +import Data.Hashable +import Data.Map (Map) +import Data.Typeable +import Prelude () +import qualified Data.Map as Map +import qualified Data.Text as Text + +import Haxl.Prelude +import Haxl.Core + +import TestTypes + +-- ----------------------------------------------------------------------------- +-- Minimal mock TAO + +data TAOReq a where + AssocRangeId2s :: Id -> Id -> TAOReq [Id] + deriving Typeable + +deriving instance Show (TAOReq a) +deriving instance Eq (TAOReq a) + +instance Show1 TAOReq where show1 = show + +instance Hashable (TAOReq a) where + hashWithSalt s (AssocRangeId2s a b) = hashWithSalt s (a,b) + +instance StateKey TAOReq where + data State TAOReq = TAOState {} + +instance DataSourceName TAOReq where + dataSourceName _ = "MockTAO" + +instance DataSource UserEnv TAOReq where + fetch _state _flags _user bfs = SyncFetch $ mapM_ doFetch bfs + +initGlobalState :: IO (State TAOReq) +initGlobalState = return TAOState {} + +doFetch :: BlockedFetch TAOReq -> IO () +doFetch (BlockedFetch req@(AssocRangeId2s a b) r) = + case Map.lookup (a, b) assocs of + Nothing -> putFailure r . NotFound . Text.pack $ show req + Just result -> putSuccess r result + +assocs :: Map (Id,Id) [Id] +assocs = Map.fromList [ + ((friendsAssoc, 1), [5..10]), + ((friendsAssoc, 2), [7..12]), + ((friendsAssoc, 3), [10..15]), + ((friendsAssoc, 4), [15..19]) + ] + +friendsAssoc :: Id +friendsAssoc = 167367433327742 + +assocRangeId2s :: Id -> Id -> Haxl [Id] +assocRangeId2s a b = dataFetch (AssocRangeId2s a b) diff --git a/tests/TestExampleDataSource.hs b/tests/TestExampleDataSource.hs new file mode 100644 --- /dev/null +++ b/tests/TestExampleDataSource.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings, RebindableSyntax #-} +module TestExampleDataSource (tests) where + +import Haxl.Prelude as Haxl +import Prelude() + +import Haxl.Core.Monad (unsafeLiftIO) +import Haxl.Core + +import qualified Data.HashMap.Strict as HashMap +import Test.HUnit +import Data.IORef +import Control.Exception + +import ExampleDataSource +import LoadCache + +testEnv = do + -- To use a data source, we need to initialize its state: + exstate <- ExampleDataSource.initGlobalState + + -- And create a StateStore object containing the states we need: + let st = stateSet exstate stateEmpty + + -- Create the Env: + initEnv st () + + +tests = TestList [ + TestLabel "exampleTest" exampleTest, + TestLabel "orderTest" orderTest, + TestLabel "preCacheTest" preCacheTest, + TestLabel "cachedComputationTest" cachedComputationTest, + TestLabel "dataSourceExceptionTest" dataSourceExceptionTest, + TestLabel "dumpCacheAsHaskell" dumpCacheTest] + +-- Let's test ExampleDataSource. + +exampleTest :: Test +exampleTest = TestCase $ do + env <- testEnv + + -- Run an example expression with two fetches: + x <- runHaxl env $ + countAardvarks "abcabc" + (length <$> listWombats 3) + + assertEqual "runTests" x (2 + 3) + + -- Should be just one fetching round: + Stats s <- readIORef (statsRef env) + assertEqual "rounds" 1 (length s) + + -- With two fetches: + let reqs = case head s of RoundStats m -> HashMap.lookup "ExampleDataSource" m + assertEqual "reqs" (Just 2) reqs + +-- Test side-effect ordering + +orderTest = TestCase $ do + env <- testEnv + + ref <- newIORef ([] :: [Int]) + + let tick n = unsafeLiftIO (modifyIORef ref (n:)) + + let left = do tick 1 + r <- countAardvarks "abcabc" + tick 2 + return r + + let right = do tick 3 + r <- length <$> listWombats 3 + tick 4 + return r + + x <- runHaxl env $ left + right + assertEqual "TestExampleDataSource2" x (2 + 3) + + -- The order of the side effects is 1,3,2,4. First we see 1, then + -- left gets blocked, then we explore right, we see 3, then right + -- gets blocked. The data fetches are performed, then we see 2 and + -- then 4. + + ys <- readIORef ref + assertEqual "TestExampleDataSource: ordering" (reverse ys) [1,3,2,4] + + +preCacheTest = TestCase $ do + env <- testEnv + + x <- runHaxl env $ do + cacheRequest (CountAardvarks "xxx") (Right 3) + cacheRequest (ListWombats 100) (Right [1,2,3]) + countAardvarks "xxx" + (length <$> listWombats 100) + assertEqual "preCacheTest1" x (3 + 3) + + y <- Control.Exception.try $ runHaxl env $ do + cacheRequest (CountAardvarks "yyy") $ except (NotFound "yyy") + countAardvarks "yyy" + assertBool "preCacheTest2" $ + case y of + Left (NotFound "yyy") -> True + _other -> False + +-- Pretend CountAardvarks is a request computed by some Haxl code +cachedComputationTest = TestCase $ do + env <- testEnv + let env' = env { flags = (flags env){trace = 3} } + + let x = cachedComputation (CountAardvarks "ababa") $ do + a <- length <$> listWombats 10 + b <- length <$> listWombats 20 + return (a + b) + + r <- runHaxl env' $ x + x + countAardvarks "baba" + + assertEqual "cachedComputationTest1" 62 r + + stats <- readIORef (statsRef env) + assertEqual "fetches" 3 (numFetches stats) + +dataSourceExceptionTest = TestCase $ do + env <- testEnv + r <- runHaxl env $ Haxl.try $ countAardvarks "BANG" + assertBool "exception" $ + case r of + Left (ErrorCall "BANG") -> True + _ -> False + r <- runHaxl env $ Haxl.try $ countAardvarks "BANG2" + assertBool "exception" $ + case r of + Left (ErrorCall "BANG2") -> True + _ -> False + +-- Test that we can load the cache from a dumped copy of it, and then dump it +-- again to get the same result. +dumpCacheTest = TestCase $ do + env <- testEnv + runHaxl env loadCache + str <- runHaxl env dumpCacheAsHaskell + loadcache <- readFile "sigma/haxl/core/tests/LoadCache.txt" + assertEqual "dumpCacheAsHaskell" str loadcache diff --git a/tests/TestTypes.hs b/tests/TestTypes.hs new file mode 100644 --- /dev/null +++ b/tests/TestTypes.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module TestTypes + ( UserEnv + , Haxl + , lookupInput + , Id(..) + ) where + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable +import Data.Typeable + +import Haxl.Core + +type UserEnv = Object +type Haxl a = GenHaxl UserEnv a + +lookupInput :: FromJSON a => Text -> Haxl a +lookupInput field = do + mb_val <- env (HashMap.lookup field . userEnv) + case mb_val of + Nothing -> + throw (NotFound (Text.concat ["field ", field, " was not found."])) + Just val -> + case fromJSON val of + Error str -> + throw (UnexpectedType (Text.concat + ["field ", field, ": ", Text.pack str])) + Success a -> return a + + +newtype Id = Id Int + deriving (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable, + ToJSON, FromJSON) + +instance Show Id where + show (Id i) = show i