diff --git a/bench/main.hs b/bench/main.hs
index b721506..9099a28 100644
--- a/bench/main.hs
+++ b/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
- pool <-
- runNoLoggingT $
- createPostgresqlPool
- (encodeUtf8 $ appPostgresString baSettings)
- (appPostgresPoolsize baSettings)
- pure pool
+ loadYamlSettingsArgs [configSettingsYmlValue] useEnv >>= \case
+ AppSettings{appDatabase = DSPostgres pgString pgPoolSize} ->
+ runNoLoggingT $ createPostgresqlPool (encodeUtf8 pgString) pgPoolSize
+ _ -> throwString "Benchmarks are crafted for PostgreSQL"
releasePool :: ConnectionPool -> IO ()
releasePool = destroyAllResources
diff --git a/src/Handler/PackageList.hs b/src/Handler/PackageList.hs
index 844aa1d..039ffe7 100644
--- a/src/Handler/PackageList.hs
+++ b/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 =
- track "Handler.PackageList.getPackageListR" $
- defaultLayout $ do
- cacheSeconds $ 60 * 60 * 2
- 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)
+getPackageListR = do
+ sendResponseStatus status404 =<<
+ defaultLayout
+ (toWidget (preEscapedText
+ ("Page has been disabled, see: " <>
+ "" <>
+ "github:fpco/stackage-server#299")))
+ -- track "Handler.PackageList.getPackageListR" $
+ -- defaultLayout $ do
+ -- cacheSeconds $ 60 * 60 * 2
+ -- 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)
diff --git a/src/Handler/StackageHome.hs b/src/Handler/StackageHome.hs
index f91f677..f01322b 100644
--- a/src/Handler/StackageHome.hs
+++ b/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
- 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")
+getDocsR _name = do
+ sendResponseStatus status404 =<<
+ defaultLayout
+ (toWidget (preEscapedText
+ ("Page has been disabled, see: " <>
+ "" <>
+ "github:fpco/stackage-server#300")))
+ -- track "Handler.StackageHome.getDocsR" $ do
+ -- 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")