diff --git a/src/Database/Persist/Box/Internal.hs b/src/Database/Persist/Box/Internal.hs index f7b37cd..78e1b12 100644 --- a/src/Database/Persist/Box/Internal.hs +++ b/src/Database/Persist/Box/Internal.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Web/Actor/Deliver.hs b/src/Web/Actor/Deliver.hs index 570dc81..3128371 100644 --- a/src/Web/Actor/Deliver.hs +++ b/src/Web/Actor/Deliver.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2023, 2024 by fr33domlover . - - ♡ 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