Fix bug in HTTP delivery actor storage, delivery wasn't working

src/Database/Persist/Box/Internal.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -114,6 +114,7 @@ module Database.Persist.Box.Internal
 where
 
 import Control.Exception.Base
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger.CallStack
@@ -121,6 +122,7 @@ import Control.Monad.Trans.Class
 import Data.ByteString (ByteString)
 import Data.Int
 import Data.Kind
+import Data.Maybe
 import Data.Proxy
 import Data.Text (Text)
 import Database.Persist
@@ -165,7 +167,7 @@ createCellIfNeeded
 createCellIfNeeded p = do
     r <-
         rawSql
-            "SELECT name FROM sqlite_schema WHERE type='table' AND name=?"
+            "SELECT name FROM sqlite_master WHERE type='table' AND name=?"
             [PersistText "cell"]
     case r  of
         [] ->
@@ -176,7 +178,7 @@ createCellIfNeeded p = do
                     ]
             in  rawExecute query []
         [Single (_ :: a)] -> pure ()
-        _ -> error "Multiple cell tables in sqlite_schema"
+        _ -> error "Multiple cell tables in sqlite_master"
 
 model :: QuasiQuoter
 model = PS.model ""
@@ -198,6 +200,7 @@ class Boxable a where
     --type MigrationRecipes a :: * -> *
     --migrateBox :: (MonadIO m, MonadLogger m, MonadMigrateBox m) => MigrationRecipe a m -> SqlPersistT m (Either Text (Int, Int))
     createBoxStorageIfNeeded :: MonadIO m => Proxy a -> SqlPersistT m ()
+    getB :: MonadIO m => SqlPersistT m (Maybe a)
     bestowB :: MonadIO m => a -> SqlPersistT m ()
     obtainB :: MonadIO m => SqlPersistT m a
 
@@ -220,6 +223,9 @@ bestow = BoxPersistT . bestowB . wrapBF @(BV a) @a
 obtain :: forall m a. (MonadIO m, BoxableVia a) => BoxPersistT a m a
 obtain = BoxPersistT $ unwrapBF @(BV a) @a <$> obtainB
 
+get_b :: forall m a. (MonadIO m, BoxableVia a) => BoxPersistT a m (Maybe a)
+get_b = BoxPersistT $ fmap (unwrapBF @(BV a) @a) <$> getB
+
 newtype BoxableRecord a = BoxableRecord { unBoxableRecord :: a }
 
 instance BoxableFormat BoxableRecord where
@@ -236,6 +242,7 @@ instance (PersistRecordBackend a SqlBackend, ToBackendKey SqlBackend a) => Boxab
     --type MigrationRecipe (BoxablePersist a) m = [Migration SqlBackend m]
     --migrateBox ms = second (,length ms) <$> runMigrations schemaBackend? "" 1 ms
     createBoxStorageIfNeeded = createEntityIfNeeded . fmap unBoxableRecord
+    getB = fmap BoxableRecord <$> get key
     bestowB (BoxableRecord r) = repsert key r
     obtainB = BoxableRecord <$> getJust key
 
@@ -253,6 +260,14 @@ instance PersistFieldSql a => Boxable (BoxableField a) where
     --type MigrationRecipe (BoxablePersist a) = ???
     --migrateBox ms = ???
     createBoxStorageIfNeeded = createCellIfNeeded . fmap unBoxableField
+    getB = do
+        r <- rawSql query [toPersistValue keyN]
+        case r of
+            [] -> return Nothing
+            [Single v] -> return $ Just $ BoxableField v
+            _ -> liftIO $ throwIO $ BoxException "getB: multiple rows found"
+        where
+        query = "SELECT value FROM cell WHERE id=?"
     bestowB (BoxableField v) =
         rawExecute query [toPersistValue keyN, toPersistValue v]
         where
@@ -300,6 +315,7 @@ instance (Typeable a, Show a, Read a) => Boxable (BoxableShow a) where
     --migrateBox ms = ???
     createBoxStorageIfNeeded =
         createCellIfNeeded . fmap (WrapShow . unBoxableShow)
+    getB = fmap (BoxableShow . unWrapShow . unBoxableField) <$> getB
     bestowB = bestowB . BoxableField . WrapShow . unBoxableShow
     obtainB = BoxableShow . unWrapShow . unBoxableField <$> obtainB
 
@@ -334,6 +350,7 @@ instance (Typeable a, A.FromJSON a, A.ToJSON a) => Boxable (BoxableJSON a) where
     --migrateBox ms = ???
     createBoxStorageIfNeeded =
         createCellIfNeeded . fmap (WrapJSON . unBoxableJSON)
+    getB = fmap (BoxableJSON . unWrapJSON . unBoxableField) <$> getB
     bestowB = bestowB . BoxableField . WrapJSON . unBoxableJSON
     obtainB = BoxableJSON . unWrapJSON . unBoxableField <$> obtainB
 
@@ -362,6 +379,7 @@ instance (Typeable a, S.Serialize a) => Boxable (BoxableSerialize a) where
     --migrateBox ms = ???
     createBoxStorageIfNeeded =
         createCellIfNeeded . fmap (WrapSerialize . unBoxableSerialize)
+    getB = fmap (BoxableSerialize . unWrapSerialize . unBoxableField) <$> getB
     bestowB = bestowB . BoxableField . WrapSerialize . unBoxableSerialize
     obtainB = BoxableSerialize . unWrapSerialize . unBoxableField <$> obtainB
 
@@ -382,6 +400,8 @@ loadBox path val = do
         let proxy :: a -> Proxy (BV a a)
             proxy _ = Proxy
         BoxPersistT $ createBoxStorageIfNeeded $ proxy val
+        mval <- get_b
+        when (isNothing mval) $ bestow val
         {-
         r <- migrateBox migrations
             Left err -> do

src/Web/Actor/Deliver.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -47,6 +47,8 @@ import Data.Traversable
 import Database.Persist.Sql
 import Network.HTTP.Client (Manager)
 import Network.HTTP.Types.Header (HeaderName)
+import Network.HTTP.Types.URI (urlEncode, urlDecode)
+import System.FilePath ((</>))
 import System.Directory
 import Web.Hashids
 
@@ -54,6 +56,7 @@ import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashSet as HS
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 
 import Control.Concurrent.Actor
 import Database.Persist.Box
@@ -110,6 +113,7 @@ data DeliveryTheater u = DeliveryTheater
     , _dtHeaders :: NonEmpty HeaderName
     , _dtDelay   :: Int
     , _dtLog     :: LogFunc
+    , _dtDir     :: OsPath
     , _dtTheater :: TheaterFor (Env u)
     }
 
@@ -189,20 +193,21 @@ startDeliveryTheater headers micros manager logFunc dbRootDir = do
     entries <- listDirectory dbRootDir
     actors <- for entries $ \ path -> do
         path' <- T.pack <$> decodeUtf path
+        path'' <- either throwIO pure $ TE.decodeUtf8' $ urlDecode False $ TE.encodeUtf8 path'
         u <-
-            case parseObjURI path' of
+            case parseObjURI path'' of
                 Left e ->
                     error $
                         "Failed to parse URI-named SQLite db filename: " ++ e
                 Right uri -> return uri
-        env <- mkEnv logFunc path
+        env <- mkEnv logFunc $ dbRootDir </> path
         return (u, env, behavior manager headers micros u)
-    DeliveryTheater manager headers micros logFunc <$> startTheater logFunc actors
+    DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc actors
 
 sendHttp :: UriMode u => DeliveryTheater u -> Method u -> [ObjURI u] -> IO ()
-sendHttp (DeliveryTheater manager headers micros logFunc theater) method recips = do
+sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = do
     for_ recips $ \ u ->
-        let makeEnv = encodeUtf (T.unpack $ renderObjURI u) >>= mkEnv logFunc
+        let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv logFunc
             behave = behavior manager headers micros u
         in  void $ spawnIO theater u makeEnv behave
     sendManyIO theater (HS.fromList recips) method