{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- | This module contains all of the basics needed to build a program that
-- interacts with <https://apple.github.io/foundationdb/index.html FoundationDB>.
-- The documentation throughout this library assumes that you have already read
-- the official
-- <https://apple.github.io/foundationdb/developer-guide.html developer guide>.
--
-- = Quick start
--
-- * @import qualified FoundationDB as FDB@
-- * Use 'withFoundationDB' to get a handle to the database.
-- * Use 'runTransaction' and its variants to run a transaction in the IO monad.
-- * Read the docs in "FoundationDB.Transaction" to learn how to use the
--   'Transaction' monad.
-- * 'runTransaction' throws exceptions. 'runTransaction'' returns a sum type.
--   Whichever you choose, all errors you can encounter are defined in
--   "FoundationDB.Error".
-- * See <https://github.com/crclark/foundationdb-haskell/blob/master/tests/Properties/FoundationDB/Transaction.hs#L48 the tests> for basic usage examples.
module FoundationDB
  ( -- * Initialization
    FDB.currentAPIVersion,
    withFoundationDB,
    FoundationDBOptions (..),
    defaultOptions,
    Database,
    apiVersionInUse,

    -- * Transactions
    module FoundationDB.Transaction,

    -- * Errors
    module FoundationDB.Error,

    -- * Helpers for ghci
    startFoundationDB,
    stopFoundationDB,
  )
where

import Control.Concurrent (forkFinally)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Exception
import Control.Monad.Except
import Data.Maybe (fromMaybe)
import FoundationDB.Error
import FoundationDB.Error.Internal
import qualified FoundationDB.Internal.Bindings as FDB
import FoundationDB.Internal.Database
import FoundationDB.Transaction
import System.IO.Unsafe (unsafePerformIO)

-- | This library doesn't support FDB versions earlier than 5.2 (the first
-- open source release).
validateVersion :: Int -> IO ()
validateVersion :: Int -> IO ()
validateVersion Int
v =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
520)
    (Error -> IO ()
forall a e. Exception e => e -> a
throw (FDBHsError -> Error
Error FDBHsError
UnsupportedAPIVersion))

#if FDB_API_VERSION < 610
initCluster :: FilePath -> IO FDB.Cluster
initCluster fp = do
  futureCluster <- FDB.createCluster fp
  fdbThrowing' $ FDB.futureBlockUntilReady futureCluster
  fdbThrowing $ FDB.futureGetCluster futureCluster

withCluster :: Maybe FilePath -> (FDB.Cluster -> IO a) -> IO a
withCluster mfp =
  bracket (initCluster (fromMaybe "" mfp))
          FDB.clusterDestroy

initDB :: FDB.Cluster -> IO FDB.DatabasePtr
initDB cluster = do
  futureDB <- FDB.clusterCreateDatabase cluster
  fdbThrowing' $ FDB.futureBlockUntilReady futureDB
  fdbThrowing $ FDB.futureGetDatabase futureDB

withDatabase :: FoundationDBOptions -> (Database -> IO a) -> IO a
withDatabase opts@FoundationDBOptions{clusterFile} f =
  withCluster clusterFile $ \ cluster ->
    bracket (fmap (flip Database opts) $ initDB cluster)
            (FDB.databaseDestroy . databasePtr)
            f
#else
withDatabase :: FoundationDBOptions -> (Database -> IO a) -> IO a
withDatabase :: FoundationDBOptions -> (Database -> IO a) -> IO a
withDatabase opts :: FoundationDBOptions
opts@FoundationDBOptions{Maybe FilePath
clusterFile :: FoundationDBOptions -> Maybe FilePath
clusterFile :: Maybe FilePath
clusterFile} =
  IO Database -> (Database -> IO ()) -> (Database -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((DatabasePtr -> Database) -> IO DatabasePtr -> IO Database
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DatabasePtr -> FoundationDBOptions -> Database)
-> FoundationDBOptions -> DatabasePtr -> Database
forall a b c. (a -> b -> c) -> b -> a -> c
flip DatabasePtr -> FoundationDBOptions -> Database
Database FoundationDBOptions
opts)
           (IO DatabasePtr -> IO Database) -> IO DatabasePtr -> IO Database
forall a b. (a -> b) -> a -> b
$ IO (CFDBError, DatabasePtr) -> IO DatabasePtr
forall a. IO (CFDBError, a) -> IO a
fdbThrowing
           (IO (CFDBError, DatabasePtr) -> IO DatabasePtr)
-> IO (CFDBError, DatabasePtr) -> IO DatabasePtr
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (CFDBError, DatabasePtr)
FDB.createDatabase (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
clusterFile))
          (DatabasePtr -> IO ()
FDB.databaseDestroy (DatabasePtr -> IO ())
-> (Database -> DatabasePtr) -> Database -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> DatabasePtr
databasePtr)
#endif

-- | Handles correctly starting up the network connection to the DB.
-- Can only be called once per process! Throws an 'Error' if any part of
-- setting up the connection to FoundationDB fails.
withFoundationDB ::
  FoundationDBOptions ->
  (Database -> IO a) ->
  IO a
withFoundationDB :: FoundationDBOptions -> (Database -> IO a) -> IO a
withFoundationDB opts :: FoundationDBOptions
opts@FoundationDBOptions {Int
[DatabaseOption]
[NetworkOption]
Maybe FilePath
databaseOptions :: FoundationDBOptions -> [DatabaseOption]
networkOptions :: FoundationDBOptions -> [NetworkOption]
apiVersion :: FoundationDBOptions -> Int
databaseOptions :: [DatabaseOption]
networkOptions :: [NetworkOption]
clusterFile :: Maybe FilePath
apiVersion :: Int
clusterFile :: FoundationDBOptions -> Maybe FilePath
..} Database -> IO a
m = do
  Int -> IO ()
validateVersion Int
apiVersion
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  IO CFDBError -> IO ()
fdbThrowing' (IO CFDBError -> IO ()) -> IO CFDBError -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO CFDBError
FDB.selectAPIVersion Int
apiVersion
  [NetworkOption] -> (NetworkOption -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NetworkOption]
networkOptions (IO CFDBError -> IO ()
fdbThrowing' (IO CFDBError -> IO ())
-> (NetworkOption -> IO CFDBError) -> NetworkOption -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkOption -> IO CFDBError
FDB.networkSetOption)
  IO CFDBError -> IO ()
fdbThrowing' IO CFDBError
FDB.setupNetwork
  MVar () -> IO ()
start MVar ()
done
  IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
finally (FoundationDBOptions -> (Database -> IO a) -> IO a
forall a. FoundationDBOptions -> (Database -> IO a) -> IO a
withDatabase FoundationDBOptions
opts Database -> IO a
run) (MVar () -> IO ()
forall b. MVar b -> IO b
stop MVar ()
done)
  where
    start :: MVar () -> IO ()
start MVar ()
done = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO CFDBError
-> (Either SomeException CFDBError -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally IO CFDBError
FDB.runNetwork (\Either SomeException CFDBError
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
    stop :: MVar b -> IO b
stop MVar b
done = IO CFDBError
FDB.stopNetwork IO CFDBError -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar b -> IO b
forall b. MVar b -> IO b
takeMVar MVar b
done
    run :: Database -> IO a
run db :: Database
db@Database {DatabasePtr
databasePtr :: DatabasePtr
databasePtr :: Database -> DatabasePtr
databasePtr} = do
      [DatabaseOption] -> (DatabaseOption -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DatabaseOption]
databaseOptions (IO CFDBError -> IO ()
fdbThrowing' (IO CFDBError -> IO ())
-> (DatabaseOption -> IO CFDBError) -> DatabaseOption -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabasePtr -> DatabaseOption -> IO CFDBError
FDB.databaseSetOption DatabasePtr
databasePtr)
      Database -> IO a
m Database
db

startFoundationDBGlobalLock :: MVar ()
startFoundationDBGlobalLock :: MVar ()
startFoundationDBGlobalLock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
{-# NOINLINE startFoundationDBGlobalLock #-}

-- | Starts up FoundationDB. You must call 'stopFoundationDB' before your
-- program terminates. It's recommended that you use 'withFoundationDB' instead,
-- since it handles cleanup. This function is only intended to be used in GHCi.
-- Can only be called once per process! Throws an 'Error' if any part of
-- setting up the connection FoundationDB fails.
startFoundationDB ::
  FoundationDBOptions ->
  IO Database
startFoundationDB :: FoundationDBOptions -> IO Database
startFoundationDB opts :: FoundationDBOptions
opts@FoundationDBOptions {Int
[DatabaseOption]
[NetworkOption]
Maybe FilePath
databaseOptions :: [DatabaseOption]
networkOptions :: [NetworkOption]
clusterFile :: Maybe FilePath
apiVersion :: Int
databaseOptions :: FoundationDBOptions -> [DatabaseOption]
networkOptions :: FoundationDBOptions -> [NetworkOption]
apiVersion :: FoundationDBOptions -> Int
clusterFile :: FoundationDBOptions -> Maybe FilePath
..} = do
  Int -> IO ()
validateVersion Int
apiVersion
  IO CFDBError -> IO ()
fdbThrowing' (IO CFDBError -> IO ()) -> IO CFDBError -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO CFDBError
FDB.selectAPIVersion Int
apiVersion
  [NetworkOption] -> (NetworkOption -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NetworkOption]
networkOptions (IO CFDBError -> IO ()
fdbThrowing' (IO CFDBError -> IO ())
-> (NetworkOption -> IO CFDBError) -> NetworkOption -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkOption -> IO CFDBError
FDB.networkSetOption)
  IO CFDBError -> IO ()
fdbThrowing' IO CFDBError
FDB.setupNetwork
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO CFDBError
-> (Either SomeException CFDBError -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally
      IO CFDBError
FDB.runNetwork
      (\Either SomeException CFDBError
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
startFoundationDBGlobalLock ())
#if FDB_API_VERSION < 610
  cluster <- initCluster (fromMaybe "" clusterFile)
  db <- initDB cluster
#else
  DatabasePtr
db <- IO (CFDBError, DatabasePtr) -> IO DatabasePtr
forall a. IO (CFDBError, a) -> IO a
fdbThrowing (IO (CFDBError, DatabasePtr) -> IO DatabasePtr)
-> IO (CFDBError, DatabasePtr) -> IO DatabasePtr
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (CFDBError, DatabasePtr)
FDB.createDatabase (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
clusterFile)
#endif
  [DatabaseOption] -> (DatabaseOption -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DatabaseOption]
databaseOptions (IO CFDBError -> IO ()
fdbThrowing' (IO CFDBError -> IO ())
-> (DatabaseOption -> IO CFDBError) -> DatabaseOption -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabasePtr -> DatabaseOption -> IO CFDBError
FDB.databaseSetOption DatabasePtr
db)
  Database -> IO Database
forall (m :: * -> *) a. Monad m => a -> m a
return (Database :: DatabasePtr -> FoundationDBOptions -> Database
Database {databasePtr :: DatabasePtr
databasePtr = DatabasePtr
db, databaseFoundationDBOptions :: FoundationDBOptions
databaseFoundationDBOptions = FoundationDBOptions
opts})

-- | Stops FoundationDB. For use with 'startFoundationDB'.
stopFoundationDB :: IO ()
stopFoundationDB :: IO ()
stopFoundationDB = IO CFDBError
FDB.stopNetwork IO CFDBError -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO ()
forall b. MVar b -> IO b
takeMVar MVar ()
startFoundationDBGlobalLock