2017-10-27 13:31:57 +03:00
|
|
|
-- Copyright (c) 2014-present, Facebook, Inc.
|
|
|
|
-- All rights reserved.
|
|
|
|
--
|
|
|
|
-- This source code is distributed under the terms of a BSD license,
|
2017-12-08 15:26:13 +03:00
|
|
|
-- found in the LICENSE file.
|
2017-10-27 13:31:57 +03:00
|
|
|
|
2017-04-19 22:12:56 +03:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
|
|
|
|
-- | A data source that can be made to fail in various ways, for testing
|
|
|
|
|
|
|
|
module BadDataSource (
|
|
|
|
-- * initialise the state
|
2020-01-31 12:46:41 +03:00
|
|
|
State(..), initGlobalState, FetchImpl(..),
|
2017-04-19 22:12:56 +03:00
|
|
|
|
|
|
|
-- * requests for this data source
|
2020-01-31 12:46:41 +03:00
|
|
|
FailAfter(..)
|
2017-04-19 22:12:56 +03:00
|
|
|
) where
|
|
|
|
|
|
|
|
import Haxl.Prelude
|
|
|
|
import Prelude ()
|
|
|
|
|
|
|
|
import Haxl.Core
|
|
|
|
|
|
|
|
import Control.Exception
|
|
|
|
import Data.Typeable
|
|
|
|
import Data.Hashable
|
|
|
|
import Control.Concurrent
|
2020-01-31 12:46:41 +03:00
|
|
|
import Control.Monad (void)
|
2017-04-19 22:12:56 +03:00
|
|
|
|
2020-01-15 19:11:35 +03:00
|
|
|
import GHC.Conc ( PrimMVar )
|
|
|
|
import Foreign.StablePtr
|
|
|
|
import Foreign.C.Types ( CInt(..) )
|
|
|
|
|
|
|
|
foreign import ccall safe
|
|
|
|
hs_try_putmvar :: CInt -> StablePtr PrimMVar -> IO ()
|
|
|
|
|
2020-03-03 20:38:01 +03:00
|
|
|
data FetchImpl =
|
|
|
|
Async
|
|
|
|
| Background
|
|
|
|
| BackgroundMVar
|
|
|
|
| BackgroundSeq
|
|
|
|
| BackgroundPar
|
2020-01-31 12:46:41 +03:00
|
|
|
|
2017-04-19 22:12:56 +03:00
|
|
|
data FailAfter a where
|
|
|
|
FailAfter :: Int -> FailAfter Int
|
|
|
|
deriving Typeable
|
|
|
|
|
|
|
|
deriving instance Eq (FailAfter a)
|
|
|
|
deriving instance Show (FailAfter a)
|
|
|
|
instance ShowP FailAfter where showp = show
|
|
|
|
|
|
|
|
instance Hashable (FailAfter a) where
|
|
|
|
hashWithSalt s (FailAfter a) = hashWithSalt s (0::Int,a)
|
|
|
|
|
|
|
|
instance StateKey FailAfter where
|
|
|
|
data State FailAfter = FailAfterState
|
|
|
|
{ failAcquireDelay :: Int
|
|
|
|
, failAcquire :: IO ()
|
|
|
|
, failReleaseDelay :: Int
|
|
|
|
, failRelease :: IO ()
|
|
|
|
, failDispatchDelay :: Int
|
|
|
|
, failDispatch :: IO ()
|
|
|
|
, failWaitDelay :: Int
|
|
|
|
, failWait :: IO ()
|
2020-01-31 12:46:41 +03:00
|
|
|
, failImpl :: FetchImpl
|
2017-04-19 22:12:56 +03:00
|
|
|
}
|
|
|
|
|
|
|
|
instance DataSourceName FailAfter where
|
|
|
|
dataSourceName _ = "BadDataSource"
|
|
|
|
|
2020-01-15 19:11:35 +03:00
|
|
|
|
2017-04-19 22:12:56 +03:00
|
|
|
instance DataSource u FailAfter where
|
2020-01-15 19:11:35 +03:00
|
|
|
fetch state@FailAfterState{..}
|
2020-03-03 20:38:01 +03:00
|
|
|
| BackgroundSeq <- failImpl = backgroundFetchSeq runOne state
|
|
|
|
| BackgroundPar <- failImpl = backgroundFetchPar runOne state
|
2020-01-31 12:46:41 +03:00
|
|
|
| Background <- failImpl = backgroundFetchAcquireRelease
|
2020-01-15 19:11:35 +03:00
|
|
|
acquire release dispatchbg wait
|
|
|
|
submit state
|
2020-01-31 12:46:41 +03:00
|
|
|
| BackgroundMVar <- failImpl = backgroundFetchAcquireReleaseMVar
|
|
|
|
acquire release dispatchbgMVar wait
|
|
|
|
submit state
|
|
|
|
| Async <- failImpl = asyncFetchAcquireRelease
|
2020-01-15 19:11:35 +03:00
|
|
|
acquire release dispatch wait
|
|
|
|
submit state
|
2017-04-19 22:12:56 +03:00
|
|
|
where
|
2020-01-15 19:11:35 +03:00
|
|
|
acquire = do threadDelay failAcquireDelay; failAcquire
|
|
|
|
release _ = do threadDelay failReleaseDelay; failRelease
|
|
|
|
dispatch _ = do threadDelay failDispatchDelay; failDispatch
|
2020-01-31 12:46:41 +03:00
|
|
|
dispatchBase put = (do
|
2020-01-15 19:11:35 +03:00
|
|
|
failDispatch
|
|
|
|
_ <- mask_ $ forkIO $ finally
|
|
|
|
(threadDelay failDispatchDelay)
|
2020-01-31 12:46:41 +03:00
|
|
|
put
|
|
|
|
return ()) `onException` put
|
|
|
|
dispatchbg _ c m = dispatchBase (hs_try_putmvar (fromIntegral c) m)
|
|
|
|
dispatchbgMVar _ _ m = dispatchBase (void $ tryPutMVar m ())
|
2020-01-15 19:11:35 +03:00
|
|
|
wait _ = do threadDelay failWaitDelay; failWait
|
2017-04-19 22:12:56 +03:00
|
|
|
submit :: () -> FailAfter a -> IO (IO (Either SomeException a))
|
|
|
|
submit _ (FailAfter t) = do
|
|
|
|
threadDelay t
|
|
|
|
return (return (Left (toException (FetchError "failed request"))))
|
2020-03-03 20:38:01 +03:00
|
|
|
runOne :: FailAfter a -> IO (Either SomeException a)
|
|
|
|
runOne r = do
|
|
|
|
bracket acquire release $ \s -> do
|
|
|
|
dispatch s
|
|
|
|
getRes <- submit s r
|
|
|
|
wait s
|
|
|
|
getRes
|
2017-04-19 22:12:56 +03:00
|
|
|
|
2020-01-31 12:46:41 +03:00
|
|
|
initGlobalState :: FetchImpl -> IO (State FailAfter)
|
|
|
|
initGlobalState impl = do
|
2017-04-19 22:12:56 +03:00
|
|
|
return FailAfterState
|
|
|
|
{ failAcquireDelay = 0
|
|
|
|
, failAcquire = return ()
|
|
|
|
, failReleaseDelay = 0
|
|
|
|
, failRelease = return ()
|
|
|
|
, failDispatchDelay = 0
|
|
|
|
, failDispatch = return ()
|
|
|
|
, failWaitDelay = 0
|
|
|
|
, failWait = return ()
|
2020-01-31 12:46:41 +03:00
|
|
|
, failImpl = impl
|
2017-04-19 22:12:56 +03:00
|
|
|
}
|