diff --git a/avers.cabal b/avers.cabal --- a/avers.cabal +++ b/avers.cabal @@ -1,5 +1,5 @@ name: avers -version: 0.0.8 +version: 0.0.9 license: GPL-3 license-file: LICENSE author: Tomas Carnecky @@ -51,11 +51,13 @@ , attoparsec , base <= 9999 , bytestring - , clock >= 0.4.4.0 && < 0.5 + , clock , containers , filepath , mtl , network + , network-uri + , safe , stm , template-haskell , text @@ -70,7 +72,7 @@ , cryptohash , inflections , resource-pool - , rethinkdb-client-driver >= 0.0.17 + , rethinkdb-client-driver >= 0.0.19 , scrypt @@ -91,7 +93,8 @@ , mtl , criterion , resource-pool - , rethinkdb-client-driver >= 0.0.11 + , rethinkdb-client-driver >= 0.0.19 + , network-uri , text @@ -116,7 +119,7 @@ , inflections , mtl , resource-pool - , rethinkdb-client-driver >= 0.0.11 + , rethinkdb-client-driver >= 0.0.19 , scrypt , stm , text diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -18,6 +18,8 @@ import System.Environment import System.IO.Unsafe +import Network.URI + import Criterion.Main import Avers @@ -39,29 +41,29 @@ } -databaseConfig :: IO (Text, Text) +databaseConfig :: IO URI databaseConfig = do - host <- fromMaybe "localhost" <$> lookupEnv "RETHINKDB" - database <- fromMaybe "test" <$> lookupEnv "DATABASE" - return (T.pack host, T.pack database) + uri <- fromMaybe "//localhost/test" <$> lookupEnv "RETHINKDB" + return $ fromJust $ parseRelativeReference uri -mkBenchmarkHandle :: IO AversState +mkBenchmarkHandle :: IO Handle mkBenchmarkHandle = do - (host, db) <- databaseConfig - let config = AversConfig host db undefined [SomeObjectType dummyObjectType] (\_ _ -> return ()) - newState config + dbURI <- databaseConfig + let config = Config dbURI undefined [SomeObjectType dummyObjectType] (\_ _ -> return ()) + Right h <- newState config + return h -{-# NOINLINE aversStateRef #-} -aversStateRef :: IORef AversState -aversStateRef = unsafePerformIO $ do +{-# NOINLINE handleRef #-} +handleRef :: IORef Handle +handleRef = unsafePerformIO $ do newIORef =<< mkBenchmarkHandle benchAvers :: Avers a -> IO () benchAvers m = do - h <- readIORef aversStateRef + h <- readIORef handleRef void $ evalAvers h m diff --git a/src/Avers.hs b/src/Avers.hs --- a/src/Avers.hs +++ b/src/Avers.hs @@ -61,8 +61,8 @@ , lookupObjectType , AversError(..) - , AversConfig(..) - , AversState + , Config(..) + , Handle , newState , strErr , parseValueAs diff --git a/src/Avers/Storage.hs b/src/Avers/Storage.hs --- a/src/Avers/Storage.hs +++ b/src/Avers/Storage.hs @@ -21,6 +21,7 @@ import Control.Monad.State import Control.Monad.Except +import Data.Pool import Data.Char import Data.Monoid import Data.Maybe @@ -467,7 +468,10 @@ saveBlobContent :: Blob -> BL.ByteString -> Avers () saveBlobContent Blob{..} content = do cfg <- gets config - liftIO $ (putBlob cfg) blobId blobContentType content + res <- liftIO $ (putBlob cfg) blobId blobContentType content + case res of + Left e -> throwError e + Right _ -> return () saveSession :: Session -> Avers () @@ -649,7 +653,8 @@ createTable :: Text -> [SomeIndex] -> Avers () createTable name indices = do let table = R.Table Nothing $ R.lift name - db <- fmap R.Database $ fmap R.lift $ fmap databaseName $ gets config + pool <- gets databaseHandlePool + db <- liftIO $ withResource pool $ \handle -> pure $ R.handleDatabase handle tables <- runQuery $ R.ListTables db when (name `V.notElem` tables) $ do diff --git a/src/Avers/Types.hs b/src/Avers/Types.hs --- a/src/Avers/Types.hs +++ b/src/Avers/Types.hs @@ -7,6 +7,9 @@ module Avers.Types where + +import Safe + import Control.Applicative import Control.Monad.Except @@ -25,6 +28,7 @@ import qualified Data.Map as M import Data.Monoid +import Data.Maybe import Data.Char import Data.Attoparsec.Text @@ -34,6 +38,8 @@ import Data.Aeson (Value(String)) import Data.Aeson.Types (parseEither) +import Network.URI + import qualified Database.RethinkDB as R import Database.RethinkDB.TH @@ -499,21 +505,18 @@ -- | Configuration of the 'Avers' monad. -data AversConfig = AversConfig - - { databaseHost :: !Text - -- ^ The hostname where RethinkDB is running. The port is currently not - -- configurable. +data Config = Config - , databaseName :: !Text - -- ^ RethinkDB supports multiple databases. This is the name of the one - -- which should be used. + { databaseURI :: !URI + -- ^ 'URI' which describes the connection details to the RethinkDB + -- database. The 'URI' *MUST* include at least the hostname ('uriRegName') + -- and database name ('uriPath' without the leading slash). The port + -- ('uriPort') and credentials ('uriUserInfo') *MAY* be left empty. + -- in that case the default port will be used. - , putBlob :: BlobId -> Text -> ByteString -> IO () + , putBlob :: BlobId -> Text -> ByteString -> IO (Either AversError ()) -- ^ Function which saves the given blob in the blob store. This can be - -- the local filesystem or an external services such as Amazon S3. - -- - -- TODO: Propagate errors back to the caller. + -- the local filesystem or an external service such as Amazon S3. , objectTypes :: ![SomeObjectType] -- ^ All the object types which Avers knows about. @@ -523,9 +526,30 @@ -- a measurement. } +databaseHost :: Config -> Either AversError Text +databaseHost Config{..} = maybe (Left $ AversError "databaseHost: not given") Right $ do + auth <- uriAuthority databaseURI + return $ T.pack $ uriRegName auth -data AversState = AversState - { config :: !AversConfig +databasePort :: Config -> Int +databasePort Config{..} = fromMaybe R.defaultPort $ do + auth <- uriAuthority databaseURI + readMay $ uriPort auth + +databaseAuth :: Config -> Maybe Text +databaseAuth Config{..} = do + auth <- uriAuthority databaseURI + return $ T.pack $ uriUserInfo auth + +extractDatabaseName :: Config -> Either AversError Text +extractDatabaseName Config{..} = case tail $ uriPath $ databaseURI of + "" -> Left $ AversError "databaseName: not given" + db -> Right $ T.pack db + + + +data Handle = Handle + { config :: !Config -- ^ A reference to the config, just in case we need it. , databaseHandlePool :: !(Pool R.Handle) @@ -538,21 +562,25 @@ -newDatabaseHandlePool :: AversConfig -> IO (Pool R.Handle) -newDatabaseHandlePool AversConfig{..} = - createPool create destroy numStripes idleTime maxResources +newDatabaseHandlePool :: Config -> Text -> ExceptT AversError IO (Pool R.Handle) +newDatabaseHandlePool config db = do + host <- ExceptT $ pure $ databaseHost config + let port = databasePort config + let mbAuth = databaseAuth config + lift $ createPool (create host port mbAuth) destroy numStripes idleTime maxResources + where - create = do + create host port mbAuth = do putStrLn $ mconcat [ "Creating a new RethinkDB handle to " - , T.unpack databaseHost - , ":28015" + , T.unpack host + , show port , " database " - , T.unpack databaseName + , T.unpack db ] - R.newHandle databaseHost 28015 Nothing (R.Database (R.lift databaseName)) + R.newHandle host port mbAuth (R.Database (R.lift db)) destroy handle = do putStrLn "Closing RethinkDB handle" @@ -563,17 +591,21 @@ maxResources = 10 -newState :: AversConfig -> IO AversState -newState config = do - AversState - <$> pure config - <*> newDatabaseHandlePool config - <*> newTVarIO M.empty +newState :: Config -> IO (Either AversError Handle) +newState config = runExceptT $ do + databaseName <- ExceptT $ pure $ extractDatabaseName config + databaseHandlePool <- newDatabaseHandlePool config databaseName + recentRevisionCache <- lift $ newTVarIO M.empty + Handle + <$> (pure config) + <*> (pure databaseHandlePool) + <*> (pure recentRevisionCache) + newtype Avers a = Avers - { runAvers :: StateT AversState (ExceptT AversError IO) a - } deriving (Functor, Applicative, Monad, MonadIO, MonadError AversError, MonadState AversState) + { runAvers :: StateT Handle (ExceptT AversError IO) a + } deriving (Functor, Applicative, Monad, MonadIO, MonadError AversError, MonadState Handle) class (Monad m) => MonadAvers m where liftAvers :: Avers a -> m a @@ -584,7 +616,7 @@ instance MonadAvers m => MonadAvers (StateT s m) where liftAvers = lift . liftAvers -evalAvers :: AversState -> Avers a -> IO (Either AversError a) +evalAvers :: Handle -> Avers a -> IO (Either AversError a) evalAvers h m = runExceptT $ evalStateT (runAvers m) h