avers 0.0.8 → 0.0.9

raw patch · 5 files changed

+94/−52 lines, 5 filesdep +network-uridep +safedep ~clockdep ~rethinkdb-client-driverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: network-uri, safe

Dependency ranges changed: clock, rethinkdb-client-driver

API changes (from Hackage documentation)

Files

• avers.cabal +8/−5
• benchmark/Benchmark.hs +14/−12
• src/Avers.hs +2/−2
• src/Avers/Storage.hs +7/−2
• src/Avers/Types.hs +63/−31

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

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

@@ -61,8 +61,8 @@   , lookupObjectType    , AversError(..)-  , AversConfig(..)-  , AversState+  , Config(..)+  , Handle   , newState   , strErr   , parseValueAs

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

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