Use generated options more

bindingtester/Main.hs

@@ -12,9 +12,8 @@ import FoundationDB
 
 go :: ByteString -> Int -> Maybe FilePath -> IO ()
 go prefix ver mpath =
- withFoundationDB ver mpath $ \case
- Left err -> error (show err)
- Right database -> runTests ver prefix database
+ withFoundationDB (FoundationDBOptions ver mpath [] []) $ \ database ->
+ runTests ver prefix database
 
 main :: IO ()
 main = do

bindingtester/StackMachine.hs

@@ -30,7 +30,7 @@ import GHC.Exts(IsList(..))
 import Text.Printf (printf)
 
 import FoundationDB
-import FoundationDB.Error
+import FoundationDB.Error.Internal
 import FoundationDB.Transaction
 import FoundationDB.Layer.Tuple
 import FoundationDB.Internal.Bindings ( getCFDBError
@@ -272,7 +272,7 @@ popRangeSelector = popN 10 >>= \case
  _ -> return Nothing
 
 popAtomicOp :: MonadState StackMachine m
- => m (Maybe (AtomicOp, ByteString, ByteString))
+ => m (Maybe (ByteString -> Opts.MutationType, ByteString, ByteString))
 popAtomicOp = popN 3 >>= \case
  Just [ StackBytes opBytes
  , StackBytes k
@@ -281,19 +281,19 @@ popAtomicOp = popN 3 >>= \case
  Nothing -> error $ "unknown op: " ++ show opBytes
  _ -> return Nothing
 
- where parse "ADD" = Just Add
- parse "AND" = Just And
- parse "BIT_AND" = Just BitAnd
- parse "OR" = Just Or
- parse "BIT_OR" = Just BitOr
- parse "XOR" = Just Xor
- parse "BIT_XOR" = Just BitXor
- parse "MAX" = Just Max
- parse "MIN" = Just Min
- parse "SET_VERSIONSTAMPED_KEY" = Just SetVersionstampedKey
- parse "SET_VERSIONSTAMPED_VALUE" = Just SetVersionstampedValue
- parse "BYTE_MIN" = Just ByteMin
- parse "BYTE_MAX" = Just ByteMax
+ where parse "ADD" = Just Opts.add
+ parse "AND" = Just Opts.and
+ parse "BIT_AND" = Just Opts.bitAnd
+ parse "OR" = Just Opts.or
+ parse "BIT_OR" = Just Opts.bitOr
+ parse "XOR" = Just Opts.xor
+ parse "BIT_XOR" = Just Opts.bitXor
+ parse "MAX" = Just Opts.max
+ parse "MIN" = Just Opts.min
+ parse "SET_VERSIONSTAMPED_KEY" = Just Opts.setVersionstampedKey
+ parse "SET_VERSIONSTAMPED_VALUE" = Just Opts.setVersionstampedValue
+ parse "BYTE_MIN" = Just Opts.byteMin
+ parse "BYTE_MAX" = Just Opts.byteMax
  parse _ = Nothing
 
 rangeList :: RangeResult -> Transaction (Seq (ByteString, ByteString))
@@ -517,8 +517,8 @@ step i ClearRangeStartsWith = pop >>= \case
 
 step i AtomicOp = popAtomicOp >>= \case
  Just (op, k, v) ->
- bubblingError i (atomicOp op k v) return
- x@Nothing -> errorUnexpectedState i x AtomicOp
+ bubblingError i (atomicOp k (op v)) return
+ Nothing -> errorUnexpectedState i ("Nothing" :: String) AtomicOp
 
 step i ReadConflictRange = popN 2 >>= \case
  Just [ StackBytes begin

foundationdb-haskell.cabal

@@ -59,6 +59,7 @@ library
  -- Modules exported by the library.
  exposed-modules: FoundationDB
  , FoundationDB.Error
+ , FoundationDB.Error.Internal
  , FoundationDB.Internal.Bindings
  , FoundationDB.Layer.Directory
  , FoundationDB.Layer.Directory.Internal
@@ -112,7 +113,7 @@ library
 
  c-sources: cbits/fdbc_wrapper.c
 
- ghc-options: -Wall
+ ghc-options: -Wall -O2
 
 executable generate-options
  if flag(with-generate-options)

generate-options/Generate.hs

@@ -24,7 +24,7 @@ lowerCamelCase :: String -> String
 lowerCamelCase [] = []
 lowerCamelCase str =
  let (x:xs) = splitBy (== '_') str
- in (map toLower x) ++ (concatMap capitalize xs)
+ in map toLower x ++ concatMap capitalize xs
 
 ty :: String -> Type ()
 ty str = TyCon () (UnQual () (Ident () str))
@@ -48,6 +48,9 @@ bytesOptName o = optName o "Bytes"
 flagOptName :: FdbOptionType -> String
 flagOptName o = optName o "Flag"
 
+inst :: String -> InstRule ()
+inst qn = IRule () Nothing Nothing (IHCon () (UnQual () (Ident () qn)))
+
 optionDataDecl :: FdbOptionType -> Decl ()
 optionDataDecl o@FdbOptionType{..} =
  DataDecl ()
@@ -58,7 +61,7 @@ optionDataDecl o@FdbOptionType{..} =
  , con (intOptName o) [ty "Int", ty "Int"]
  , con (bytesOptName o) [ty "Int", ty "ByteString"]
  , con (flagOptName o) [ty "Int"]]
- []
+ [Deriving () Nothing [inst "Show", inst "Read", inst "Eq", inst "Ord"]]
 
 simpleBind :: String -> [Pat ()] -> Exp () -> Decl ()
 simpleBind fnName pats rhs =
@@ -143,9 +146,10 @@ generateOptionType o@FdbOptionType{..} =
 generateOptionsModule :: [FdbOptionType] -> String
 generateOptionsModule tys =
  "{-# OPTIONS_GHC -fno-warn-missing-signatures #-}\n"
- ++ "-- NOTE: This file is generated from fdb.options\n"
- ++ "-- https://github.com/apple/foundationdb/blob/master/fdbclient/vexillographer/fdb.options\n"
- ++ "-- by the generate-options executable in this project.\n\n"
- ++ "module FoundationDB.Options where\n\n"
+ ++ "-- | NOTE: This file is generated from <https://github.com/apple/foundationdb/blob/master/fdbclient/vexillographer/fdb.options fdb.options>\n"
+ ++ "-- by the generate-options executable in this project.\n"
+ ++ "-- All documentation on the individual options in this namespace comes\n"
+ ++ "-- from FoundationDB's documentation in @fdb.options@.\n"
+ ++ "module FoundationDB.Options where\n"
  ++ "import Data.ByteString.Char8 (ByteString)\n\n"
  ++ unlines (map generateOptionType tys)

src/FoundationDB.hs

@@ -3,13 +3,15 @@
 
 
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module FoundationDB (
  -- * Initialization
  FDB.currentAPIVersion
  , withFoundationDB
+ , FoundationDBOptions(..)
+ , defaultOptions
  , FDB.Database
  -- * Transactions
  , Transaction
@@ -58,8 +60,6 @@ module FoundationDB (
  , FirstGreaterThan
  , FirstGreaterOrEq)
  , offset
- -- * Atomic operations
- , AtomicOp(..)
  -- * Errors
  , Error(..)
  , CError(..)
@@ -75,60 +75,72 @@ 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.Options (NetworkOption(..), DatabaseOption(..))
 import FoundationDB.Transaction
 import System.IO.Unsafe (unsafePerformIO)
 
 
-initCluster :: FilePath -> IO (Either Error FDB.Cluster)
+initCluster :: FilePath -> IO FDB.Cluster
 initCluster fp = do
  futureCluster <- FDB.createCluster fp
- runExceptT $ do
- fdbExcept' $ FDB.futureBlockUntilReady futureCluster
- fdbExcept $ FDB.futureGetCluster futureCluster
+ fdbThrowing' $ FDB.futureBlockUntilReady futureCluster
+ fdbThrowing $ FDB.futureGetCluster futureCluster
 
-withCluster :: Maybe FilePath -> (Either Error FDB.Cluster -> IO a) -> IO a
+withCluster :: Maybe FilePath -> (FDB.Cluster -> IO a) -> IO a
 withCluster mfp =
  bracket (initCluster (fromMaybe "" mfp))
- (either (const (return ())) FDB.clusterDestroy)
+ FDB.clusterDestroy
 
-initDB :: FDB.Cluster -> IO (Either Error FDB.Database)
+initDB :: FDB.Cluster -> IO FDB.Database
 initDB cluster = do
  futureDB <- FDB.clusterCreateDatabase cluster
- runExceptT $ do
- fdbExcept' $ FDB.futureBlockUntilReady futureDB
- fdbExcept $ FDB.futureGetDatabase futureDB
+ fdbThrowing' $ FDB.futureBlockUntilReady futureDB
+ fdbThrowing $ FDB.futureGetDatabase futureDB
 
-withDatabase :: Maybe FilePath -> (Either Error FDB.Database -> IO a) -> IO a
+withDatabase :: Maybe FilePath -> (FDB.Database -> IO a) -> IO a
 withDatabase clusterFile f =
- withCluster clusterFile $ \case
- Left err -> f $ Left err
- Right cluster -> bracket (initDB cluster)
- (either (const (return ())) FDB.databaseDestroy)
- f
-
--- TODO: check that we support the desired API version and bail out otherwise.
+ withCluster clusterFile $ \ cluster ->
+ bracket (initDB cluster)
+ FDB.databaseDestroy
+ f
+
+data FoundationDBOptions = FoundationDBOptions
+ { apiVersion :: Int
+ -- ^ Desired API version. See 'currentAPIVersion' for the latest
+ -- version installed on your system.
+ , clusterFile :: Maybe FilePath
+ -- ^ Path to your @fdb.cluster@ file. If 'Nothing', uses
+ -- default location.
+ , networkOptions :: [NetworkOption]
+ -- ^ Additional network options. Each will be set in order.
+ , databaseOptions :: [DatabaseOption]
+ -- ^ Additional database options. Each will be set in order.
+ } deriving (Show, Eq, Ord)
+
+defaultOptions :: FoundationDBOptions
+defaultOptions = FoundationDBOptions FDB.currentAPIVersion Nothing [] []
 
 -- | Handles correctly starting up the network connection to the DB.
--- Can only be called once per process!
-withFoundationDB :: Int
- -- ^ Desired API version. See 'currentAPIVersion' for the
- -- latest version installed on your system.
- -> Maybe FilePath
- -- ^ Path to your @fdb.cluster@ file. If 'Nothing', uses
- -- default location.
- -> (Either Error FDB.Database -> IO a)
+-- Can only be called once per process! Throws an 'Error' if any part of
+-- setting up the connection FoundationDB fails.
+withFoundationDB :: FoundationDBOptions
+ -> (FDB.Database -> IO a)
  -> IO a
-withFoundationDB version clusterFile m = do
+withFoundationDB FoundationDBOptions{..} m = do
  done <- newEmptyMVar
- fdbThrowing $ FDB.selectAPIVersion version
- fdbThrowing FDB.setupNetwork
+ fdbThrowing' $ FDB.selectAPIVersion apiVersion
+ forM_ networkOptions (fdbThrowing' . FDB.networkSetOption)
+ fdbThrowing' FDB.setupNetwork
  start done
- finally (withDatabase clusterFile m) (stop done)
+ finally (withDatabase clusterFile run) (stop done)
  where
  start done = void $ forkFinally FDB.runNetwork (\_ -> putMVar done ())
  stop done = FDB.stopNetwork >> takeMVar done
+ run db = do
+ forM_ databaseOptions (fdbThrowing' . FDB.databaseSetOption db)
+ m db
 
 startFoundationDBGlobalLock :: MVar ()
 startFoundationDBGlobalLock = unsafePerformIO newEmptyMVar
@@ -137,25 +149,20 @@ startFoundationDBGlobalLock = unsafePerformIO newEmptyMVar
 -- | 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!
-startFoundationDB :: Int
- -- ^ Desired API version.
- -> Maybe FilePath
- -- ^ Cluster file. 'Nothing' uses the default.
- -> IO (Either Error FDB.Database)
-startFoundationDB v mfp = do
- fdbThrowing $ FDB.selectAPIVersion v
- fdbThrowing FDB.setupNetwork
+-- Can only be called once per process! Throws an 'Error' if any part of
+-- setting up the connection FoundationDB fails.
+startFoundationDB :: FoundationDBOptions
+ -> IO FDB.Database
+startFoundationDB FoundationDBOptions{..} = do
+ fdbThrowing' $ FDB.selectAPIVersion apiVersion
+ forM_ networkOptions (fdbThrowing' . FDB.networkSetOption)
+ fdbThrowing' FDB.setupNetwork
  void $ forkFinally FDB.runNetwork
  (\_ -> putMVar startFoundationDBGlobalLock ())
- mcluster <- initCluster (fromMaybe "" mfp)
- case mcluster of
- Left e -> return $ Left e
- Right c -> do
- mdb <- initDB c
- case mdb of
- Left e -> return $ Left e
- Right db -> return $ Right db
+ cluster <- initCluster (fromMaybe "" clusterFile)
+ db <- initDB cluster
+ forM_ databaseOptions (fdbThrowing' . FDB.databaseSetOption db)
+ return db
 
 stopFoundationDB :: IO ()
 stopFoundationDB = FDB.stopNetwork >> takeMVar startFoundationDBGlobalLock