improve performance of getText

Author: jruehlow

service/postgres/init.sql

@@ -398,6 +398,9 @@ CREATE INDEX idx_text_paragraph_era
 CREATE INDEX idx_text_paragraph_era_source_book
     ON public.text_paragraph (era, source, book);
 
+CREATE INDEX idx_text_paragraph_era_source_book_id
+  ON text_paragraph(era, source, book, id);
+
 -- For replay
 CREATE INDEX idx_replay_user_id
     ON public.replay (user_id);

service/src/Application.hs

@@ -23,12 +23,14 @@ where
 
 -- Import all relevant handler modules here.
 import Control.Monad.Logger (liftLoc, runLoggingT)
+import qualified Data.Map.Strict as Map
 import Database.Persist.Postgresql
   ( createPostgresqlPool,
     pgConnStr,
     pgPoolSize,
     runSqlPool,
   )
+import Database.Persist.Sql (Single (..), rawSql)
 import Handler.Common
 import Handler.CustomText
 import Handler.Home
@@ -82,6 +84,7 @@ makeFoundation appSettings = do
   appLobbies <- newTVarIO mempty
   gen <- newStdGen
   appRng <- newIORef gen
+  appMinMaxByEra <- newIORef Map.empty
 
   let mkFoundation appConnPool = App {..}
       tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
@@ -97,6 +100,21 @@ makeFoundation appSettings = do
   -- Perform database migration using our application's logging settings.
   runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
 
+  -- Load MIN/MAX IDs per era into memory
+  minMaxRows <-
+    flip runSqlPool pool $
+      rawSql
+        "SELECT era, MIN(id), MAX(id) \
+        \FROM text_paragraph \
+        \GROUP BY era"
+        []
+  let minMaxMap =
+        Map.fromList
+          [ (era, (minId, maxId))
+            | (Single era, Single (Just minId), Single (Just maxId)) <- minMaxRows
+          ]
+  writeIORef appMinMaxByEra minMaxMap
+
   -- Return the foundation
   return $ mkFoundation pool
 

service/src/Foundation.hs

@@ -17,6 +17,7 @@ import Control.Monad.Logger (LogSource)
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.CaseInsensitive as CI
 import Data.Kind (Type)
+import qualified Data.Map.Strict as Map
 import qualified Data.Text.Encoding as TE
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Import.NoFoundation
@@ -37,7 +38,8 @@ data App = App
     appHttpManager :: Manager,
     appLogger :: Logger,
     appLobbies :: TVar (Map Text LobbyState),
-    appRng :: IORef StdGen
+    appRng :: IORef StdGen,
+    appMinMaxByEra :: IORef (Map.Map Text (Int64, Int64))
   }
 
 type ServerMessage = LBS.ByteString

service/src/Handler/Text.hs

@@ -6,40 +6,80 @@
 module Handler.Text where
 
 import Data.ByteString (hGet)
+import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
+import Database.Persist.Sql (Single (Single), rawSql, toSqlKey)
 import Import
 import System.Directory (doesFileExist)
 import System.Random (randomRIO)
 
-getRandomParagraph :: Text -> Text -> Int -> Handler (Entity TextParagraph)
+getRandomParagraph ::
+  Text -> Text -> Int -> Handler (Entity TextParagraph)
 getRandomParagraph era source book = do
-  let filters =
+  res <-
+    runDB $
+      rawSql
+        "SELECT MIN(id), MAX(id) \
+        \FROM text_paragraph      \
+        \WHERE era    = ?         \
+        \  AND source = ?         \
+        \  AND book   = ?"
+        [ toPersistValue era,
+          toPersistValue source,
+          toPersistValue book
+        ]
+  pair <- case res of
+    [(Single mMinId, Single mMaxId)] ->
+      let minId = fromMaybe (error "no rows") mMinId
+          maxId = fromMaybe minId mMaxId
+       in return (minId, maxId)
+    _ -> notFound
+  let (minId, maxId) = pair
+  rnd <- liftIO $ randomRIO (minId, maxId)
+  let baseFilters =
         [ TextParagraphEra ==. era,
           TextParagraphSource ==. source,
           TextParagraphBook ==. book
         ]
-  total <- runDB $ count filters
-  when (total == 0) notFound
-
-  idx <- liftIO $ randomRIO (0, total - 1)
-
-  results <- runDB $ selectList filters [OffsetBy idx, LimitTo 1]
-  case results of
-    [ent] -> return ent
-    _ -> error "No paragraph found for this era."
+  mEnt <-
+    runDB $
+      selectFirst
+        (baseFilters ++ [TextParagraphId >=. toSqlKey rnd])
+        [Asc TextParagraphId]
+  case mEnt of
+    Just ent -> return ent
+    Nothing -> do
+      mEnt2 <-
+        runDB $
+          selectFirst
+            baseFilters
+            [Asc TextParagraphId]
+      maybe notFound return mEnt2
 
 getRandomNewText :: Text -> Handler (Entity TextParagraph)
 getRandomNewText era = do
-  let filters = [TextParagraphEra ==. era]
-  total <- runDB $ count filters
-  when (total == 0) notFound
-
-  idx <- liftIO $ randomRIO (0, total - 1)
-
-  results <- runDB $ selectList filters [OffsetBy idx, LimitTo 1]
-  case results of
-    [ent] -> return ent
-    _ -> error "No paragraph found for this era."
+  App {appMinMaxByEra = cacheRef} <- getYesod
+  cache <- liftIO $ readIORef cacheRef
+  case Map.lookup era cache of
+    Nothing -> notFound
+    Just (minId, maxId) -> do
+      rnd <- liftIO $ randomRIO (minId, maxId)
+      mEnt <-
+        runDB $
+          selectFirst
+            [ TextParagraphEra ==. era,
+              TextParagraphId >=. toSqlKey rnd
+            ]
+            [Asc TextParagraphId]
+      case mEnt of
+        Just ent -> return ent
+        Nothing -> do
+          mEnt2 <-
+            runDB $
+              selectFirst
+                [TextParagraphEra ==. era]
+                [Asc TextParagraphId]
+          maybe notFound return mEnt2
 
 getCustomText :: UserId -> Text -> Handler ByteString
 getCustomText userId filename = do