module Resource.Source ( Source(..) , load , embedFile ) where import RIO import Data.FileEmbed qualified import Data.Typeable import GHC.Records (HasField(..)) import GHC.Stack (withFrozenCallStack) import Language.Haskell.TH.Syntax qualified as TH import Resource.Compressed.Zstd qualified as Zstd import RIO.ByteString qualified as ByteString import RIO.FilePath (takeFileName, takeExtension) import RIO.Text qualified as Text data Source = Bytes (Maybe Text) ByteString | BytesZstd (Maybe Text) (Zstd.Compressed ByteString) | File (Maybe Text) FilePath instance HasField "label" Source (Maybe Text) where {-# INLINE getField #-} getField :: Source -> Maybe Text getField = \case Bytes Maybe Text label ByteString _bytes -> Maybe Text label BytesZstd Maybe Text label Compressed ByteString _bytes -> Maybe Text label File Maybe Text label FilePath _path -> Maybe Text label instance Show Source where show :: Source -> FilePath show = \case Bytes Maybe Text mlabel ByteString _bs -> FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath forall b a. b -> (a -> b) -> Maybe a -> b maybe FilePath "<buffer>" Text -> FilePath Text.unpack Maybe Text mlabel BytesZstd Maybe Text mlabel Compressed ByteString _zbs -> FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath forall b a. b -> (a -> b) -> Maybe a -> b maybe FilePath "<zstd buffer>" Text -> FilePath Text.unpack Maybe Text mlabel File Maybe Text mlabel FilePath filePath -> FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath forall b a. b -> (a -> b) -> Maybe a -> b maybe FilePath filePath Text -> FilePath Text.unpack Maybe Text mlabel load :: forall a m env . ( MonadIO m , MonadReader env m , HasLogFunc env , Typeable a , HasCallStack ) => (ByteString -> m a) -> Source -> m a load :: forall a (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, Typeable a, HasCallStack) => (ByteString -> m a) -> Source -> m a load ByteString -> m a action = \case Bytes Maybe Text label !ByteString bytes -> do (HasCallStack => m ()) -> m () forall a. HasCallStack => (HasCallStack => a) -> a withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m () forall a b. (a -> b) -> a -> b $ Utf8Builder -> m () forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m () forall a b. (a -> b) -> a -> b $ case Maybe Text label of Maybe Text Nothing -> Utf8Builder "Loading " Utf8Builder -> Utf8Builder -> Utf8Builder forall a. Semigroup a => a -> a -> a <> TypeRep -> Utf8Builder forall a. Show a => a -> Utf8Builder displayShow (Proxy a -> TypeRep forall {k} (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep forall a b. (a -> b) -> a -> b $ forall t. Proxy t forall {k} (t :: k). Proxy t Proxy @a) Just Text someText -> Utf8Builder "Loading " Utf8Builder -> Utf8Builder -> Utf8Builder forall a. Semigroup a => a -> a -> a <> TypeRep -> Utf8Builder forall a. Show a => a -> Utf8Builder displayShow (Proxy a -> TypeRep forall {k} (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep forall a b. (a -> b) -> a -> b $ forall t. Proxy t forall {k} (t :: k). Proxy t Proxy @a) Utf8Builder -> Utf8Builder -> Utf8Builder forall a. Semigroup a => a -> a -> a <> Utf8Builder " from " Utf8Builder -> Utf8Builder -> Utf8Builder forall a. Semigroup a => a -> a -> a <> Text -> Utf8Builder forall a. Display a => a -> Utf8Builder display Text someText ByteString -> m a action ByteString bytes BytesZstd Maybe Text label !Compressed ByteString bytesZstd -> case Compressed ByteString -> Either CompressedError ByteString Zstd.decompressBytes Compressed ByteString bytesZstd of Left CompressedError zstdError -> CompressedError -> m a forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a throwIO CompressedError zstdError Right !ByteString bytes -> (ByteString -> m a) -> Source -> m a forall a (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, Typeable a, HasCallStack) => (ByteString -> m a) -> Source -> m a load ByteString -> m a action (Source -> m a) -> Source -> m a forall a b. (a -> b) -> a -> b $ Maybe Text -> ByteString -> Source Bytes Maybe Text label ByteString bytes File Maybe Text label FilePath filePath -> do !ByteString bytes <- (ByteString -> m ByteString) -> (FilePath -> m ByteString) -> FilePath -> m ByteString forall (m :: * -> *) b. MonadIO m => (ByteString -> m b) -> (FilePath -> m b) -> FilePath -> m b Zstd.fromFileWith ByteString -> m ByteString forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (IO ByteString -> m ByteString forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO ByteString -> m ByteString) -> (FilePath -> IO ByteString) -> FilePath -> m ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . FilePath -> IO ByteString forall (m :: * -> *). MonadIO m => FilePath -> m ByteString ByteString.readFile) FilePath filePath (ByteString -> m a) -> Source -> m a forall a (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, Typeable a, HasCallStack) => (ByteString -> m a) -> Source -> m a load ByteString -> m a action (Source -> m a) -> Source -> m a forall a b. (a -> b) -> a -> b $ Maybe Text -> ByteString -> Source Bytes (Maybe Text label Maybe Text -> Maybe Text -> Maybe Text forall a. Maybe a -> Maybe a -> Maybe a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Text -> Maybe Text forall a. a -> Maybe a Just (FilePath -> Text forall a. IsString a => FilePath -> a fromString FilePath filePath)) ByteString bytes embedFile :: FilePath -> TH.Q TH.Exp embedFile :: FilePath -> Q Exp embedFile FilePath filePath = case ShowS takeExtension FilePath filePath of FilePath ".zst" -> do Exp bytesZstd <- FilePath -> Q Exp Data.FileEmbed.embedFile FilePath filePath Exp compressed <- [| Zstd.Compressed |] let bytesZstdExpr :: Exp bytesZstdExpr = Exp compressed Exp -> Exp -> Exp `TH.AppE` Exp bytesZstd Exp constr <- [| BytesZstd label |] pure $ Exp constr Exp -> Exp -> Exp `TH.AppE` Exp bytesZstdExpr FilePath _ -> do Exp bytes <- FilePath -> Q Exp Data.FileEmbed.embedFile FilePath filePath Exp constr <- [| Bytes label |] pure $ Exp constr Exp -> Exp -> Exp `TH.AppE` Exp bytes where label :: Maybe FilePath label = FilePath -> Maybe FilePath forall a. a -> Maybe a Just (FilePath -> Maybe FilePath) -> ShowS -> FilePath -> Maybe FilePath forall b c a. (b -> c) -> (a -> b) -> a -> c . FilePath -> ShowS forall a. Monoid a => a -> a -> a mappend FilePath "embedded|" (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath forall a b. (a -> b) -> a -> b $ ShowS takeFileName FilePath filePath