#!/usr/bin/env stack
{-
  Copyright (c) Meta Platforms, Inc. and affiliates.

  This source code is licensed under the MIT license found in the
  LICENSE file in the root directory of this source tree.
-}

-- stack --resolver lts-9.0 --install-ghc runghc --package turtle --package system-filepath --package pseudomacros --package megaparsec --package bifunctors

{-

This script verifies that for a given version number, all Flipper artifacts were
successfully uploaded to Bintray. Due to service flakiness, sometimes one or
more artifacts don't actually end up getting published and we want to have
an automated way to check whether or not an upload succeded.

This script works by simply passing it the version number you want to check.
On Mac OS you may also need to disable IPv6 because reasons.

  scripts/verify-bintray-upload.hs 0.5.0

Or with disabling the IPv6 stack in the JVM:

  env JAVA_TOOL_OPTIONS="-Djava.net.preferIPv6Addresses=false" scripts/verify-bintray-upload.hs 0.5.0

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

import Prelude hiding (FilePath)
import Turtle

import Control.Arrow ((>>>))
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe, catMaybes)
import Data.List.NonEmpty (fromList)
import PseudoMacros (__FILE__)

import qualified Filesystem.Path.CurrentOS as Path
import qualified Control.Monad.Managed as Managed
import qualified Text.Megaparsec.Text as MT
import qualified Text.Megaparsec as M
import qualified Data.Text as T
import qualified Control.Foldl as Fold

-- * Global settings

data RemoteRepository = RemoteRepository
  { repoId :: Text
  , repoLayout :: Maybe Text
  , repoUrl :: Text }

remoteRepositoryToString :: RemoteRepository -> Text
remoteRepositoryToString RemoteRepository{..} =
  T.intercalate "::"
    [ repoId
    , fromMaybe "" repoLayout
    , repoUrl
    ]

remoteRepositories :: [RemoteRepository]
remoteRepositories =
  [ RemoteRepository "jcenter" Nothing "https://jcenter.bintray.com/"
  , RemoteRepository "google" Nothing "https://maven.google.com/"
  ]

-- * Application logic

newtype Version = Version Text

-- | Strip a leading 'v' if present and wrap in a newtype.
parseVersion :: Text -> Version
parseVersion (T.stripPrefix "v" -> Just v) = Version v
parseVersion v                             = Version v

parser :: Turtle.Parser Version
parser = parseVersion <$> argText "VERSION" "Version number to verify"

data MvnArtifact = MvnArtifact
  { mvnArtifactId :: Text
  , mvnPackaging :: Text
  } deriving Show

-- | Provide a path to the directory this very file resides in through some
-- arcane magic.
thisDirectory :: IO FilePath
thisDirectory = do
  let filePath :: FilePath = $__FILE__
  currentDir <- pwd
  return . Path.parent $ currentDir </> filePath

mkFakeMavenSettings
  :: Managed.MonadManaged m
  => m FilePath
mkFakeMavenSettings = do
  mavenTmp <- using (mktempdir "/tmp" "fbm2")
  output (mavenTmp </> "settings.xml") $
    "<settings>" <|> ("<localRepository>" <> pure (unsafeTextToLine (format fp mavenTmp)) <>  "</localRepository>") <|> "</settings>"
  return mavenTmp

parseMvnArtifact :: Text -> Either Text MvnArtifact
parseMvnArtifact = M.parse (mvnParser <* M.eof) "<input>" >>> first (T.pack . M.parseErrorPretty)
  where
    pomParser :: MT.Parser (Text, Text)
    pomParser = do
      identifier <- T.strip . T.pack <$> M.someTill M.printChar (M.char '=')
      M.space
      value <- T.strip . T.pack <$> M.some M.printChar

      return (identifier, value)

    emptyLineParser :: forall a. MT.Parser (Maybe a)
    emptyLineParser = M.some M.spaceChar >> M.optional M.newline *> pure Nothing

    commentParser :: forall a. MT.Parser (Maybe a)
    commentParser = M.char '#' >> M.manyTill M.anyChar M.newline *> pure Nothing

    mvnParser :: MT.Parser MvnArtifact
    mvnParser = do
      pomItems <- M.many $ (commentParser <|> (Just <$> pomParser) <* M.eol) <|> emptyLineParser
      case reducePomTokens (catMaybes pomItems) of
        Just a -> return a
        Nothing -> M.unexpected (M.Label $ fromList "Missing POM identifiers.")

    reducePomTokens :: [(Text, Text)] -> Maybe MvnArtifact
    reducePomTokens ts = do
      mvnArtifactId <- lookup "POM_ARTIFACT_ID" ts
      mvnPackaging <- lookup "POM_PACKAGING" ts
      return MvnArtifact{..}

mvnArtifactToVersionedIdentifier :: MvnArtifact -> Text -> Text
mvnArtifactToVersionedIdentifier MvnArtifact{..} version =
  format ("com.facebook.flipper:"%s%":"%s%":"%s) mvnArtifactId version mvnPackaging

buildMvnGetCommand :: MvnArtifact -> Version -> FilePath -> (T.Text, [T.Text])
buildMvnGetCommand artifact (Version version) configDir =
  ( "mvn"
  , [ "dependency:get"
    , "-gs"
    , format fp (configDir </> "settings.xml")
    , "-Dartifact=" <> (mvnArtifactToVersionedIdentifier artifact version)
    , "-DremoteRepositories=" <> T.intercalate "," (remoteRepositoryToString <$> remoteRepositories)
    -- Would be nice to also check transitive deps, but mvn get doesn't support resolving transitive AARs.
    , "-Dtransitive=false"]
  )

-- | Ensure that the given directory sits at least one
--   level deep inside the given prefix.
isSubDir :: FilePath -> FilePath -> Bool
isSubDir prefix' path =
  stripPrefix prefix' path & \case
    Just dir -> length (splitDirectories dir) > 1
    Nothing -> False

foldResult :: FoldM IO (Maybe (MvnArtifact, Bool)) Bool
foldResult = FoldM step (pure True) pure
    where
        step _ (Just (mvnArtifact, False)) =
          printf ("Failed to download artifact "%w%".\n") mvnArtifact >> return False
        step prev _ =
          return prev

main :: IO ()
main = do
  version <- options "Bintray Upload Verifier" parser
  this <- thisDirectory
  rootDir <- realpath $ this </> ".."

  whichMvn <- which "mvn"
  case whichMvn of
    Just _ -> return ()
    Nothing -> die "This tool requires `mvn` (Apache Maven) to be on your $PATH."

  let parseProg = do
      gradleProperties :: FilePath <- realpath =<< find (suffix "/gradle.properties") rootDir
      guard $ isSubDir rootDir gradleProperties
      contents <- liftIO $ readTextFile gradleProperties
      case parseMvnArtifact contents of
        Left err' -> do
          printf ("Skipping unsupported file '"%fp%"' because of error "%s%".\n") gradleProperties err'
          return Nothing
        Right mvnArtifact -> do
          printf ("Downloading Maven artifact for "%w%" ...\n") mvnArtifact
          return $ Just mvnArtifact

  let runProg mvnArtifact = do
      mavenTmp <- mkFakeMavenSettings
      let (cmd, args) = buildMvnGetCommand mvnArtifact version mavenTmp
      ret <- proc cmd args empty
      case ret of
        ExitSuccess ->
          return (mvnArtifact, True)
        ExitFailure code -> do
          return (mvnArtifact, False)

  artifacts :: [MvnArtifact] <- catMaybes <$> fold parseProg Fold.list
  foldIO (parallel (flip fold Fold.head . runProg <$> artifacts)) foldResult >>= \case
     True -> do
       echo "All artifacts seem to have been uploaded. Sweet!"
       exit ExitSuccess
     False -> do
       err "ERROR: Some artifacts are missing from Bintray!"
       exit $ ExitFailure 1


#!/usr/bin/env stack
{-
  Copyright (c) Meta Platforms, Inc. and affiliates.

  This source code is licensed under the MIT license found in the
  LICENSE file in the root directory of this source tree.
-}

-- stack --resolver lts-14.7 --install-ghc runghc --package turtle --package system-filepath --package foldl

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}

import Prelude hiding (FilePath)
import Turtle

import Data.Maybe (catMaybes)
import Control.Monad (forM_)

import qualified Filesystem.Path.CurrentOS as Path
import qualified Data.Text as T
import qualified Control.Foldl as F

-- * Global settings

releaseReplacements :: [(FilePath, Pattern Version)]
releaseReplacements =
  [("gradle.properties", "VERSION_NAME=" *> anyVersion)
  ,("docs/getting-started/android-native.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper:" *> releaseVersion <* "'")
  ,("docs/getting-started/android-native.mdx", spaces >> "releaseImplementation 'com.facebook.flipper:flipper-noop:" *> releaseVersion <* "'")
  ,("docs/getting-started/react-native-android.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper:" *> releaseVersion <* "'")
  ,("docs/getting-started/react-native-android.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper-network-plugin:" *> releaseVersion <* "'")
  ,("desktop/plugins/public/leak_canary/docs/setup.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper-leakcanary2-plugin:" *> releaseVersion <* "'")
  ,("desktop/plugins/public/layout/docs/setup.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper-litho-plugin:" *> releaseVersion <* "'")
  ,("desktop/plugins/public/network/docs/setup.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper-network-plugin:" *> releaseVersion <* "'")
  ,("desktop/plugins/public/fresco/docs/setup.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper-images-plugin:" *> releaseVersion <* "'")
  ,("docs/getting-started/react-native-ios.mdx", spaces >> "use_flipper!('Flipper' => '" *> releaseVersion <* "')" <* many anyChar)
  ,("docs/getting-started/react-native-ios.mdx", spaces >> "flipperkit_version = '" *> releaseVersion <* "'" <* many anyChar)
  ,("docs/getting-started/react-native.mdx", many anyChar >> "`FLIPPER_VERSION=" *> releaseVersion <* "`.")
  ,("docs/getting-started/react-native.mdx", many anyChar >> "`use_flipper!({ 'Flipper' => '" *> releaseVersion <* "' })`.")
  ]

snapshotReplacements :: [(FilePath, Pattern Version)]
snapshotReplacements =
  [("gradle.properties", "VERSION_NAME=" *> anyVersion)
  ,("docs/getting-started/android-native.mdx", spaces >> "debugImplementation 'com.facebook.flipper:flipper:" *> snapshotVersion <* "'")
  ,("docs/getting-started/android-native.mdx", spaces >> "releaseImplementation 'com.facebook.flipper:flipper-noop:" *> snapshotVersion <* "'")
  ]

flipperPath :: FilePath -> FilePath
flipperPath basePath =
  basePath </> "xplat" </> "sonar"

-- * Patterns

releaseVersion :: Pattern Version
releaseVersion =
  Version <$> plus digit <> "." <> plus digit <> "." <> plus digit

snapshotVersion :: Pattern Version
snapshotVersion =
  Version <$> plus digit <> "." <> plus digit <> "." <> plus digit <> "-SNAPSHOT"

anyVersion :: Pattern Version
anyVersion =
  Version <$> plus digit <> "." <> plus digit <> "." <> plus (char '-' <|> alphaNum)

-- * Application logic

newtype Version = Version Text
  deriving (Show, Eq)

unversion (Version v) = v

data BumpMode = ModeRelease | ModeSnapshot
  deriving (Show, Eq)

data BumpArguments = BumpArguments
  { argVersion :: Version
  , argMode :: BumpMode
  } deriving (Show, Eq)

parser :: Turtle.Parser BumpArguments
parser = BumpArguments
  <$> (Version <$> argText "version" "Version to bump to, e.g. 1.0.2")
  <*> ((\b -> if b then ModeSnapshot else ModeRelease) <$> switch "snapshot" 's' "Change SNAPSHOT references instead of release ones")

-- | Find the root of the project, indicated by the presence of a ".hg" folder.
findProjectRoot :: FilePath -> IO (Maybe FilePath)
findProjectRoot dir = go $ Path.splitDirectories dir
  where
        go :: forall (m :: * -> *).
              MonadIO m =>
              [FilePath] -> m (Maybe FilePath)
        go []     = return Nothing
        go ds     = do
          let ds'  = init ds
              dir' = Path.concat ds'
              hg   = dir' </> ".hg"
          hgExists <- testdir hg
          if hgExists then
            return $ Just dir'
          else
            go ds'

replaceLine :: Version -> Pattern Version -> Pattern Version -> Line -> Shell Line
replaceLine newVersion matcher pttrn l =
  if match pttrn (lineToText l) == empty then pure l
  else sed (unversion newVersion <$ anyVersion) $ pure l

main :: IO ()
main = do
  args <- options "Flipper Version Bumper" parser
  let newVersion = argVersion args
  let (versionMatcher, replacements) = case argMode args of
        ModeRelease -> (releaseVersion, releaseReplacements)
        ModeSnapshot -> (snapshotVersion, snapshotReplacements)

  let isVersionValid = match versionMatcher (unversion newVersion)
  when (null isVersionValid) $ do
    printf ("Invalid version specified: "%w%".\n") newVersion
    exit $ ExitFailure 2

  projectRoot <- findProjectRoot =<< pwd
  let flipperDir = flipperPath <$> projectRoot
  flipperDir_ <- case flipperDir of
        Just f -> pure f
        Nothing -> die "Couldn't determine flipper location."

  printf ("Starting bump to "%w%".\n") newVersion
  forM_ replacements $ \(path, pttrn) -> do
      let absPath = flipperDir_ </> path
      printf ("Updating version in "%w%"\n") absPath
      lines <- T.lines <$> readTextFile absPath
      newLines :: [Line] <- flip fold F.mconcat . sequence $ replaceLine newVersion versionMatcher pttrn <$> catMaybes (textToLine <$> lines)
      writeTextFile absPath . T.unlines $ lineToText <$> newLines
  echo "Done!"


#!/usr/bin/env stack
{-
  Copyright (c) Meta Platforms, Inc. and affiliates.

  This source code is licensed under the MIT license found in the
  LICENSE file in the root directory of this source tree.
-}

-- stack --resolver lts-14.3 --install-ghc runghc --package turtle --package system-filepath --package foldl --package typed-process --package bytestring

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}

import Prelude hiding (FilePath)
import Turtle

import Data.Maybe (catMaybes)
import Control.Monad (forM_)
import Data.List ((\\))

import qualified Filesystem.Path.CurrentOS as Path
import qualified System.Process.Typed as Proc
import qualified Data.Text as T
import qualified Control.Foldl as F
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL

-- * Global settings

flipperPath :: FilePath -> FilePath
flipperPath basePath =
  basePath </> "xplat" </> "sonar"

-- * Application logic

-- | Find the root of the project, indicated by the presence of a ".hg" folder.
findProjectRoot :: FilePath -> IO (Maybe FilePath)
findProjectRoot dir = go $ Path.splitDirectories dir
  where
        go :: forall (m :: * -> *).
              MonadIO m =>
              [FilePath] -> m (Maybe FilePath)
        go []     = return Nothing
        go ds     = do
          let ds'  = init ds
              dir' = Path.concat ds'
              hg   = dir' </> ".hg"
          hgExists <- testdir hg
          if hgExists then
            return $ Just dir'
          else
            go ds'

data TSCResult = TSCResult
  { numErrors :: Int
  , errors    :: [BS.ByteString]
  } deriving (Show, Eq)

runTSC :: FilePath -> Shell TSCResult
runTSC root = do
  cd root
  (exitCode, stdout, stderr) <- liftIO $ Proc.readProcess (Proc.proc "yarn" ["run", "tsc", "--strict"])
  let errors = C.split '\n' (BSL.toStrict stdout) & filter (BS.isInfixOf ": error TS")
  pure $ TSCResult { numErrors = length errors
                   , errors = errors
                   }

hgPrev :: Shell ()
hgPrev = procs "hg" ["prev"] mempty

hgNext :: Shell ()
hgNext = procs "hg" ["next"] mempty

handleErr :: IO ExitCode
handleErr = err "Failed to run hg/tsc. Check above output." >> (pure $ ExitFailure 2)

handleRes :: TSCResult -> TSCResult -> IO ExitCode
handleRes cur prev = do
  let delta = numErrors cur - numErrors prev
  if delta > 0 then do
    eprintf ("TSC Strict Mode regression. "%d%" new violations introduced:\n") delta
    forM_ (errors cur \\ errors prev) $ eprintf ("- "%w%"\n")
    eprintf "Please visit https://fburl.com/strictflipper for more information.\n"
    return $ ExitFailure 1
  else do
    printf ("TSC Strict Mode test passed. Delta: "%d%"\n") delta
    return ExitSuccess

main :: IO ()
main = do
  projectRoot <- findProjectRoot =<< pwd
  let flipperDir = flipperPath <$> projectRoot
  flipperDir_ <- case flipperDir of
        Just f -> realpath f
        Nothing -> die "Couldn't determine Flipper project location."

  printf "Running tsc --strict against current revision.\n"
  currentRes <- fold (runTSC flipperDir_) F.head
  printf "Checking out hg prev.\n"
  _ <- sh hgPrev
  printf "Running tsc --strict against previous revision.\n"
  prevRes <- fold (runTSC flipperDir_) F.head
  printf "Checking out hg next.\n"
  _ <- sh hgNext

  exit =<< case (currentRes, prevRes) of
    (Just cur, Just prev) -> handleRes cur prev
    _ -> handleErr


import Distribution.Simple
main = defaultMain


module FB
  ( getObject
  , getUser
  , getUserFriends
  , Id(..), Friend(..), User(..)
  ) where

import FB.DataSource
import Data.Aeson
import Facebook (Id(..), Friend(..), User(..))

import Haxl.Core

-- | Fetch an arbitrary object in the Facebook graph.
getObject :: Id -> GenHaxl u w Object
getObject id = dataFetch (GetObject id)

-- | Fetch a Facebook user.
getUser :: Id -> GenHaxl u w User
getUser id = dataFetch (GetUser id)

-- | Fetch the friends of a Facebook user that are registered with the
-- current app.
getUserFriends :: Id -> GenHaxl u w [Friend]
getUserFriends id = dataFetch (GetUserFriends id)


{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
module Main (main) where

import Control.Exception as E
import Data.Aeson
import Data.HashMap.Strict ((!))
import Data.Time.Calendar
import Data.Time.Clock
import FB
import FB.DataSource
import Haxl.Core
import Haxl.Prelude
import System.Environment
import System.Exit
import System.IO.Error
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import qualified Data.Vector as Vector

main = do
  (creds, access_token) <- getCredentials
  facebookState <- initGlobalState 10 creds access_token
  env <- initEnv (stateSet facebookState stateEmpty) ()
  r <- runHaxl env $ do
    likes <- getObject "me/likes"
    mapM getObject (likeIds likes)      -- these happen concurrently
  print r

likeIds :: Object -> [Id]
likeIds likes = do
  Array arr <- [likes ! "data"]
  Object obj <- Vector.toList arr
  String id <- [obj ! "id"]
  return (Id id)

-- Modifed from the test in the fb package:
-- https://github.com/meteficha/fb/blob/master/tests/Main.hs
-- Copyright (c)2012, Felipe Lessa

-- | Grab the Facebook credentials from the environment.
getCredentials :: IO (Credentials, UserAccessToken)
getCredentials = tryToGet `E.catch` showHelp
    where
      tryToGet = do
        [appName, appId, appSecret, accessToken] <-
           mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET", "ACCESS_TOKEN"]
        now <- getCurrentTime
        let creds = Credentials (T.pack appName)
                                (T.pack appId)
                                (T.pack appSecret)
            access_token = UserAccessToken
                             (Id "me")
                             (T.pack accessToken)
                             now
        return (creds, access_token)

      showHelp exc | not (isDoesNotExistError exc) = E.throw exc
      showHelp _ = do
        putStrLn $ unlines
          [ "In order to run the tests from the 'haxl-facebook' package, you"
          , "need developer access to a Facebook app.  Create an app by"
          , "going to http://developers.facebook.com, select \"Create a New"
          , " App\" from the \"Apps\" menu at the top.  Then create an"
          , "access token using the Graph API explorer:"
          , "   https://developers.facebook.com/tools/explorer"
          , "Select your app from the \"Application\" menu at the top, then hit"
          , "\"Get Access Token\".  The access token will last about 2 hours."
          , ""
          , "Please supply your app's name, id and secret in the environment"
          , "variables APP_NAME, APP_ID and APP_SECRET, respectively, and"
          , "the access token in ACCESS_TOKEN."
          , ""
          , "For example, before running the test you could run in the shell:"
          , ""
          , " $ export APP_NAME=\"test\""
          , " $ export APP_ID=\"000000000000000\""
          , " $ export APP_SECRET=\"xxxxxxxxxxxxxxxxxxxxxxxxxxxx\""
          , " $ export ACCESS_TOKEN=\"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\""
          , ""
          , "Of course, these values above aren't valid and you need to"
          , "replace them with your own."
          , ""
          , "(Exiting now with a failure code.)"]
        exitFailure


{-# LANGUAGE OverloadedStrings, StandaloneDeriving, RecordWildCards,
    GADTs, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable,
    FlexibleInstances #-}
-- QSem was deprecated in 7.6, but no more
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module FB.DataSource
  ( FacebookReq(..)
  , initGlobalState
  , Credentials(..)
  , UserAccessToken
  , AccessToken(..)
  ) where

import Network.HTTP.Conduit
import Facebook as FB
import Control.Monad
import Control.Monad.Trans.Resource
import Data.Hashable
import Data.Typeable
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Data.Conduit
import Data.Conduit.List hiding (mapM, mapM_)
import Data.Monoid
import Data.Aeson
import Control.Concurrent.Async
import Control.Concurrent.QSem
import Control.Exception

import Haxl.Core

data FacebookReq a where
   GetObject      :: Id -> FacebookReq Object
   GetUser        :: UserId -> FacebookReq User
   GetUserFriends :: UserId -> FacebookReq [Friend]
  deriving Typeable

deriving instance Eq (FacebookReq a)
deriving instance Show (FacebookReq a)

instance ShowP FacebookReq where showp = show

instance Hashable (FacebookReq a) where
  hashWithSalt s (GetObject (Id id))      = hashWithSalt s (0::Int,id)
  hashWithSalt s (GetUser (Id id))        = hashWithSalt s (1::Int,id)
  hashWithSalt s (GetUserFriends (Id id)) = hashWithSalt s (2::Int,id)

instance StateKey FacebookReq where
  data State FacebookReq =
    FacebookState
       { credentials :: Credentials
       , userAccessToken :: UserAccessToken
       , manager :: Manager
       , semaphore :: QSem
       }

instance DataSourceName FacebookReq where
  dataSourceName _ = "Facebook"

instance DataSource u FacebookReq where
  fetch = facebookFetch

initGlobalState
  :: Int
  -> Credentials
  -> UserAccessToken
  -> IO (State FacebookReq)

initGlobalState threads creds token = do
  manager <- newManager tlsManagerSettings
  sem <- newQSem threads
  return FacebookState
    { credentials = creds
    , manager = manager
    , userAccessToken = token
    , semaphore = sem
    }

facebookFetch
  :: State FacebookReq
  -> Flags
  -> u
  -> PerformFetch FacebookReq

facebookFetch FacebookState{..} _flags _user =
  BackgroundFetch $
    mapM_ (fetchAsync credentials manager userAccessToken semaphore)

fetchAsync
  :: Credentials -> Manager -> UserAccessToken -> QSem
  -> BlockedFetch FacebookReq
  -> IO ()
fetchAsync creds manager tok sem (BlockedFetch req rvar) =
  void $ async $ bracket_ (waitQSem sem) (signalQSem sem) $ do
    e <- Control.Exception.try $
           runResourceT $ runFacebookT creds manager $ fetchFBReq tok req
    case e of
      Left ex -> putFailure rvar (ex :: SomeException)
      Right a -> putSuccess rvar a

fetchFBReq
  :: UserAccessToken
  -> FacebookReq a
  -> FacebookT Auth (ResourceT IO) a

fetchFBReq tok (GetObject (Id id)) =
  getObject ("/" <> id) [] (Just tok)

fetchFBReq _tok (GetUser id) =
  getUser id [] Nothing

fetchFBReq tok (GetUserFriends id) = do
  f <- getUserFriends id [] tok
  source <- fetchAllNextPages f
  source $$ consume


-- Necessary:
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

-- Incidental:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Main where

import Control.Monad
import Data.Hashable
import Data.List
import Data.Text (Text)
import Data.Traversable (for)
import Data.Typeable
import Haxl.Core
import System.Random

import qualified Data.Text as Text

main :: IO ()
main = do
  let stateStore = stateSet UserState{} stateEmpty
  env0 <- initEnv stateStore ()
  names <- runHaxl env0 getAllUsernames
  print names

-- Data source API.

getAllUsernames :: Haxl [Name]
getAllUsernames = do
  userIds <- getAllUserIds
  for userIds $ \userId -> do
    getUsernameById userId

getAllUserIds :: Haxl [Id]
getAllUserIds = dataFetch GetAllIds

getUsernameById :: Id -> Haxl Name
getUsernameById userId = dataFetch (GetNameById userId)

-- Aliases.

type Haxl = GenHaxl () ()
type Id = Int
type Name = Text

-- Data source implementation.

data UserReq a where
  GetAllIds   :: UserReq [Id]
  GetNameById :: Id -> UserReq Name
  deriving (Typeable)

deriving instance Eq (UserReq a)
instance Hashable (UserReq a) where
   hashWithSalt s GetAllIds       = hashWithSalt s (0::Int)
   hashWithSalt s (GetNameById a) = hashWithSalt s (1::Int, a)

deriving instance Show (UserReq a)
instance ShowP UserReq where showp = show

instance StateKey UserReq where
  data State UserReq = UserState {}

instance DataSourceName UserReq where
  dataSourceName _ = "UserDataSource"

instance DataSource u UserReq where
  fetch _state _flags _userEnv = SyncFetch $ \blockedFetches -> do
    let
      allIdVars :: [ResultVar [Id]]
      allIdVars = [r | BlockedFetch GetAllIds r <- blockedFetches]

      idStrings :: [String]
      idStrings = map show ids

      ids :: [Id]
      vars :: [ResultVar Name]
      (ids, vars) = unzip
        [(userId, r) | BlockedFetch (GetNameById userId) r <- blockedFetches]

    unless (null allIdVars) $ do
      allIds <- sql "select id from ids"
      mapM_ (\r -> putSuccess r allIds) allIdVars

    unless (null ids) $ do
      names <- sql $ unwords
        [ "select name from names where"
        , intercalate " or " $ map ("id = " ++) idStrings
        , "order by find_in_set(id, '" ++ intercalate "," idStrings ++ "')"
        ]
      mapM_ (uncurry putSuccess) (zip vars names)

-- Mock SQL API.

class SQLResult a where
  mockResult :: IO a

instance SQLResult a => SQLResult [a] where
  mockResult = replicateM 10 mockResult

instance SQLResult Name where
  -- An infinite number of employees, all named Jim.
  mockResult = ("Jim" `Text.append`) . Text.pack . show <$> randomRIO (1::Int, 100)

instance SQLResult Id where
  mockResult = randomRIO (1, 100)

sql :: SQLResult a => String -> IO a
sql query = print query >> mockResult


-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

-- | Everything needed to define data sources and to invoke the
-- engine.
--
{-# LANGUAGE CPP #-}
module Haxl.Core (
    -- * The monad and operations
    GenHaxl (..), runHaxl, runHaxlWithWrites

    -- ** Env
  , Env(..), Caches, caches
    -- *** Operations in the monad
  , env, withEnv, withLabel
    -- *** Building the Env
  , initEnvWithData, initEnv, emptyEnv, sanitizeEnv
    -- *** Building the StateStore
  , StateStore, stateGet, stateSet, stateEmpty

    -- ** Writes inside the monad
  , tellWrite, tellWriteNoMemo

    -- ** Exceptions
  , throw, catch, catchIf, try, tryToHaxlException

    -- ** Data fetching and caching
  , dataFetch, uncachedRequest
  , cacheRequest, dupableCacheRequest, cacheResult, cacheResultWithShow
  , cachedComputation, preCacheComputation
  , dumpCacheAsHaskell

    -- ** Memoization
  , newMemo, newMemoWith, prepareMemo, runMemo
  , memo, memoUnique, memoize, memoize1, memoize2
  , memoFingerprint, MemoFingerprintKey(..)

    -- ** Conditionals
  , pAnd, pOr, unsafeChooseFirst

    -- ** Statistics
  , Stats(..)
  , FetchStats(..)
  , CallId
  , Microseconds
  , Timestamp
  , emptyStats
  , numFetches
  , ppStats
  , ppFetchStats
  , aggregateFetchBatches
  , Profile(..)
  , ProfileMemo(..)
  , ProfileFetch(..)
  , emptyProfile
  , ProfileLabel
  , ProfileKey
  , ProfileData(..)
  , emptyProfileData
  , AllocCount
  , LabelHitCount

    -- * Report flags
  , ReportFlag(..)
  , ReportFlags
  , defaultReportFlags
  , profilingReportFlags
  , setReportFlag
  , clearReportFlag
  , testReportFlag

    -- ** Flags
  , Flags(..)
  , defaultFlags
  , ifTrace
  , ifReport
  , ifProfiling

    -- * Building data sources
  , DataSource(..)
  , ShowP(..)
  , DataSourceName(..)
  , Request
  , BlockedFetch(..)
  , PerformFetch(..)
  , StateKey(..)
  , SchedulerHint(..)
  , FailureClassification(..)

    -- ** Result variables
  , ResultVar(..)
  , mkResultVar
  , putFailure
  , putResult
  , putSuccess
  , putResultFromChildThread
  , putResultWithStats
  , putResultWithStatsFromChildThread
  , DataSourceStats(..)

    -- ** Default fetch implementations
  , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease
  , backgroundFetchSeq, backgroundFetchPar
  , backgroundFetchAcquireRelease, backgroundFetchAcquireReleaseMVar
  , stubFetch
  , syncFetch

    -- ** Utilities
  , except
  , setError
  , getMapFromRCMap

    -- * Exceptions
  , module Haxl.Core.Exception

    -- * Recording the function callgraph
  , module Haxl.Core.CallGraph
  ) where

import Haxl.Core.CallGraph
import Haxl.Core.DataSource
import Haxl.Core.Flags
import Haxl.Core.Memo
import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -})
import Haxl.Core.Fetch
import Haxl.Core.Parallel
import Haxl.Core.Profile
import Haxl.Core.Run
import Haxl.Core.Stats
import Haxl.Core.Exception
import Haxl.Core.RequestStore (getMapFromRCMap)
import Haxl.Core.ShowP (ShowP(..))
import Haxl.Core.StateStore


-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE 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
-- 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, memo,
    memoize, memoize1, memoize2,

    -- * Extra Monad and Applicative things
    Applicative(..),
    mapM, mapM_, sequence, sequence_, filterM, foldM,
    forM, forM_,
    foldl', sort,
    Monoid(..),
    join,
    andThen,

    -- * Lifted operations
    IfThenElse(..),
    (.>), (.<), (.>=), (.<=),
    (.==), (./=), (.&&), (.||),
    (.++),
    pair,
    pAnd, pOr,

    -- * Text things
    Text,
    IsString(..),

    -- * Exceptions
    throw, catch, try, withDefault, catchAny,
    HaxlException(..), TransientError(..), LogicError(..),
    NotFound(..), UnexpectedType(..), FetchError(..),
    EmptyList(..), InvalidParameter(..)

  ) where

import Haxl.Core.DataSource
import Haxl.Core.Exception
import Haxl.Core.Memo
import Haxl.Core.Monad
import Haxl.Core.Fetch
import Haxl.Core.Parallel

import Control.Applicative
import Control.Monad (foldM, join, void)
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.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 = if b then t else e

-- The equality constraint is necessary to convince the typechecker that
-- this is valid:
--
-- > if ipGetCountry ip .== "us" then ... else ...
--
instance (u1 ~ u2) => IfThenElse (GenHaxl u1 w Bool) (GenHaxl u2 w a) where
  ifThenElse fb t e = do
    b <- fb
    if b then t else e

instance Num a => Num (GenHaxl u w a) where
  (+)         = liftA2 (+)
  (-)         = liftA2 (-)
  (*)         = liftA2 (*)
  fromInteger = pure . fromInteger
  abs         = liftA abs
  signum      = liftA signum
  negate      = liftA negate

instance Fractional a => Fractional (GenHaxl u w 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 w a -> GenHaxl u w a -> GenHaxl u w Bool
(.>) = liftA2 (Prelude.>)

(.<) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.<) = liftA2 (Prelude.<)

(.>=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.>=) = liftA2 (Prelude.>=)

(.<=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.<=) = liftA2 (Prelude.<=)

(.==) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.==) = liftA2 (Prelude.==)

(./=) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(./=) = liftA2 (Prelude./=)

(.++) :: GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a]
(.++) = liftA2 (Prelude.++)

-- short-circuiting Bool operations
(.&&):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
fa .&& fb = do a <- fa; if a then fb else return False

(.||):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
fa .|| fb = do a <- fa; if a then return True else fb

pair :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (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 = void $ 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 = void $ sequenceA t

-- | See 'mapM'.
filterM :: (Applicative f) => (a -> f Bool) -> [a] -> f [a]
filterM predicate xs =
    filt <$> mapM predicate xs
  where
    filt bools = [ x | (x,True) <- zip xs bools ]

-- | In somes cases, we do want the monadic version of @('>>')@ to disable
-- concurrency and start one computation only after the other finishes, e.g.:
--
-- @
-- deferedFetch x = do
--   sleep 5
--   fetch x  -- fetch will actually run concurrently with sleep
-- @
--
-- But we have defined @('>>') = ('*>')@ with the applicative behavior as this
-- is desired in most cases, so instead we define 'andThen' as the monadic
-- version of @('>>')@:
--
-- @
-- deferedFetch x = sleep 5 `andThen` fetch x
-- @
andThen :: Monad m => m a -> m b -> m b
andThen a b = a >>= \_ -> b

--------------------------------------------------------------------------------

-- | 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 w a -> GenHaxl u w a
withDefault d a = catchAny a (return d)

-- | Catch 'LogicError's and 'TransientError's and perform an alternative action
catchAny
  :: GenHaxl u w a   -- ^ run this first
  -> GenHaxl u w a   -- ^ if it throws 'LogicError' or 'TransientError', run this
  -> GenHaxl u w a
catchAny haxl handler =
  haxl `catch` \e ->
    if isJust (fromException e :: Maybe LogicError) ||
       isJust (fromException e :: Maybe TransientError)
      then
        handler
      else
        throw e


-- Copyright 2004-present Facebook. All Rights Reserved.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module Haxl.Core.CallGraph where

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import Data.Text (Text)
import qualified Data.Text as Text

type ModuleName = Text

-- | An unqualified function
type Function = Text

-- | A qualified function
data QualFunction = QualFunction ModuleName Function deriving (Eq, Ord)

instance Show QualFunction where
  show (QualFunction mn nm) = Text.unpack $ mn <> Text.pack "." <> nm

-- | Represents an edge between a parent function which calls a child function
-- in the call graph
type FunctionCall = (QualFunction, QualFunction)

-- | An edge list which represents the dependencies between function calls
type CallGraph = ([FunctionCall], Map QualFunction Text)

-- | Used as the root of all function calls
mainFunction :: QualFunction
mainFunction = QualFunction "MAIN" "main"

emptyCallGraph :: CallGraph
emptyCallGraph = ([], Map.empty)


-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- A cache mapping data requests to their results.  This module is
-- provided for access to Haxl internals only; most users should not
-- need to import it.
--
module Haxl.Core.DataCache
  ( DataCache(..)
  , SubCache(..)
  , emptyDataCache
  , filter
  , insert
  , insertNotShowable
  , insertWithShow
  , lookup
  , showCache
  , readCache
  ) where

import Prelude hiding (lookup, filter)
import Control.Exception
import Unsafe.Coerce
import Data.Typeable
import Data.Hashable
import qualified Data.HashTable.IO as H

-- ---------------------------------------------------------------------------
-- DataCache

-- | A @'DataCache' res@ maps things of type @req a@ to @res a@, for
-- any @req@ and @a@ provided @req a@ is an instance of 'Typeable'. In
-- practice @req a@ will be a request type parameterised by its result.
--
newtype DataCache res = DataCache (HashTable TypeRep (SubCache res))

-- | 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 res =
  forall req a . (Hashable (req a), Eq (req a)) =>
       SubCache (req a -> String) (a -> String) !(HashTable (req a) (res a))
       -- NB. the inner HashMap is strict, to avoid building up
       -- a chain of thunks during repeated insertions.

type HashTable k v = H.BasicHashTable k v

-- | A new, empty 'DataCache'.
emptyDataCache :: IO (DataCache res)
emptyDataCache = DataCache <$> H.new

-- | Inserts a request-result pair into the 'DataCache'.
insert
  :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a)
  => req a
  -- ^ Request
  -> res a
  -- ^ Result
  -> DataCache res
  -> IO ()

insert = insertWithShow show show

-- | Inserts a request-result pair into the 'DataCache', without
-- requiring Show instances of the request or the result.  The cache
-- cannot be subsequently used with `showCache`.
insertNotShowable
  :: (Hashable (req a), Typeable (req a), Eq (req a))
  => req a
  -- ^ Request
  -> res a
  -- ^ Result
  -> DataCache res
  -> IO ()

insertNotShowable = insertWithShow notShowable notShowable

-- | Inserts a request-result pair into the 'DataCache', with the given
-- functions used to show the request and result.
insertWithShow
  :: (Hashable (req a), Typeable (req a), Eq (req a))
  => (req a -> String)
  -- ^ Show function for request
  -> (a -> String)
  -- ^ Show function for result
  -> req a
  -- ^ Request
  -> res a
  -- ^ Result
  -> DataCache res
  -> IO ()

insertWithShow showRequest showResult request result (DataCache m) =
  H.mutateIO m (typeOf request) (mutate showRequest showResult request result)

notShowable :: a
notShowable = error "insertNotShowable"

-- | A mutation function for mutateIO. If the key doesn't exist in the top-level
-- cache, creates a new hashtable and inserts the request and result.
-- If the key exists, insert the request and result into the existing subcache,
-- replacing any existing mapping.
mutate :: (Hashable (req a), Typeable (req a), Eq (req a))
  => (req a -> String)
  -> (a -> String)
  -> req a
  -> res a
  -> Maybe (SubCache res)
  -> IO (Maybe (SubCache res), ())
mutate showRequest showResult request result Nothing = do
  newTable <- H.new
  H.insert newTable request result
  return (Just (SubCache showRequest showResult newTable), ())
mutate _ _ request result (Just sc@(SubCache _ _ oldTable)) = do
    H.insert oldTable (unsafeCoerce request) (unsafeCoerce result)
    return (Just sc, ())

-- | Looks up the cached result of a request.
lookup
  :: Typeable (req a)
  => req a
  -- ^ Request
  -> DataCache res
  -> IO (Maybe (res a))

lookup req (DataCache m) = do
  mbRes <- H.lookup m (typeOf req)
  case mbRes of
    Nothing -> return Nothing
    Just (SubCache _ _ sc) ->
      unsafeCoerce (H.lookup sc (unsafeCoerce req))

filter
  :: forall res
  . (forall a. res a -> IO Bool)
  -> DataCache res
  -> IO (DataCache res)
filter pred (DataCache cache) = do
  cacheList <- H.toList cache
  filteredCache <- filterSubCache `mapM` cacheList
  DataCache <$> H.fromList filteredCache
  where
    filterSubCache
      :: (TypeRep, SubCache res)
      -> IO (TypeRep, SubCache res)
    filterSubCache (ty, SubCache showReq showRes hm) = do
      filteredList <- H.foldM go [] hm
      filteredSC <- H.fromList filteredList
      return (ty, SubCache showReq showRes filteredSC)
      where
        go res (request, rvar) = do
          predRes <- pred rvar
          return $ if predRes then (request, rvar):res else res

-- | Dumps the contents of the cache, with requests and responses
-- converted to 'String's using the supplied show functions.  The
-- entries are grouped by 'TypeRep'.  Note that this will fail if
-- 'insertNotShowable' has been used to insert any entries.
showCache
  :: forall res
  .  DataCache res
  -> (forall a . res a -> IO (Maybe (Either SomeException a)))
  -> IO [(TypeRep, [(String, Either SomeException String)])]
showCache (DataCache cache) readRes = H.foldM goSubCache [] cache
  where
    goSubCache
      :: [(TypeRep, [(String, Either SomeException String)])]
      -> (TypeRep, SubCache res)
      -> IO [(TypeRep, [(String, Either SomeException String)])]
    goSubCache res (ty, SubCache showReq showRes hm) = do
      subCacheResult <- H.foldM go [] hm
      return $ (ty, subCacheResult):res
      where
        go res (request, rvar) = do
          maybe_r <- readRes rvar
          return $ case maybe_r of
            Nothing -> res
            Just (Left e) -> (showReq request, Left e) : res
            Just (Right result) ->
              (showReq request, Right (showRes result)) : res

-- | Dumps the contents of the cache responses to list
readCache
  :: forall res ret
  .  DataCache res
  -> (forall a . res a -> IO ret)
  -> IO [(TypeRep, [Either SomeException ret])]
readCache (DataCache cache) readRes = H.foldM goSubCache [] cache
  where
    goSubCache
      :: [(TypeRep, [Either SomeException ret])]
      -> (TypeRep, SubCache res)
      -> IO [(TypeRep, [Either SomeException ret])]
    goSubCache res (ty, SubCache _showReq _showRes hm) = do
      subCacheResult <- H.foldM go [] hm
      return $ (ty, subCacheResult):res
      where
        go res (_request, rvar) = do
          r <- try $ readRes rvar
          return $ r : res


-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- The 'DataSource' class and related types and functions.  This
-- module is provided for access to Haxl internals only; most users
-- should import "Haxl.Core" instead.
--
module Haxl.Core.DataSource
  (
  -- * Data fetching
    DataSource(..)
  , DataSourceName(..)
  , Request
  , BlockedFetch(..)
  , PerformFetch(..)
  , SchedulerHint(..)
  , FailureClassification(..)

  -- * Result variables
  , ResultVar(..)
  , mkResultVar
  , putFailure
  , putResult
  , putResultFromChildThread
  , putSuccess
  , putResultWithStats
  , putResultWithStatsFromChildThread

  -- * Default fetch implementations
  , asyncFetch, asyncFetchWithDispatch
  , asyncFetchAcquireRelease
  , backgroundFetchSeq, backgroundFetchPar
  , backgroundFetchAcquireRelease
  , backgroundFetchAcquireReleaseMVar
  , stubFetch
  , syncFetch

  -- * Utilities
  , except
  , setError
  ) where

import Control.Exception
import Control.Monad
import Data.Hashable
import Data.Text (Text)
import Data.Kind (Type)
import Data.Typeable

import Haxl.Core.Exception
import Haxl.Core.Flags
import Haxl.Core.ShowP
import Haxl.Core.StateStore
import Haxl.Core.Stats

import GHC.Conc ( newStablePtrPrimMVar
                , PrimMVar)
import Control.Concurrent ( threadCapability
                          , forkOn
                          , myThreadId )
import Control.Concurrent.MVar
import Foreign.StablePtr

-- ---------------------------------------------------------------------------
-- DataSource class

-- | 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
-- <https://github.com/facebook/Haxl/tree/master/example Examples>.
--
class (DataSourceName req, StateKey req, ShowP req) => DataSource u req where

  -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch'
  -- objects contain both the request and the 'ResultVar's into which to put
  -- the results.
  fetch
    :: State req
      -- ^ Current state.
    -> Flags
      -- ^ Tracing flags.
    -> u
      -- ^ User environment.
    -> PerformFetch req
      -- ^ Fetch the data; see 'PerformFetch'.

  schedulerHint :: u -> SchedulerHint req
  schedulerHint _ = TryToBatch

  classifyFailure :: u -> req a -> SomeException -> FailureClassification
  classifyFailure _ _ _ = StandardFailure

class DataSourceName (req :: Type -> Type) where
  -- | The name of this 'DataSource', used in tracing and stats. Must
  -- take a dummy request.
  dataSourceName :: Proxy req -> Text

-- The 'ShowP' 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). 'ShowP' 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
  )

-- | Hints to the scheduler about this data source
data SchedulerHint (req :: Type -> Type)
  = TryToBatch
    -- ^ Hold data-source requests while we execute as much as we can, so
    -- that we can hopefully collect more requests to batch.
  | SubmitImmediately
    -- ^ Submit a request via fetch as soon as we have one, don't try to
    -- batch multiple requests.  This is really only useful if the data source
    -- returns BackgroundFetch, otherwise requests to this data source will
    -- be performed synchronously, one at a time.

-- | Hints to the stats module about how to deal with these failures
data FailureClassification
  = StandardFailure
  | IgnoredForStatsFailure

-- | A data source can fetch data in one of four ways.
--
data PerformFetch req
  = SyncFetch  ([BlockedFetch req] -> IO ())
    -- ^ Fully synchronous, returns only when all the data is fetched.
    -- See 'syncFetch' for an example.
  | AsyncFetch ([BlockedFetch req] -> IO () -> IO ())
    -- ^ Asynchronous; performs an arbitrary IO action while the data
    -- is being fetched, but only returns when all the data is
    -- fetched.  See 'asyncFetch' for an example.
  | BackgroundFetch ([BlockedFetch req] -> IO ())
    -- ^ Fetches the data in the background, calling 'putResult' at
    -- any time in the future.  This is the best kind of fetch,
    -- because it provides the most concurrency.

-- | A 'BlockedFetch' is a pair of
--
--   * The request to fetch (with result type @a@)
--
--   * A 'ResultVar' 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 'ResultVar'
-- out, the type system knows that the result type of the request
-- matches the type parameter of the 'ResultVar', so it will let us take the
-- result of the request and store it in the 'ResultVar'.
--
data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a)

-- -----------------------------------------------------------------------------
-- ResultVar

-- | A sink for the result of a data fetch in 'BlockedFetch'
newtype ResultVar a =
  ResultVar (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())
  -- The Bool here is True if result was returned by a child thread,
  -- rather than the main runHaxl thread.  see Note [tracking allocation in
  -- child threads]

mkResultVar
  :: (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())
  -> ResultVar a
mkResultVar = ResultVar

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 io) res = io res False Nothing

putResultWithStats
  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()
putResultWithStats (ResultVar io) res st = io res False (Just st)

putResultWithStatsFromChildThread
  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()
putResultWithStatsFromChildThread (ResultVar io) res st = io res True (Just st)

-- | Like `putResult`, but used to get correct accounting when work is
-- being done in child threads.  This is particularly important for
-- data sources that are using 'BackgroundFetch', The allocation performed
-- in the child thread up to this point will be propagated back to the
-- thread that called 'runHaxl'.
--
-- Note: if you're doing multiple 'putResult' calls in the same thread
-- ensure that only the /last/ one is 'putResultFromChildThread'.  If you
-- make multiple 'putResultFromChildThread' calls, the allocation will be
-- counted multiple times.
--
-- If you are reusing a thread for multiple fetches, you should call
-- @System.Mem.setAllocationCounter 0@ after
-- 'putResultFromChildThread', so that allocation is not counted
-- multiple times.
putResultFromChildThread :: ResultVar a -> Either SomeException a -> IO ()
putResultFromChildThread (ResultVar io) res =  io res True Nothing
  -- see Note [tracking allocation in child threads]

-- | 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

-- -----------------------------------------------------------------------------
-- Fetch templates

stubFetch
  :: (Exception e) => (forall a. r a -> e)
  -> State r -> Flags -> u -> PerformFetch r
stubFetch e _state _flags _si = SyncFetch $ mapM_ (setError e)

-- | 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.

  -> PerformFetch request

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.

  -> PerformFetch request

asyncFetchWithDispatch
  withService dispatch wait enqueue _state _flags _si =
  AsyncFetch $ \requests inner -> withService $ \service -> do
    getResults <- mapM (submitFetch service enqueue) requests
    dispatch service
    inner
    wait service
    sequence_ getResults

asyncFetch withService wait enqueue _state _flags _si =
  AsyncFetch $ \requests inner -> withService $ \service -> do
    getResults <- mapM (submitFetch service enqueue) requests
    inner
    wait service
    sequence_ getResults

syncFetch withService dispatch enqueue _state _flags _si =
  SyncFetch $ \requests -> withService $ \service -> do
  getResults <- mapM (submitFetch service enqueue) requests
  dispatch service
  sequence_ getResults

backgroundFetchSeq, backgroundFetchPar
  :: (forall a. request a -> IO (Either SomeException a))
  -- ^ Run one request, will be run in a background thread

  -> State request
  -- ^ Currently unused.

  -> Flags
  -- ^ Currently unused.

  -> u
  -- ^ Currently unused.

  -> PerformFetch request

backgroundFetchSeq run _state _flags _si =
  BackgroundFetch $ \requests -> do
    (cap, _) <- threadCapability =<< myThreadId
    mask $ \restore -> void $ forkOn cap $ do
      let rethrow = rethrowFromBg requests
      restore (mapM_ runOne requests) `catch` rethrow
      where
        runOne (BlockedFetch request result) = do
          res <- run request
          putResultFromBg result res

backgroundFetchPar run _state _flags _si =
  BackgroundFetch $ \requests -> do
    (cap, _) <- threadCapability =<< myThreadId
    mapM_ (runOneInThread cap) requests
  where
    runOneInThread cap request = do
      mask $ \restore -> void $ forkOn cap $ do
        let rethrow = rethrowFromBg [request]
        restore (runOne request) `catch` rethrow
    runOne (BlockedFetch request result) = do
      res <- run request
      putResultFromBg result res

{- |
A version of 'asyncFetch' (actually 'asyncFetchWithDispatch') that
handles exceptions correctly.  You should use this instead of
'asyncFetch' or 'asyncFetchWithDispatch'.  The danger with
'asyncFetch' is that if an exception is thrown by @withService@, the
@inner@ action won't be executed, and we'll drop some data-fetches in
the same round.

'asyncFetchAcquireRelease' behaves like the following:

> asyncFetchAcquireRelease acquire release dispatch wait enqueue =
>   AsyncFetch $ \requests inner ->
>     bracket acquire release $ \service -> do
>       getResults <- mapM (submitFetch service enqueue) requests
>       dispatch service
>       inner
>       wait service
>       sequence_ getResults

except that @inner@ is run even if @acquire@, @enqueue@, or @dispatch@ throws,
/unless/ an async exception is received.
-}

asyncFetchAcquireRelease
  :: IO service
  -- ^ Resource acquisition for this datasource

  -> (service -> IO ())
  -- ^ Resource release

  -> (service -> IO ())
  -- ^ Dispatch all the pending requests and wait for the results

  -> (service -> IO ())
  -- ^ 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.

  -> PerformFetch request

asyncFetchAcquireRelease
  acquire release dispatch wait enqueue _state _flags _si =
  AsyncFetch $ \requests 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  --  we assume this cannot throw, ensured by performFetches
          case r2 of
            Left err -> throwIO (err :: SomeException)
            Right getResults -> do wait 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 fetchFn (BlockedFetch request result)
  = (putResult result =<<) <$> fetchFn service request

putResultFromBg :: ResultVar a -> Either SomeException a -> IO ()
putResultFromBg result r = do
  -- See comment on putResultFromChildThread
  -- We must set the allocation counter to 0 here in case there are more
  -- results in the batch.
  -- This is safe as we own this thread, and know that there
  -- is no allocation limits set.
  putResultFromChildThread result r
  setAllocationCounter 0

rethrowFromBg :: [BlockedFetch req] -> SomeException -> IO ()
rethrowFromBg requests e = do
  mapM_ (rethrow1bg e) requests
  rethrowAsyncExceptions e
  where
    rethrow1bg e (BlockedFetch _ result) =
      putResultFromBg result (Left e)

backgroundFetchAcquireReleaseMVar
  :: IO service
  -- ^ Resource acquisition for this datasource

  -> (service -> IO ())
  -- ^ Resource release

  -> (service -> Int -> MVar () -> IO ())
  -- ^ Dispatch all the pending requests and when ready trigger the given mvar

  -> (service -> IO ())
  -- ^ Process all requests

  -> (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.

  -> PerformFetch request

backgroundFetchAcquireReleaseMVar
  acquire release dispatch process enqueue _state _flags _si =
  BackgroundFetch $ \requests -> do
    mvar <- newEmptyMVar
    mask $ \restore -> do
      (cap, _) <- threadCapability =<< myThreadId
      service <- acquire
      getResults <- (do
        results <- restore $ mapM (submit service) requests
        -- dispatch takes ownership of mvar, so we call it under `mask` to
        -- ensure that it can safely manage that resource.
        dispatch service cap mvar
        return (sequence_ results)) `onException` release service
      -- now spawn off a background thread to wait on the dispatch to finish
      _tid <- forkOn cap $ do
        takeMVar mvar
          -- todo: it is possible that we would want to do
          -- this processResults on the main scheduler thread for performance
          -- which might reduce thread switching, especially for large batches
          -- but for now this seems to work just fine
        let rethrow = rethrowFromBg requests
        _ <- finally
          (restore (process service >> getResults) `catch` rethrow)
          (release service `catch` rethrow)
        return ()
      return ()
  where
    submit service (BlockedFetch request result) =
      (putResultFromBg result =<<) <$> enqueue service request

{- |
A version of 'backgroundFetchAcquireReleaseMVar' where the dispatch function
is given a 'StablePtr PrimMVar' which is more useful for C based APIs.
-}

backgroundFetchAcquireRelease
  :: IO service
  -- ^ Resource acquisition for this datasource

  -> (service -> IO ())
  -- ^ Resource release

  -> (service -> Int -> StablePtr PrimMVar -> IO ())
  -- ^ Dispatch all the pending requests and when ready trigger the given mvar

  -> (service -> IO ())
  -- ^ Process all requests

  -> (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.

  -> PerformFetch request

backgroundFetchAcquireRelease
  a r dispatch = backgroundFetchAcquireReleaseMVar
                 a
                 r
                 (\s c mvar -> do
                     sp <- newStablePtrPrimMVar mvar
                     dispatch s c sp)


-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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.
--
-- Most users should import "Haxl.Core" instead of importing this
-- module directly.
--
module Haxl.Core.Exception (

  HaxlException(..),

  -- * Exception categories
  InternalError(..),
  internalErrorToException,
  internalErrorFromException,

  LogicError(..),
  logicErrorToException,
  logicErrorFromException,

  LogicBug(..),
  logicBugToException,
  logicBugFromException,

  TransientError(..),
  transientErrorToException,
  transientErrorFromException,

  -- ** Internal exceptions
  CriticalError(..),
  DataSourceError(..),
  NonHaxlException(..),

  -- ** Logic exceptions
  NotFound(..),
  UnexpectedType(..),
  EmptyList(..),
  JSONError(..),
  InvalidParameter(..),
  MonadFail(..),

  -- ** Transient exceptions
  FetchError(..),

  -- * Exception utilities
  asHaxlException,
  MiddleException(..),
  rethrowAsyncExceptions,
  tryWithRethrow,
  ) where

#if __GLASGOW_HASKELL__ >= 808
import Prelude hiding (MonadFail)
#endif
import Control.Exception as Exception
import Data.Aeson
import Data.Binary (Binary)
import Data.Typeable
import Data.Text (Text)
import qualified Data.Text as Text

import Haxl.Core.Util
import GHC.Stack

-- | 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.
--
--   ['LogicBug']       Something is wrong with Haxl client code.
--
--   ['LogicError']     Things that really should be return values, e.g.
--                      NotFound.
--
--   ['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. (MiddleException e)
    => HaxlException
         (Maybe Stack)  -- filled in with the call stack when thrown,
                        -- if PROFILING is on
         e
  deriving (Typeable)

type Stack = [Text]
  -- hopefully this will get more informative in the future

instance Show HaxlException where
  show (HaxlException (Just stk@(_:_)) e) =
    show e ++ '\n' : renderStack (reverse $ map Text.unpack stk)
  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 stk e) = object fields
    where
      fields | Just s@(_:_) <- stk = ("stack" .= s) : rest
             | otherwise = rest
      rest =
        [ "type" .= show (typeOf e)
        , "name" .= eName e
        , "txt"  .= show e
        ]

haxlExceptionToException
  :: (MiddleException e) => e -> SomeException
haxlExceptionToException = toException . HaxlException Nothing

haxlExceptionFromException
  :: (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

data LogicBug = forall e . (Exception e) => LogicBug e
  deriving (Typeable)

deriving instance Show LogicBug

instance Exception LogicBug where
 toException   = haxlExceptionToException
 fromException = haxlExceptionFromException

instance MiddleException LogicBug where
  eName (LogicBug e) = show $ typeOf e

logicBugToException :: (Exception e) => e -> SomeException
logicBugToException = toException . LogicBug

logicBugFromException
  :: (Exception e) => SomeException -> Maybe e
logicBugFromException x = do
  LogicBug a <- fromException x
  cast a

------------------------------------------------------------------------
-- Leaf exceptions. You should throw these. Or make your own.
------------------------------------------------------------------------

-- | Generic \"critical\" exception. Something internal is
-- borked. Panic.
newtype CriticalError = CriticalError Text
  deriving (Typeable, Binary, Eq, Show)

instance Exception CriticalError where
  toException   = internalErrorToException
  fromException = internalErrorFromException

-- | Exceptions that are converted to HaxlException by
-- asHaxlException.  Typically these will be pure exceptions,
-- e.g., the 'error' function in pure code, or a pattern-match
-- failure.
newtype NonHaxlException = NonHaxlException Text
  deriving (Typeable, Binary, Eq, Show)

instance Exception NonHaxlException where
  toException   = internalErrorToException
  fromException = internalErrorFromException

-- | Generic \"something was not found\" exception.
newtype NotFound = NotFound Text
  deriving (Typeable, Binary, Eq, Show)

instance Exception NotFound where
  toException = logicErrorToException
  fromException = logicErrorFromException

-- | Generic \"something had the wrong type\" exception.
newtype UnexpectedType = UnexpectedType Text
  deriving (Typeable, Eq, Show)

instance Exception UnexpectedType where
  toException = logicErrorToException
  fromException = logicErrorFromException

-- | Generic \"input list was empty\" exception.
newtype EmptyList = EmptyList Text
  deriving (Typeable, Eq, Show)

instance Exception EmptyList where
  toException = logicErrorToException
  fromException = logicErrorFromException
  -- TODO: should be a child of LogicBug

-- | Generic \"Incorrect assumptions about JSON data\" exception.
newtype JSONError = JSONError Text
  deriving (Typeable, Eq, Show)

instance Exception JSONError where
  toException = logicErrorToException
  fromException = logicErrorFromException

-- | Generic \"passing some invalid parameter\" exception.
newtype InvalidParameter = InvalidParameter Text
  deriving (Typeable, Eq, Show)

instance Exception InvalidParameter where
  toException = logicErrorToException
  fromException = logicErrorFromException
  -- TODO: should be a child of LogicBug

-- | Generic \"fail was called\" exception.
newtype MonadFail = MonadFail Text
  deriving (Typeable, Eq, Show)

instance Exception MonadFail where
  toException = logicErrorToException
  fromException = logicErrorFromException

-- | Generic transient fetching exceptions.
newtype FetchError = FetchError Text
  deriving (Typeable, Eq, Show)

instance Exception FetchError where
  toException   = transientErrorToException
  fromException = transientErrorFromException

-- | A data source did something wrong
newtype 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 'NonHaxlException', using 'show'.
asHaxlException :: SomeException -> HaxlException
asHaxlException e
  | Just haxl_exception <- fromException e = -- it's a HaxlException
     haxl_exception
  | otherwise =
     HaxlException Nothing (InternalError (NonHaxlException (textShow e)))

-- We must be careful about turning IO monad exceptions into Haxl
-- exceptions.  An IO monad exception will normally propagate right
-- out of runHaxl and terminate the whole computation, whereas a Haxl
-- exception can get dropped on the floor, if it is on the right of
-- <*> and the left side also throws, for example.  So turning an IO
-- monad exception into a Haxl exception is a dangerous thing to do.
-- In particular, we never want to do it for an asynchronous exception
-- (AllocationLimitExceeded, ThreadKilled, etc.), because these are
-- supposed to unconditionally terminate the computation.
--
-- There are three places where we take an arbitrary IO monad exception and
-- turn it into a Haxl exception:
--
--  * wrapFetchInCatch.  Here we want to propagate a failure of the
--    data source to the callers of the data source, but if the
--    failure came from elsewhere (an asynchronous exception), then we
--    should just propagate it
--
--  * cacheResult (cache the results of IO operations): again,
--    failures of the IO operation should be visible to the caller as
--    a Haxl exception, but we exclude asynchronous exceptions from
--    this.

--  * unsafeToHaxlException: assume the caller knows what they're
--    doing, and just wrap all exceptions.
--
rethrowAsyncExceptions :: SomeException -> IO ()
rethrowAsyncExceptions e
  | Just SomeAsyncException{} <- fromException e = Exception.throw e
  | otherwise = return ()

tryWithRethrow :: IO a -> IO (Either SomeException a)
tryWithRethrow io =
  (Right <$> io) `catch` \e -> do rethrowAsyncExceptions e ; return (Left e)