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")