Add sqlite3 extension to per-actor DB files to fix a bug

Vervis tries to open Sqlite's WAL files as databases and thus fails to
launch
This commit is contained in:
Pere Lev 2024-08-07 17:00:12 +03:00
parent e1c952a3b2
commit d224569efc
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D

View file

@ -41,7 +41,9 @@ import Control.Retry
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Foldable import Data.Foldable
import Data.Hashable import Data.Hashable
import Data.List
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Interval import Data.Time.Interval
@ -51,7 +53,7 @@ import Network.HTTP.Client (Manager, HttpException (..), HttpExceptionContent (.
import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Header (HeaderName)
import Network.HTTP.Types.URI (urlEncode, urlDecode) import Network.HTTP.Types.URI (urlEncode, urlDecode)
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import System.FilePath ((</>)) import System.FilePath
import System.Directory import System.Directory
import Web.Hashids import Web.Hashids
@ -217,9 +219,18 @@ startDeliveryTheater
-> OsPath -> OsPath
-> IO (DeliveryTheater u) -> IO (DeliveryTheater u)
startDeliveryTheater headers micros manager logFunc dbRootDir = do startDeliveryTheater headers micros manager logFunc dbRootDir = do
-- We first add the sqlite3 extension as needed
entries <- listDirectory dbRootDir entries <- listDirectory dbRootDir
actors <- for entries $ \ path -> do for_ entries $ \ path ->
path' <- T.pack <$> decodeUtf path if takeExtension path == "" && not ("-wal-shm" `isSuffixOf` path) && not ("-wal-wal" `isSuffixOf` path)
then renameFile (dbRootDir </> path) (dbRootDir </> path <.> "sqlite3")
else return ()
entries <- listDirectory dbRootDir
let dbs = filter ((== ".sqlite3") . takeExtension) entries
actors <- for dbs $ \ path -> do
path' <- T.pack <$> decodeUtf (dropExtension path)
path'' <- either throwIO pure $ TE.decodeUtf8' $ urlDecode False $ TE.encodeUtf8 path' path'' <- either throwIO pure $ TE.decodeUtf8' $ urlDecode False $ TE.encodeUtf8 path'
u <- u <-
case parseObjURI path'' of case parseObjURI path'' of