pantry 0.9.0 → 0.9.1

raw patch · 6 files changed

+131/−125 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• int/Pantry/SQLite.hs +0/−116
• int/Pantry/Types.hs +7/−6
• pantry.cabal +2/−2
• src/Pantry/Internal/Stackage.hs +2/−1
• src/Pantry/SQLite.hs +116/−0

@@ -1,5 +1,9 @@ # Changelog for pantry
 
+## v0.9.1
+
+* Expose module `Pantry.SQLite`.
+
 ## v0.9.0
 
 * Remove module `Pantry.Internal.AesonExtended` and depend on

@@ -1,116 +0,0 @@-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Pantry.SQLite
-  ( Storage (..)
-  , initStorage
-  ) where
-
-import           Control.Concurrent.Companion
-                   ( Companion, onCompanionDone, withCompanion )
-import           Database.Persist.Sqlite
-import           Pantry.Types
-                   ( PantryException (MigrationFailure), Storage (..) )
-import           Path ( Abs, File, Path, parent, toFilePath )
-import           Path.IO ( ensureDir )
-import           RIO hiding ( FilePath )
-import           RIO.Orphans ()
-import           System.FileLock
-                   ( SharedExclusive (..), withFileLock, withTryFileLock )
-
-initStorage ::
-     HasLogFunc env
-  => Text
-  -> Migration
-  -> Path Abs File -- ^ storage file
-  -> (Storage -> RIO env a)
-  -> RIO env a
-initStorage description migration fp inner = do
-  ensureDir $ parent fp
-
-  migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $
-    withSqliteConnInfo (sqinfo True) $ runSqlConn $
-    runMigrationSilent migration
-  forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig
-
-  -- Make a single connection to the SQLite database and wrap it in an MVar for
-  -- the entire execution context. Previously we used a resource pool of size
-  -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird
-  -- interaction with Docker on OS X where when resource-pool's reaper would
-  -- trigger, it would somehow cause the Stack process inside the container to
-  -- die with a SIGBUS. Definitely an interesting thing worth following up
-  -- on...
-  withSqliteConnInfo (sqinfo False) $ \conn0 -> do
-    connVar <- newMVar conn0
-    inner $ Storage
-      -- NOTE: Currently, we take a write lock on every action. This is
-      -- a bit heavyweight, but it avoids the SQLITE_BUSY errors
-      -- reported in
-      -- <https://github.com/commercialhaskell/stack/issues/4471>
-      -- completely. We can investigate more elegant solutions in the
-      -- future, such as separate read and write actions or introducing
-      -- smarter retry logic.
-      { withStorage_ = \action -> withMVar connVar $ \conn ->
-                       withWriteLock (display description) fp $
-                       runSqlConn action conn
-      , withWriteLock_ = id
-      }
- where
-  wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp)
-
-  sqinfo isMigration
-    = set extraPragmas ["PRAGMA busy_timeout=2000;"]
-    $ set walEnabled False
-
-    -- When doing a migration, we want to disable foreign key checking, since
-    -- the order in which tables are created by the migration scripts may not
-    -- respect foreign keys. The rest of the time: enforce those foreign keys.
-    $ set fkEnabled (not isMigration)
-
-    $ mkSqliteConnectionInfo (fromString $ toFilePath fp)
-
--- | Ensure that only one process is trying to write to the database at a time.
--- See https://github.com/commercialhaskell/stack/issues/4471 and comments
--- above.
-withWriteLock ::
-     HasLogFunc env
-  => Utf8Builder -- ^ database description, for lock messages
-  -> Path Abs File -- ^ SQLite database file
-  -> RIO env a
-  -> RIO env a
-withWriteLock desc dbFile inner = do
-  let lockFile = toFilePath dbFile ++ ".pantry-write-lock"
-  withRunInIO $ \run -> do
-    mres <- withTryFileLock lockFile Exclusive $ const $ run inner
-    case mres of
-      Just res -> pure res
-      Nothing -> do
-        let complainer :: Companion IO
-            complainer delay = run $ do
-              -- Wait five seconds before giving the first message to
-              -- avoid spamming the user for uninteresting file locks
-              delay $ 5 * 1000 * 1000 -- 5 seconds
-              logInfo $
-                   "Unable to get a write lock on the "
-                <> desc
-                <> " database, waiting..."
-
-              -- Now loop printing a message every 1 minute
-              forever $ do
-                delay (60 * 1000 * 1000) -- 1 minute
-                  `onCompanionDone` logInfo
-                    (  "Acquired the "
-                    <> desc
-                    <> " database write lock"
-                    )
-                logWarn
-                  (  "Still waiting on the "
-                  <> desc
-                  <> " database write lock..."
-                  )
-        withCompanion complainer $ \stopComplaining ->
-          withFileLock lockFile Exclusive $ const $ do
-            stopComplaining
-            run inner

@@ -260,12 +260,13 @@ newtype Revision = Revision Word
   deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql)
 
--- | Represents a SQL database connection. This used to be a newtype wrapper
--- around a connection pool. However, when investigating
--- <https://github.com/commercialhaskell/stack/issues/4471>, it appeared that
--- holding a pool resulted in overly long write locks being held on the
--- database. As a result, we now abstract away whether a pool is used, and the
--- default implementation in "Pantry.Storage" does not use a pool.
+-- | Represents a SQL database connection.
+
+-- This used to be a newtype wrapper around a connection pool. However, when
+-- investigating <https://github.com/commercialhaskell/stack/issues/4471>, it
+-- appeared that holding a pool resulted in overly long write locks being held
+-- on the database. As a result, we now abstract away whether a pool is used,
+-- and the default implementation in "Pantry.Storage" does not use a pool.
 data Storage = Storage
   { withStorage_ ::
          forall env a. HasLogFunc env

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack
 
 name:           pantry
-version:        0.9.0
+version:        0.9.1
 synopsis:       Content addressable Haskell package management
 description:    Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme>
 category:       Development
@@ -36,6 +36,7 @@ library
   exposed-modules:
       Pantry
+      Pantry.SQLite
       Pantry.Internal.Stackage
   other-modules:
       Hackage.Security.Client.Repository.HttpLib.HttpClient
@@ -122,7 +123,6 @@       Pantry.HPack
       Pantry.Internal
       Pantry.SHA256
-      Pantry.SQLite
       Pantry.Types
   other-modules:
       Paths_pantry

@@ -1,5 +1,6 @@ -- | All types and functions exported from this module are for advanced usage
--- only. They are needed for stackage-server integration with pantry.
+-- only. They are needed for stackage-server integration with pantry and some
+-- are needed for stack testing.
 module Pantry.Internal.Stackage
   ( module X
   ) where

@@ -0,0 +1,116 @@+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Pantry.SQLite
+  ( Storage (..)
+  , initStorage
+  ) where
+
+import           Control.Concurrent.Companion
+                   ( Companion, onCompanionDone, withCompanion )
+import           Database.Persist.Sqlite
+import           Pantry.Types
+                   ( PantryException (MigrationFailure), Storage (..) )
+import           Path ( Abs, File, Path, parent, toFilePath )
+import           Path.IO ( ensureDir )
+import           RIO hiding ( FilePath )
+import           RIO.Orphans ()
+import           System.FileLock
+                   ( SharedExclusive (..), withFileLock, withTryFileLock )
+
+initStorage ::
+     HasLogFunc env
+  => Text -- ^ Database description, for lock messages.
+  -> Migration -- ^ Initial migration.
+  -> Path Abs File -- ^ SQLite database file.
+  -> (Storage -> RIO env a) -- ^ What to do with the initialised 'Storage'.
+  -> RIO env a
+initStorage description migration fp inner = do
+  ensureDir $ parent fp
+
+  migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $
+    withSqliteConnInfo (sqinfo True) $ runSqlConn $
+    runMigrationSilent migration
+  forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig
+
+  -- Make a single connection to the SQLite database and wrap it in an MVar for
+  -- the entire execution context. Previously we used a resource pool of size
+  -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird
+  -- interaction with Docker on OS X where when resource-pool's reaper would
+  -- trigger, it would somehow cause the Stack process inside the container to
+  -- die with a SIGBUS. Definitely an interesting thing worth following up
+  -- on...
+  withSqliteConnInfo (sqinfo False) $ \conn0 -> do
+    connVar <- newMVar conn0
+    inner $ Storage
+      -- NOTE: Currently, we take a write lock on every action. This is
+      -- a bit heavyweight, but it avoids the SQLITE_BUSY errors
+      -- reported in
+      -- <https://github.com/commercialhaskell/stack/issues/4471>
+      -- completely. We can investigate more elegant solutions in the
+      -- future, such as separate read and write actions or introducing
+      -- smarter retry logic.
+      { withStorage_ = \action -> withMVar connVar $ \conn ->
+                       withWriteLock (display description) fp $
+                       runSqlConn action conn
+      , withWriteLock_ = id
+      }
+ where
+  wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp)
+
+  sqinfo isMigration
+    = set extraPragmas ["PRAGMA busy_timeout=2000;"]
+    $ set walEnabled False
+
+    -- When doing a migration, we want to disable foreign key checking, since
+    -- the order in which tables are created by the migration scripts may not
+    -- respect foreign keys. The rest of the time: enforce those foreign keys.
+    $ set fkEnabled (not isMigration)
+
+    $ mkSqliteConnectionInfo (fromString $ toFilePath fp)
+
+-- | Ensure that only one process is trying to write to the database at a time.
+-- See https://github.com/commercialhaskell/stack/issues/4471 and comments
+-- above.
+withWriteLock ::
+     HasLogFunc env
+  => Utf8Builder -- ^ Database description, for lock messages
+  -> Path Abs File -- ^ SQLite database file
+  -> RIO env a
+  -> RIO env a
+withWriteLock desc dbFile inner = do
+  let lockFile = toFilePath dbFile ++ ".pantry-write-lock"
+  withRunInIO $ \run -> do
+    mres <- withTryFileLock lockFile Exclusive $ const $ run inner
+    case mres of
+      Just res -> pure res
+      Nothing -> do
+        let complainer :: Companion IO
+            complainer delay = run $ do
+              -- Wait five seconds before giving the first message to
+              -- avoid spamming the user for uninteresting file locks
+              delay $ 5 * 1000 * 1000 -- 5 seconds
+              logInfo $
+                   "Unable to get a write lock on the "
+                <> desc
+                <> " database, waiting..."
+
+              -- Now loop printing a message every 1 minute
+              forever $ do
+                delay (60 * 1000 * 1000) -- 1 minute
+                  `onCompanionDone` logInfo
+                    (  "Acquired the "
+                    <> desc
+                    <> " database write lock"
+                    )
+                logWarn
+                  (  "Still waiting on the "
+                  <> desc
+                  <> " database write lock..."
+                  )
+        withCompanion complainer $ \stopComplaining ->
+          withFileLock lockFile Exclusive $ const $ do
+            stopComplaining
+            run inner