From 122e34ff12e5c728b5850ee28af7a135ab66fdc7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 20 Aug 2017 09:38:54 +0300 Subject: [PATCH] Migrate from SQLite to PostgreSQL --- Application.hs | 9 ++-- Foundation.hs | 6 +-- Settings.hs | 3 ++ Stackage/Database.hs | 25 ++++++------ Stackage/Database/Cron.hs | 86 ++++----------------------------------- config/settings.yml | 4 +- stackage-server.cabal | 2 +- 7 files changed, 36 insertions(+), 99 deletions(-) diff --git a/Application.hs b/Application.hs index d39ae9f..f213003 100644 --- a/Application.hs +++ b/Application.hs @@ -33,7 +33,8 @@ import Yesod.Default.Config2 import Yesod.Default.Handlers import Yesod.GitRepo import System.Process (rawSystem) -import Stackage.Database.Cron (loadFromS3, newHoogleLocker, singleRun) +import Stackage.Database (openStackageDatabase, PostgresConf (..)) +import Stackage.Database.Cron (newHoogleLocker, singleRun) import Control.AutoUpdate -- Import all relevant handler modules here. @@ -119,13 +120,15 @@ makeFoundation appSettings = do "master" loadWebsiteContent - (appStackageDatabase, refreshDB) <- loadFromS3 (appDevDownload appSettings) appHttpManager + appStackageDatabase <- openStackageDatabase PostgresConf + { pgPoolSize = 7 + , pgConnStr = encodeUtf8 $ appPostgresString appSettings + } -- Temporary workaround to force content updates regularly, until -- distribution of webhooks is handled via consul void $ forkIO $ forever $ void $ do threadDelay $ 1000 * 1000 * 60 * 5 - handleAny print refreshDB handleAny print $ grRefresh appWebsiteContent appLatestStackMatcher <- mkAutoUpdate defaultUpdateSettings diff --git a/Foundation.hs b/Foundation.hs index 92297d8..dce1d16 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -23,7 +23,7 @@ data App = App , appHttpManager :: Manager , appLogger :: Logger , appWebsiteContent :: GitRepo WebsiteContent - , appStackageDatabase :: IO StackageDatabase + , appStackageDatabase :: StackageDatabase , appLatestStackMatcher :: IO (Text -> Maybe Text) -- ^ Give a pattern, get a URL , appHoogleLock :: MVar () @@ -155,6 +155,6 @@ instance RenderMessage App FormMessage where -- https://github.com/yesodweb/yesod/wiki/Sending-email instance GetStackageDatabase Handler where - getStackageDatabase = getYesod >>= liftIO . appStackageDatabase + getStackageDatabase = appStackageDatabase <$> getYesod instance GetStackageDatabase (WidgetT App IO) where - getStackageDatabase = getYesod >>= liftIO . appStackageDatabase + getStackageDatabase = appStackageDatabase <$> getYesod diff --git a/Settings.hs b/Settings.hs index eae0ba3..0b67e6a 100644 --- a/Settings.hs +++ b/Settings.hs @@ -33,6 +33,8 @@ data AppSettings = AppSettings , appIpFromHeader :: Bool -- ^ Get the IP address from the header when logging. Useful when sitting -- behind a reverse proxy. + , appPostgresString :: !Text + -- ^ PostgreSQL connection string , appDetailedRequestLogging :: Bool -- ^ Use detailed request logging system @@ -64,6 +66,7 @@ instance FromJSON AppSettings where appHost <- fromString <$> o .: "host" appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" + appPostgresString <- o .: "postgres-string" appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev diff --git a/Stackage/Database.hs b/Stackage/Database.hs index 8531e3b..20cc9f3 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -1,5 +1,6 @@ module Stackage.Database ( StackageDatabase + , PostgresConf (..) , GetStackageDatabase (..) , SnapName (..) , SnapshotId () @@ -44,7 +45,6 @@ module Stackage.Database , getLatestLtsByGhc ) where -import Database.Sqlite (SqliteException) import Web.PathPieces (toPathPiece) import qualified Codec.Archive.Tar as Tar import Database.Esqueleto.Internal.Language (From) @@ -58,7 +58,7 @@ import Yesod.Form.Fields (Textarea (..)) import Stackage.Database.Types import System.Directory (getAppUserDataDirectory) import qualified Filesystem as F -import Filesystem.Path.CurrentOS (parent, filename, directory, FilePath, encodeString, ()) +import Filesystem.Path.CurrentOS (filename, directory, FilePath, encodeString, ()) import Data.Conduit.Process import Stackage.Types import Stackage.Metadata @@ -66,7 +66,7 @@ import Stackage.PackageIndex.Conduit import Web.PathPieces (fromPathPiece) import Data.Yaml (decodeFileEither) import Database.Persist -import Database.Persist.Sqlite +import Database.Persist.Postgresql import Database.Persist.TH import Control.Monad.Logger import System.IO.Temp @@ -215,29 +215,28 @@ runIn dir cmd args = where cp = (proc cmd args) { cwd = Just $ encodeString dir } -openStackageDatabase :: MonadIO m => FilePath -> m StackageDatabase -openStackageDatabase fp = liftIO $ do - F.createTree $ parent fp - fmap StackageDatabase $ runNoLoggingT $ createSqlitePool (pack $ encodeString fp) 7 +openStackageDatabase :: MonadIO m => PostgresConf -> m StackageDatabase +openStackageDatabase pg = liftIO $ do + fmap StackageDatabase $ runNoLoggingT $ createPostgresqlPool + (pgConnStr pg) + (pgPoolSize pg) -getSchema :: FilePath -> IO (Maybe Int) +getSchema :: PostgresConf -> IO (Maybe Int) getSchema fp = do StackageDatabase pool <- openStackageDatabase fp - eres <- try $ runSqlPool (selectList [] []) pool + eres <- tryAny $ runSqlPool (selectList [] []) pool putStrLn $ "getSchema result: " ++ tshow eres - case eres :: Either SqliteException [Entity Schema] of + case eres of Right [Entity _ (Schema v)] -> return $ Just v _ -> return Nothing -createStackageDatabase :: MonadIO m => FilePath -> m () +createStackageDatabase :: MonadIO m => PostgresConf -> m () createStackageDatabase fp = liftIO $ do putStrLn "Entering createStackageDatabase" actualSchema <- getSchema fp let schemaMatch = actualSchema == Just currentSchema unless schemaMatch $ do putStrLn $ "Current schema does not match actual schema: " ++ tshow (actualSchema, currentSchema) - putStrLn $ "Deleting " ++ pack (encodeString fp) - void $ tryIO $ removeFile $ encodeString fp StackageDatabase pool <- openStackageDatabase fp flip runSqlPool pool $ do diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 9458517..03d32a7 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -1,6 +1,5 @@ module Stackage.Database.Cron ( stackageServerCron - , loadFromS3 , newHoogleLocker , singleRun ) where @@ -31,86 +30,13 @@ import qualified Data.Conduit.Binary as CB import Data.Conduit.Zlib (WindowBits (WindowBits), compress, ungzip) import qualified Hoogle -import System.Directory (doesFileExist, getAppUserDataDirectory) +import System.Directory (getAppUserDataDirectory) import System.IO (withBinaryFile, IOMode (ReadMode)) import System.IO.Temp (withSystemTempDirectory) import Control.SingleRun import qualified Data.ByteString.Lazy as L import System.FilePath (splitPath) - -filename' :: Text -filename' = concat - [ "stackage-database-" - , tshow currentSchema - , ".sqlite3" - ] - -keyName :: Text -keyName = "stackage-database/" ++ filename' - -url :: Text -url = concat - [ "https://s3.amazonaws.com/haddock.stackage.org/" - , keyName - ] - --- | Provides an action to be used to refresh the file from S3. -loadFromS3 :: Bool -- ^ devel mode? if True, won't delete old databases, and won't refresh them either - -> Manager -> IO (IO StackageDatabase, IO ()) -loadFromS3 develMode man = do - killPrevVar <- newTVarIO $ return () - currSuffixVar <- newTVarIO (1 :: Int) - - let root = "stackage-database" - unless develMode $ handleIO print $ removeTree root - createTree root - - req <- parseRequest $ unpack url - let download = do - suffix <- atomically $ do - x <- readTVar currSuffixVar - writeTVar currSuffixVar $! x + 1 - return x - - let fp = root unpack ("database-download-" ++ tshow suffix) - isInitial = suffix == 1 - toSkip <- - if isInitial - then do - putStrLn $ "Checking if database exists: " ++ tshow fp - doesFileExist fp - else return False - if toSkip - then putStrLn "Skipping initial database download" - else do - putStrLn $ "Downloading database to " ++ pack fp - withResponse req man $ \res -> - runResourceT - $ bodyReaderSource (responseBody res) - $= ungzip - $$ sinkFile fp - putStrLn "Finished downloading database" - - return fp - - dbvar <- newTVarIO $ error "database not yet loaded" - - let update = do - fp <- download - db <- openStackageDatabase (fromString fp) `onException` removeFile (fromString fp) - void $ tryIO $ join $ atomically $ do - writeTVar dbvar db - oldKill <- readTVar killPrevVar - writeTVar killPrevVar $ do - -- give existing users a chance to clean up - threadDelay $ 1000000 * 30 - void $ tryIO $ removeFile (fromString fp) - closeStackageDatabase db - return oldKill - - update - - return (readTVarIO dbvar, unless develMode update) +import System.Environment (getEnv) hoogleKey :: SnapName -> Text hoogleKey name = concat @@ -175,9 +101,13 @@ stackageServerCron = do Left e -> error $ show (fp, key, e) Right _ -> putStrLn "Success" - let dbfp = fromText keyName + connstr <- getEnv "PGSTRING" + + let dbfp = PostgresConf + { pgPoolSize = 5 + , pgConnStr = encodeUtf8 $ pack connstr + } createStackageDatabase dbfp - upload (encodeString dbfp) (ObjectKey keyName) db <- openStackageDatabase dbfp diff --git a/config/settings.yml b/config/settings.yml index 3602563..486f7e7 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -20,4 +20,6 @@ approot: "_env:APPROOT:" # mutable-static: false # skip-combining: false # force-ssl: true -# dev-download: false \ No newline at end of file +# dev-download: false + +postgres-string: "_env:PGSTRING:host=localhost port=5432 user=stackage dbname=stackage password=stackage" diff --git a/stackage-server.cabal b/stackage-server.cabal index e8656b0..6ab0848 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -172,7 +172,7 @@ library , streaming-commons , classy-prelude-conduit , path-pieces - , persistent-sqlite + , persistent-postgresql , stackage-metadata , filepath , http-client