module Haxl.Core.Monad (
GenHaxl (..), runHaxl,
env,
throw, catch, try, tryToHaxlException,
dataFetch, uncachedRequest,
cacheRequest, cacheResult, cachedComputation,
dumpCacheAsHaskell,
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)
newtype GenHaxl u a = GenHaxl
{ unHaxl :: Env u -> IORef (RequestStore u) -> IO (Result u a) }
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
case ra of
Done a' -> return (Blocked (f' <*> return a'))
Throw e -> return (Blocked (f' <*> throw e))
Blocked a' -> return (Blocked (f' <*> a'))
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
env :: (Env u -> a) -> GenHaxl u a
env f = GenHaxl $ \env _ref -> return (Done (f env))
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)
unsafeLiftIO :: IO a -> GenHaxl u a
unsafeLiftIO m = GenHaxl $ \_env _ref -> Done <$> m
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
tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a)
tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)
dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a
dataFetch req = GenHaxl $ \env ref -> do
res <- cached env req
case res of
Uncached rvar -> do
modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs
return $ Blocked (continueFetch req rvar)
CachedNotFetched rvar -> return
$ Blocked (continueFetch req rvar)
Cached (Left ex) -> return (Throw ex)
Cached (Right a) -> return (Done a)
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)
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."
]
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
putResult rvar result
return $ Done ()
_other -> raise $
DataSourceError "cacheRequest: request is already in the cache"
instance IsString a => IsString (GenHaxl u a) where
fromString s = return (fromString s)
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 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 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
Nothing -> return $ Blocked (continueCached rvar)
Just r -> done r
done :: Either SomeException a -> IO (Result u a)
done = return . either Throw Done
dumpCacheAsHaskell :: GenHaxl u String
dumpCacheAsHaskell = do
ref <- env cacheRef
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 ""