Migrate from SQLite to PostgreSQL

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

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

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

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

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
 

config/settings.yml

@@ -20,4 +20,6 @@ approot:        "_env:APPROOT:"
 # mutable-static: false
 # skip-combining: false
 # force-ssl: true
-# dev-download: false
+# dev-download: false
+
+postgres-string: "_env:PGSTRING:host=localhost port=5432 user=stackage dbname=stackage password=stackage"

stackage-server.cabal

@@ -172,7 +172,7 @@ library
                   , streaming-commons
                   , classy-prelude-conduit
                   , path-pieces
-                  , persistent-sqlite
+                  , persistent-postgresql
                   , stackage-metadata
                   , filepath
                   , http-client