Merge pull request #301 from lehins/deal-with-slow-queries

Disable the really slow pages

bench/main.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT)
@@ -10,7 +11,7 @@ import Database.Persist.Sql (ConnectionPool, SqlBackend, runSqlPool)
 import Gauge
 import Pantry.Internal.Stackage (PackageNameP(..))
 import RIO
-import Settings (getAppSettings, AppSettings(..), configSettingsYmlValue)
+import Settings (getAppSettings, AppSettings(..), DatabaseSettings(..), configSettingsYmlValue)
 import Stackage.Database.Query
 import Stackage.Database.Schema (withStackageDatabase, runDatabase)
 import Stackage.Database.Types (LatestInfo, SnapName(..), SnapshotPackageInfo(..))
@@ -19,17 +20,12 @@ import Yesod.Default.Config2
 main :: IO ()
 main = do
     appSettings <- getAppSettings
-    let pgConf =
-            PostgresConf
-                { pgPoolSize = appPostgresPoolsize appSettings
-                , pgConnStr = encodeUtf8 $ appPostgresString appSettings
-                }
     let snapName = SNLts 16 4
     mSnapInfo <-
         runSimpleApp $
         withStackageDatabase
             True
-            pgConf
+            (appDatabase appSettings)
             (\db -> runDatabase db $ getSnapshotPackageInfoQuery snapName (PackageNameP "yesod"))
     let snapInfo = fromMaybe (error "snapInfo not retrieved") mSnapInfo
     defaultMain [benchs snapInfo]
@@ -39,13 +35,10 @@ runBenchApp pool m = runSimpleApp $ runSqlPool m pool
 
 createBenchPool :: IO ConnectionPool
 createBenchPool = do
-    baSettings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
+    loadYamlSettingsArgs [configSettingsYmlValue] useEnv >>= \case
-    pool <-
+        AppSettings{appDatabase = DSPostgres pgString pgPoolSize} ->
-        runNoLoggingT $
+            runNoLoggingT $ createPostgresqlPool (encodeUtf8 pgString) pgPoolSize
-        createPostgresqlPool
+        _ -> throwString "Benchmarks are crafted for PostgreSQL"
-            (encodeUtf8 $ appPostgresString baSettings)
-            (appPostgresPoolsize baSettings)
-    pure pool
 
 releasePool :: ConnectionPool -> IO ()
 releasePool = destroyAllResources

src/Handler/PackageList.hs

@@ -1,22 +1,26 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell   #-}
 module Handler.PackageList where
 
 import Import
-import Stackage.Database
+import Text.Blaze
-
 
 -- FIXME maybe just redirect to the LTS or nightly package list
 getPackageListR :: Handler Html
-getPackageListR =
+getPackageListR = do
-    track "Handler.PackageList.getPackageListR" $
+    sendResponseStatus status404 =<<
-    defaultLayout $ do
+        defaultLayout
-        cacheSeconds $ 60 * 60 * 2
+            (toWidget (preEscapedText
-        setTitle "Package list"
+                 ("Page has been disabled, see: " <>
-        packages <- getAllPackages
+                   "<a href=\"https://github.com/fpco/stackage-server/issues/299\">" <>
-        $(widgetFile "package-list")
+                   "github:fpco/stackage-server#299</a>")))
-  where
+  --   track "Handler.PackageList.getPackageListR" $
-    strip x = fromMaybe x (stripSuffix "." x)
+  --   defaultLayout $ do
-    makePackageLink snapName pli =
+  --       cacheSeconds $ 60 * 60 * 2
-        SnapshotR snapName $ StackageSdistR $ PNVNameVersion (pliName pli) (pliVersion pli)
+  --       setTitle "Package list"
+  --       packages <- getAllPackages
+  --       $(widgetFile "package-list")
+  -- where
+  --   strip x = fromMaybe x (stripSuffix "." x)
+  --   makePackageLink snapName pli =
+  --       SnapshotR snapName $ StackageSdistR $ PNVNameVersion (pliName pli) (pliVersion pli)

src/Handler/StackageHome.hs

@@ -17,6 +17,7 @@ import RIO.Time (FormatTime)
 import Import
 import Stackage.Database
 import Stackage.Snapshot.Diff
+import Text.Blaze
 
 getStackageHomeR :: SnapName -> Handler TypedContent
 getStackageHomeR name =
@@ -155,12 +156,19 @@ getSnapshotPackagesR name = track "Handler.StackageHome.getSnapshotPackagesR" $
     redirect $ SnapshotR name StackageHomeR
 
 getDocsR :: SnapName -> Handler Html
-getDocsR name = track "Handler.StackageHome.getDocsR" $ do
+getDocsR _name = do
-    cacheSeconds $ 60 * 60 * 48
+    sendResponseStatus status404 =<<
-    Entity sid _ <- lookupSnapshot name >>= maybe notFound return
+        defaultLayout
-    mlis <- getSnapshotModules sid
+            (toWidget (preEscapedText
-    render <- getUrlRender
+                 ("Page has been disabled, see: " <>
-    let mliUrl mli = render $ haddockUrl name mli
+                   "<a href=\"https://github.com/fpco/stackage-server/issues/300\">" <>
-    defaultLayout $ do
+                   "github:fpco/stackage-server#300</a>")))
-        setTitle $ toHtml $ "Module list for " ++ toPathPiece name
+  -- track "Handler.StackageHome.getDocsR" $ do
-        $(widgetFile "doc-list")
+  --   cacheSeconds $ 60 * 60 * 48
+  --   Entity sid _ <- lookupSnapshot name >>= maybe notFound return
+  --   mlis <- getSnapshotModules sid
+  --   render <- getUrlRender
+  --   let mliUrl mli = render $ haddockUrl name mli
+  --   defaultLayout $ do
+  --       setTitle $ toHtml $ "Module list for " ++ toPathPiece name
+  --       $(widgetFile "doc-list")