{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
#if __GLASGOW_HASKELL >= 800
{-# OPTIONS_GHC -Wno-name-shadowing #-}
#else
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#endif
module Haxl.Core.Types (
Flags(..),
defaultFlags,
ifTrace,
ifReport,
ifProfiling,
Stats(..),
RoundStats(..),
DataSourceRoundStats(..),
Microseconds,
Round,
emptyStats,
numRounds,
numFetches,
ppStats,
ppRoundStats,
ppDataSourceRoundStats,
Profile,
emptyProfile,
profile,
profileRound,
profileCache,
ProfileLabel,
ProfileData(..),
emptyProfileData,
AllocCount,
MemoHitCount,
DataSource(..),
DataSourceName(..),
Request,
BlockedFetch(..),
PerformFetch(..),
DataCache(..),
SubCache(..),
emptyDataCache,
ResultVar(..),
newEmptyResult,
newResult,
putFailure,
putResult,
putSuccess,
takeResult,
tryReadResult,
tryTakeResult,
asyncFetch, asyncFetchWithDispatch,
asyncFetchAcquireRelease,
stubFetch,
syncFetch,
except,
setError,
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Data.Aeson
import Data.Function (on)
import Data.Functor.Constant
import Data.Int
import Data.Hashable
import Data.HashMap.Strict (HashMap, toList)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (intercalate, sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text, unpack)
import Data.Typeable
import Haxl.Core.Exception
#if __GLASGOW_HASKELL__ < 708
import Haxl.Core.Util (tryReadMVar)
#endif
import Haxl.Core.ShowP
import Haxl.Core.StateStore
data Flags = Flags
{ trace :: {-# UNPACK #-} !Int
, report :: {-# UNPACK #-} !Int
, caching :: {-# UNPACK #-} !Int
}
defaultFlags :: Flags
defaultFlags = Flags
{ trace = 0
, report = 1
, caching = 1
}
#if __GLASGOW_HASKELL__ >= 710
#define FUNMONAD Monad m
#else
#define FUNMONAD (Functor m, Monad m)
#endif
ifTrace :: FUNMONAD => Flags -> Int -> m a -> m ()
ifTrace flags i = when (trace flags >= i) . void
ifReport :: FUNMONAD => Flags -> Int -> m a -> m ()
ifReport flags i = when (report flags >= i) . void
ifProfiling :: FUNMONAD => Flags -> m a -> m ()
ifProfiling flags = when (report flags >= 4) . void
#undef FUNMONAD
type Microseconds = Int
type Round = Int
newtype Stats = Stats [RoundStats]
deriving (Show, ToJSON)
ppStats :: Stats -> String
ppStats (Stats rss) =
intercalate "\n"
[ "Round: " ++ show i ++ " - " ++ ppRoundStats rs
| (i, rs) <- zip [(1::Int)..] (filter isRoundStats (reverse rss)) ]
where
isRoundStats RoundStats{} = True
isRoundStats _ = False
data RoundStats
= RoundStats
{ roundTime :: Microseconds
, roundAllocation :: Int
, roundDataSources :: HashMap Text DataSourceRoundStats
}
| FetchCall
{ fetchReq :: String
, fetchStack :: [String]
}
deriving (Show)
ppRoundStats :: RoundStats -> String
ppRoundStats (RoundStats t a dss) =
show t ++ "us " ++ show a ++ " bytes\n"
++ unlines [ " " ++ unpack nm ++ ": " ++ ppDataSourceRoundStats dsrs
| (nm, dsrs) <- sortBy (compare `on` fst) (toList dss) ]
ppRoundStats (FetchCall r ss) = show r ++ '\n':show ss
instance ToJSON RoundStats where
toJSON RoundStats{..} = object
[ "time" .= roundTime
, "allocation" .= roundAllocation
, "dataSources" .= roundDataSources
]
toJSON (FetchCall req strs) = object
[ "request" .= req
, "stack" .= strs
]
data DataSourceRoundStats = DataSourceRoundStats
{ dataSourceFetches :: Int
, dataSourceTime :: Maybe Microseconds
, dataSourceFailures :: Maybe Int
, dataSourceAllocation :: Maybe Int
} deriving (Show)
ppDataSourceRoundStats :: DataSourceRoundStats -> String
ppDataSourceRoundStats (DataSourceRoundStats fetches time failures allocs) =
maybe id (\t s -> s ++ " (" ++ show t ++ "us)") time $
maybe id (\a s -> s ++ " (" ++ show a ++ " bytes)") allocs $
maybe id (\f s -> s ++ " " ++ show f ++ " failures") failures $
show fetches ++ " fetches"
instance ToJSON DataSourceRoundStats where
toJSON DataSourceRoundStats{..} = object [k .= v | (k, Just v) <-
[ ("fetches", Just dataSourceFetches)
, ("time", dataSourceTime)
, ("failures", dataSourceFailures)
, ("allocation", dataSourceAllocation)
]]
fetchesInRound :: RoundStats -> Int
fetchesInRound (RoundStats _ _ hm) =
sum $ map dataSourceFetches $ HashMap.elems hm
fetchesInRound _ = 0
emptyStats :: Stats
emptyStats = Stats []
numRounds :: Stats -> Int
numRounds (Stats rs) = length [ s | s@RoundStats{} <- rs ]
numFetches :: Stats -> Int
numFetches (Stats rs) = sum (map fetchesInRound rs)
type ProfileLabel = Text
type AllocCount = Int64
type MemoHitCount = Int64
data Profile = Profile
{ profileRound :: {-# UNPACK #-} !Round
, profile :: HashMap ProfileLabel ProfileData
, profileCache :: DataCache (Constant Round)
}
emptyProfile :: Profile
emptyProfile = Profile 1 HashMap.empty emptyDataCache
data ProfileData = ProfileData
{ profileAllocs :: {-# UNPACK #-} !AllocCount
, profileDeps :: HashSet ProfileLabel
, profileFetches :: Map Round (HashMap Text Int)
, profileMemoHits :: {-# UNPACK #-} !MemoHitCount
}
deriving Show
emptyProfileData :: ProfileData
emptyProfileData = ProfileData 0 HashSet.empty Map.empty 0
newtype DataCache res = DataCache (HashMap TypeRep (SubCache res))
data SubCache res =
forall req a . (Hashable (req a), Eq (req a), Typeable (req a)) =>
SubCache (req a -> String) (a -> String) ! (HashMap (req a) (res a))
emptyDataCache :: DataCache res
emptyDataCache = DataCache HashMap.empty
class (DataSourceName req, StateKey req, ShowP req) => DataSource u req where
fetch
:: State req
-> Flags
-> u
-> [BlockedFetch req]
-> PerformFetch
class DataSourceName req where
dataSourceName :: req a -> Text
type Request req a =
( Eq (req a)
, Hashable (req a)
, Typeable (req a)
, Show (req a)
, Show a
)
data PerformFetch
= SyncFetch (IO ())
| AsyncFetch (IO () -> IO ())
data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a)
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
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
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
asyncFetchWithDispatch
:: ((service -> IO ()) -> IO ())
-> (service -> IO ())
-> (service -> IO ())
-> (forall a. service -> request a -> IO (IO (Either SomeException a)))
-> State request
-> Flags
-> u
-> [BlockedFetch request]
-> PerformFetch
asyncFetch, syncFetch
:: ((service -> IO ()) -> IO ())
-> (service -> IO ())
-> (forall a. service -> request a -> IO (IO (Either SomeException a)))
-> State request
-> Flags
-> u
-> [BlockedFetch request]
-> 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
asyncFetchAcquireRelease
:: IO service
-> (service -> IO ())
-> (service -> IO ())
-> (service -> IO ())
-> (forall a. service -> request a -> IO (IO (Either SomeException a)))
-> State request
-> Flags
-> u
-> [BlockedFetch request]
-> PerformFetch
asyncFetchAcquireRelease
acquire release dispatch wait enqueue _state _flags _si requests =
AsyncFetch $ \inner -> mask $ \restore -> do
r1 <- tryWithRethrow acquire
case r1 of
Left err -> do restore inner; throwIO (err :: SomeException)
Right service -> do
flip finally (release service) $ restore $ do
r2 <- tryWithRethrow $ do
getResults <- mapM (submitFetch service enqueue) requests
dispatch service
return getResults
inner
case r2 of
Left err -> throwIO (err :: SomeException)
Right getResults -> do wait service; sequence_ getResults
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