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

lib/Soostone.hs

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

lib/Soostone/Handlers.hs

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

lib/Soostone/Types.hs

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