Use stm-containers Map in memory for concurrent read/writes

This commit is contained in:
Julian Ospald 2022-05-04 20:27:05 +02:00
parent 6fa9746f36
commit 7d52862780
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
5 changed files with 30 additions and 11 deletions

View File

@ -3,7 +3,7 @@
module Main where module Main where
import Soostone ( app, middleWare, AppState(AppState, sqliteFile) ) import Soostone ( app, middleWare, AppState(AppState, sqliteFile, stmMap) )
import Control.Monad ( void, when ) import Control.Monad ( void, when )
import Data.Version (showVersion) import Data.Version (showVersion)
@ -34,6 +34,7 @@ import Prometheus ( register )
import Prometheus.Metric.GHC ( ghcMetrics ) import Prometheus.Metric.GHC ( ghcMetrics )
import Prometheus.Metric.Proc ( procMetrics ) import Prometheus.Metric.Proc ( procMetrics )
import Text.Read ( readEither ) import Text.Read ( readEither )
import qualified StmContainers.Map as SM
versioner :: Parser (a -> a) versioner :: Parser (a -> a)
@ -98,7 +99,8 @@ main = do
case serverCommand of case serverCommand of
Run ServerConfig{..} -> do Run ServerConfig{..} -> do
when (sqliteDB == ":memory:") $ fail "In-memory DB is not supported!" when (sqliteDB == ":memory:") $ fail "In-memory DB is not supported!"
let appState = AppState { sqliteFile = sqliteDB } m <- SM.newIO
let appState = AppState { sqliteFile = sqliteDB, stmMap = m }
void $ register ghcMetrics void $ register ghcMetrics
void $ register procMetrics void $ register procMetrics
run serverPort (middleWare $ app appState) run serverPort (middleWare $ app appState)

View File

@ -27,7 +27,7 @@ app !s = \req resp ->
serve api (hoistServer api nt soostoneServer) req resp serve api (hoistServer api nt soostoneServer) req resp
where where
nt :: AppM a -> Handler a nt :: AppM a -> Handler a
nt x = flip runReaderT s $ runAppM x nt x = flip runReaderT s $ runAppM x
middleWare :: Middleware middleWare :: Middleware

View File

@ -4,7 +4,7 @@
module Soostone.Handlers where module Soostone.Handlers where
import Soostone.Types import Soostone.Types
( AppState(AppState, sqliteFile), AppM, Count(..), Key ) ( AppState(AppState, sqliteFile, stmMap), AppM, Count(..), Key )
import Data.Functor ( ($>) ) import Data.Functor ( ($>) )
import Database.SQLite.Simple import Database.SQLite.Simple
@ -18,10 +18,20 @@ import Database.SQLite.Simple
import Control.Monad.Catch ( finally ) import Control.Monad.Catch ( finally )
import Control.Monad.Reader ( ask ) import Control.Monad.Reader ( ask )
import Control.Monad.IO.Class ( liftIO ) import Control.Monad.IO.Class ( liftIO )
import qualified StmContainers.Map as SM
import GHC.Conc (atomically)
submitKeyHandler :: Key -> AppM () submitKeyHandler :: Key -> AppM ()
submitKeyHandler key = withSQLiteCon $ \con -> do submitKeyHandler key = do
AppState{..} <- ask
liftIO $ atomically $ do
SM.lookup key stmMap >>= \case
Just v -> SM.insert (v + 1) key stmMap
Nothing -> SM.insert 1 key stmMap
{--
withSQLiteCon $ \con -> do
r <- liftIO $ withImmediateTransaction con $ do r <- liftIO $ withImmediateTransaction con $ do
queryNamed @Count con "SELECT count FROM keys WHERE key=:key" [":key" := key] >>= \case queryNamed @Count con "SELECT count FROM keys WHERE key=:key" [":key" := key] >>= \case
[] -> executeNamed con "INSERT INTO keys (key, count) VALUES (:key, :count)" [":key" := key, ":count" := Count 1] $> Right () [] -> executeNamed con "INSERT INTO keys (key, count) VALUES (:key, :count)" [":key" := key, ":count" := Count 1] $> Right ()
@ -30,14 +40,16 @@ submitKeyHandler key = withSQLiteCon $ \con -> do
case r of case r of
Right _ -> pure () Right _ -> pure ()
Left e -> fail e -- internal error Left e -> fail e -- internal error
--}
countKeyHandler :: Key -> AppM Count countKeyHandler :: Key -> AppM Count
countKeyHandler key = withSQLiteCon $ \con -> do countKeyHandler key = do
liftIO (queryNamed @Count con "SELECT count FROM keys WHERE key=:key" [":key" := key]) >>= \case AppState{..} <- ask
[] -> return (Count 0) liftIO $ atomically $ do
[c] -> pure c SM.lookup key stmMap >>= \case
_ -> fail "Oops" -- internal error Just v -> return v
Nothing -> return (Count 0)
withSQLiteCon :: (Connection -> AppM a) -> AppM a withSQLiteCon :: (Connection -> AppM a) -> AppM a
withSQLiteCon action = do withSQLiteCon action = do

View File

@ -17,10 +17,12 @@ import Database.SQLite.Simple.ToField ( ToField(..) )
import Servant import Servant
( Handler, ServerError(errBody), FromHttpApiData, err500 ) ( Handler, ServerError(errBody), FromHttpApiData, err500 )
import Servant.API.Generic ( Generic ) import Servant.API.Generic ( Generic )
import qualified StmContainers.Map as SM
import Data.Hashable
newtype Key = Key Text newtype Key = Key Text
deriving (FromHttpApiData, Generic) deriving (FromHttpApiData, Generic, Hashable, Eq)
instance ToField Key where instance ToField Key where
toField (Key k) = toField k toField (Key k) = toField k
@ -46,6 +48,7 @@ instance FromJSON Count
data AppState = AppState { data AppState = AppState {
sqliteFile :: FilePath sqliteFile :: FilePath
, stmMap :: SM.Map Key Count
} }
newtype AppM a = AppM { runAppM :: ReaderT AppState Handler a } newtype AppM a = AppM { runAppM :: ReaderT AppState Handler a }

View File

@ -21,6 +21,7 @@ common deps
, base >=4.13 && <5.0 , base >=4.13 && <5.0
, bytestring ^>=0.11 , bytestring ^>=0.11
, exceptions ^>=0.10 , exceptions ^>=0.10
, hashable ^>=1.4
, mtl ^>=2.2 , mtl ^>=2.2
, optparse-applicative ^>=0.16 , optparse-applicative ^>=0.16
, prometheus-client ^>=1.1 , prometheus-client ^>=1.1
@ -29,6 +30,7 @@ common deps
, servant ^>=0.19 , servant ^>=0.19
, servant-server ^>=0.19 , servant-server ^>=0.19
, sqlite-simple ^>=0.4 , sqlite-simple ^>=0.4
, stm-containers ^>=1.2
, text ^>=2.0 , text ^>=2.0
, transformers ^>=0.5 , transformers ^>=0.5
, wai ^>=3.2.3 , wai ^>=3.2.3