{-|
Module: IHP.FileStorage.ControllerFunctions
Description: Store uploaded files
Copyright: (c) digitally induced GmbH, 2021
-}
module IHP.FileStorage.ControllerFunctions
( storeFile
, removeFileFromStorage
, storeFileWithOptions
, storeFileFromUrl
, storeFileFromPath
, contentDispositionAttachmentAndFileName
, createTemporaryDownloadUrl
, createTemporaryDownloadUrlFromPath
, createTemporaryDownloadUrlFromPathWithExpiredAt
, refreshTemporaryDownloadUrlFromFile
, uploadToStorage
, uploadToStorageWithOptions
, storage
, storagePrefix
) where

import IHP.Prelude
import IHP.FileStorage.Types
import IHP.Controller.Context
import IHP.Controller.FileUpload
import IHP.FrameworkConfig
import qualified IHP.ModelSupport as ModelSupport
import IHP.ValidationSupport

import Network.Minio
import qualified Data.Conduit.Binary as Conduit
import qualified Network.Wai.Parse as Wai
import Network.Wai (Request)

import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import qualified Data.TMap as TMap
import qualified Data.Text as Text
import qualified Data.ByteString.Lazy as LBS
import qualified System.Directory.OsPath as Directory
import qualified Control.Exception.Safe as Exception
import System.OsPath (encodeUtf)
import qualified Network.Wreq as Wreq
import Control.Lens hiding ((|>), set)
import qualified Network.Mime as Mime

-- | Uploads a file to a directory in the storage
--
-- See 'storeFileWithOptions' for more advanced use cases.
--
-- __Example:__ Save a file upload by the user to the storage
--
-- > action UpdateLogoAction = do
-- >     let file = fileOrNothing "file"
-- >             |> fromMaybe (error "No file given")
-- >
-- >     storedFile <- storeFile file "logos"
-- >
-- >     let url = storedFile.url
-- >
--
storeFile :: (?context :: context, ConfigProvider context) => Wai.FileInfo LByteString -> Text -> IO StoredFile
storeFile :: forall context.
(?context::context, ConfigProvider context) =>
FileInfo LByteString -> Text -> IO StoredFile
storeFile FileInfo LByteString
fileInfo Text
directory = FileInfo LByteString -> StoreFileOptions -> IO StoredFile
forall context.
(?context::context, ConfigProvider context) =>
FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions FileInfo LByteString
fileInfo (StoreFileOptions
forall a. Default a => a
def { directory })


-- | Like 'storeFile' but with more options.
--
-- See 'storeFileWithOptions' for more advanced use cases.
--
-- __Example:__ Save a file to @my_files@ directory and specify a 'Content-Disposition: attachment; filename="$filename"' header
--
-- > let file = fileOrNothing "file" |> fromMaybe (error "no file given")
-- >
-- > let options :: StoreFileOptions = def
-- >         { directory = "my_files"
-- >         , contentDisposition = contentDispositionAttachmentAndFileName
-- >         }
-- >
-- > storedFile <- storeFileWithOptions file options
-- > let url = storedFile.url
--
--
-- __Example:__ Transform an uploaded image to a JPEG file, strip meta data and store it inside the @pictures@ directory
--
-- > let file = fileOrNothing "file" |> fromMaybe (error "no file given")
-- >
-- > let options :: StoreFileOptions = def
-- >         { directory = "pictures"
-- >         , preprocess = applyImageMagick "jpg" "-strip"
-- >         }
-- >
-- > storedFile <- storeFileWithOptions file options
-- > let url = storedFile.url
--
storeFileWithOptions :: (?context :: context, ConfigProvider context) => Wai.FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions :: forall context.
(?context::context, ConfigProvider context) =>
FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions FileInfo LByteString
fileInfo StoreFileOptions
options = do
    objectId <- IO UUID
UUID.nextRandom

    let fileName = StoreFileOptions
options.fileName Maybe UUID -> (Maybe UUID -> UUID) -> UUID
forall a b. a -> (a -> b) -> b
|> UUID -> Maybe UUID -> UUID
forall a. a -> Maybe a -> a
fromMaybe UUID
objectId

    let objectPath = StoreFileOptions
options.directory Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UUID -> Text
UUID.toText UUID
fileName
    let preprocess = StoreFileOptions
options.preprocess

    fileInfo <- preprocess fileInfo

    url <- case storage of
        StaticDirStorage { Text
directory :: Text
directory :: FileStorage -> Text
directory } -> do
            let Text
destPath :: Text = Text
directory Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectPath
            dirOsPath <- FilePath -> IO OsPath
forall (m :: * -> *). MonadThrow m => FilePath -> m OsPath
encodeUtf (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
directory Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFileOptions
options.directory)
            Directory.createDirectoryIfMissing True dirOsPath

            fileInfo
                |> (.fileContent)
                |> LBS.writeFile (cs destPath)

            let frameworkConfig = context
?context::context
?context.frameworkConfig
            -- Prefix with a slash so it can be used in URLs, even if the baseUrl is empty.
            pure $ "/" <> objectPath
        S3Storage { ConnectInfo
connectInfo :: ConnectInfo
connectInfo :: FileStorage -> ConnectInfo
connectInfo, Text
bucket :: Text
bucket :: FileStorage -> Text
bucket, Text
baseUrl :: Text
baseUrl :: FileStorage -> Text
baseUrl } -> do
            let payload :: ConduitT () ByteString Minio ()
payload = FileInfo LByteString
fileInfo
                    FileInfo LByteString
-> (FileInfo LByteString -> LByteString) -> LByteString
forall a b. a -> (a -> b) -> b
|> (.fileContent)
                    LByteString
-> (LByteString -> ConduitT () ByteString Minio ())
-> ConduitT () ByteString Minio ()
forall a b. a -> (a -> b) -> b
|> LByteString -> ConduitT () ByteString Minio ()
forall (m :: * -> *) i.
Monad m =>
LByteString -> ConduitT i ByteString m ()
Conduit.sourceLbs

            let contentType :: Text
contentType = ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (FileInfo LByteString -> ByteString
forall c. FileInfo c -> ByteString
Wai.fileContentType FileInfo LByteString
fileInfo)
            contentDisposition <- (StoreFileOptions
options.contentDisposition) FileInfo LByteString
fileInfo
            trySaveFile <- runMinio connectInfo do
                let options :: PutObjectOptions = defaultPutObjectOptions { pooContentType = Just contentType, pooContentDisposition = contentDisposition }
                putObject bucket objectPath payload Nothing options
            case trySaveFile of
                Left MinioErr
e -> MinioErr -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw MinioErr
e
                Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

            pure $ baseUrl <> objectPath

    pure StoredFile { path = objectPath, url }

-- | Fetches an url and uploads it to the storage.
--
-- The stored file has the content type provided by @Content-Type@ header of the downloaded file.
--
-- __Example:__ Copy a file from a remote server to the @pictures@ directory
--
-- > let externalUrl = "http://example/picture.jpg"
-- >
-- > let options :: StoreFileOptions = def
-- >         { directory = "pictures"
-- >         }
-- >
-- > storedFile <- storeFileFromUrl externalUrl options
-- > let newUrl = storedFile.url
--
storeFileFromUrl :: (?context :: context, ConfigProvider context) => Text -> StoreFileOptions -> IO StoredFile
storeFileFromUrl :: forall context.
(?context::context, ConfigProvider context) =>
Text -> StoreFileOptions -> IO StoredFile
storeFileFromUrl Text
url StoreFileOptions
options = do
    (contentType, responseBody) <- do
        response <- FilePath -> IO (Response LByteString)
Wreq.get (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs Text
url)
        let contentType = Response LByteString
response Response LByteString
-> Getting ByteString (Response LByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. HeaderName -> Traversal' (Response LByteString) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
Wreq.responseHeader HeaderName
"Content-Type"
        let responseBody = Response LByteString
response Response LByteString
-> Getting LByteString (Response LByteString) LByteString
-> LByteString
forall s a. s -> Getting a s a -> a
^. Getting LByteString (Response LByteString) LByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
Wreq.responseBody
        pure (contentType, responseBody)

    let file = Wai.FileInfo
            { fileName :: ByteString
fileName = ByteString
""
            , fileContentType :: ByteString
fileContentType = ByteString
contentType
            , fileContent :: LByteString
fileContent = LByteString
responseBody
            }

    storeFileWithOptions file options


-- | Uploads a local file to the storage
--
-- The content type is guessed based on the file extension.
--
-- __Example:__ Copy a local "picture.jpg" to the @pictures@ directory inside the storage
--
-- >
-- > let options :: StoreFileOptions = def
-- >         { directory = "pictures"
-- >         }
-- >
-- > storedFile <- storeFileFromPath "picture.jpg" options
-- > let newUrl = storedFile.url
--
storeFileFromPath :: (?context :: context, ConfigProvider context) => Text -> StoreFileOptions -> IO StoredFile
storeFileFromPath :: forall context.
(?context::context, ConfigProvider context) =>
Text -> StoreFileOptions -> IO StoredFile
storeFileFromPath Text
path StoreFileOptions
options = do
    let fileContentType :: ByteString
fileContentType = Text -> ByteString
Mime.defaultMimeLookup (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
path)

    fileContent <- FilePath -> IO LByteString
LBS.readFile (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs Text
path)

    -- If fileName was passed (as UUID), use it. Otherwise, keep it empty, and a new random UUID will be generated.
    let fileName = case StoreFileOptions
options.fileName of
            Just UUID
name -> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ UUID -> Text
UUID.toText UUID
name
            Maybe UUID
Nothing -> ByteString
""

    let file = Wai.FileInfo
            { fileName :: ByteString
fileName = ByteString
fileName
            , ByteString
fileContentType :: ByteString
fileContentType :: ByteString
fileContentType
            , LByteString
fileContent :: LByteString
fileContent :: LByteString
fileContent
            }

    storeFileWithOptions file options

-- | Returns a signed url for a path inside the storage. The url is valid for 7 days.
--
-- If the 'StaticDirStorage' is used, a unsigned normal URL will be returned, as these files are public anyways.
--
-- __Example:__ Get a signed url for a path
--
-- >
-- > signedUrl <- createTemporaryDownloadUrlFromPath "logos/8ed22caa-11ea-4c45-a05e-91a51e72558d"
-- >
-- > let url :: Text = signedUrl.url
-- > let expiredAt :: UTCTime = signedUrl.expiredAt
--
-- See 'createTemporaryDownloadUrlFromPathWithExpiredAt' if you want to customize the url expiration time of 7 days.
--
createTemporaryDownloadUrlFromPath :: (?context :: context, ConfigProvider context) => Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPath :: forall context.
(?context::context, ConfigProvider context) =>
Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPath Text
objectPath = Int -> Text -> IO TemporaryDownloadUrl
forall context.
(?context::context, ConfigProvider context) =>
Int -> Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPathWithExpiredAt (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3600) Text
objectPath


-- | Like 'createTemporaryDownloadUrlFromPath', but with a custom expiration time. Returns a signed url for a path inside the storage. The url is valid for 7 days.
--
-- If the 'StaticDirStorage' is used, a unsigned normal URL will be returned, as these files are public anyways.
--
-- __Example:__ Get a signed url for a path that expires in 5 minutes
--
-- > let validInSeconds = 5 * 60
-- > signedUrl <- createTemporaryDownloadUrlFromPathWithExpiredAt validInSeconds "logos/8ed22caa-11ea-4c45-a05e-91a51e72558d"
-- >
-- > let url :: Text = signedUrl.url
-- > let expiredAt :: UTCTime = signedUrl.expiredAt
--
createTemporaryDownloadUrlFromPathWithExpiredAt :: (?context :: context, ConfigProvider context) => Int -> Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPathWithExpiredAt :: forall context.
(?context::context, ConfigProvider context) =>
Int -> Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPathWithExpiredAt Int
validInSeconds Text
objectPath = do
    publicUrlExpiredAt <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
validInSeconds) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    case storage of
        StaticDirStorage {} -> do
            let frameworkConfig :: FrameworkConfig
frameworkConfig = context
?context::context
?context.frameworkConfig
            let urlSchemes :: [Text]
urlSchemes = [Text
"http://", Text
"https://"]

            let cleanPath :: Text
cleanPath = if Text
"/" Text -> Text -> Bool
`isPrefixOf` Text
objectPath
                    then Int -> Text -> Text
Text.drop Int
1 Text
objectPath
                    else Text
objectPath

            let url :: Text
url = if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`isPrefixOf` Text
objectPath) [Text]
urlSchemes
                    -- Legacy case: full URL saved, use as is.
                    then Text
objectPath
                    -- Otherwise, construct full URL using baseUrl and cleaned path.
                    else FrameworkConfig
frameworkConfig.baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cleanPath

            TemporaryDownloadUrl -> IO TemporaryDownloadUrl
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TemporaryDownloadUrl { url :: Text
url = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
url, expiredAt :: UTCTime
expiredAt = UTCTime
publicUrlExpiredAt }
        S3Storage { ConnectInfo
connectInfo :: FileStorage -> ConnectInfo
connectInfo :: ConnectInfo
connectInfo, Text
bucket :: FileStorage -> Text
bucket :: Text
bucket} -> do

            url <- ConnectInfo -> Minio ByteString -> IO (Either MinioErr ByteString)
forall a. ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ConnectInfo
connectInfo do
                Text -> Text -> Int -> Query -> RequestHeaders -> Minio ByteString
presignedGetObjectUrl Text
bucket Text
objectPath Int
validInSeconds [] []

            case url of
                Left MinioErr
message -> Text -> IO TemporaryDownloadUrl
forall a. Text -> a
error (MinioErr -> Text
forall a. Show a => a -> Text
tshow MinioErr
message)
                Right ByteString
url -> TemporaryDownloadUrl -> IO TemporaryDownloadUrl
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TemporaryDownloadUrl { url :: Text
url = ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
url, expiredAt :: UTCTime
expiredAt = UTCTime
publicUrlExpiredAt }

-- | Returns a signed url for a 'StoredFile'. The url is valid for 7 days.
--
-- If the 'StaticDirStorage' is used, a unsigned normal URL will be returned, as these files are public anyways.
--
-- __Example:__ Get a signed url for a stored file using 'createTemporaryDownloadUrl'
--
-- > let file = fileOrNothing "file"
-- >         |> fromMaybe (error "No file given")
-- >
-- > storedFile <- storeFile file "logos"
-- >
-- > signedUrl <- createTemporaryDownloadUrl storedFile
-- >
-- > let url :: Text = signedUrl.url
-- > let expiredAt :: UTCTime = signedUrl.expiredAt
--
createTemporaryDownloadUrl :: (?context :: context, ConfigProvider context) => StoredFile -> IO TemporaryDownloadUrl
createTemporaryDownloadUrl :: forall context.
(?context::context, ConfigProvider context) =>
StoredFile -> IO TemporaryDownloadUrl
createTemporaryDownloadUrl StoredFile
storedFile = Text -> IO TemporaryDownloadUrl
forall context.
(?context::context, ConfigProvider context) =>
Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPath (StoredFile
storedFile.path)

-- | Use the temporary download URL if the current one is not expired.
-- Otherwise, create a new temporary download URL and update the record.
--
-- __Example:__ Fetch an 'UploadedFile' record (a custom record with @signedUrl@, @signedUrlExpiredAt@ and @path@ ) and use 'refreshTemporaryDownloadUrlFromFile'
-- to get a fresh signed url if expired date has passed.
-- and update it with the signed url.
--
-- > uploadedFile <- fetch uploadedFileId
-- > uploadedFile <- refreshTemporaryDownloadUrlFromFile uploadedFile
refreshTemporaryDownloadUrlFromFile ::
    ( ?modelContext::ModelContext
    , ?context :: context
    , ConfigProvider context
    , CanUpdate record
    , HasField "signedUrl" record Text
    , HasField "signedUrlExpiredAt" record UTCTime
    , HasField "path" record Text
    , SetField "signedUrl" record Text
    , SetField "signedUrlExpiredAt" record UTCTime
    , SetField "path" record Text
    ) => record  -> IO record
refreshTemporaryDownloadUrlFromFile :: forall context record.
(?modelContext::ModelContext, ?context::context,
 ConfigProvider context, CanUpdate record,
 HasField "signedUrl" record Text,
 HasField "signedUrlExpiredAt" record UTCTime,
 HasField "path" record Text, SetField "signedUrl" record Text,
 SetField "signedUrlExpiredAt" record UTCTime,
 SetField "path" record Text) =>
record -> IO record
refreshTemporaryDownloadUrlFromFile record
record = do
    now <- IO UTCTime
getCurrentTime
    let diff = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now record
record.signedUrlExpiredAt
    if diff > 0
        then do
            temporaryDownloadUrl <- createTemporaryDownloadUrlFromPath record.path
            record
                |> set #signedUrl (temporaryDownloadUrl |> get #url)
                |> set #signedUrlExpiredAt (temporaryDownloadUrl |> get #expiredAt)
                |> updateRecord

        else
            pure record

contentDispositionAttachmentAndFileName :: Wai.FileInfo LByteString -> IO (Maybe Text)
contentDispositionAttachmentAndFileName :: FileInfo LByteString -> IO (Maybe Text)
contentDispositionAttachmentAndFileName FileInfo LByteString
fileInfo = Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"attachment; filename=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (FileInfo LByteString
fileInfo.fileName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""))

-- | Saves an upload to the storage and sets the record attribute to the url.
--
-- __Example:__ Upload a logo for a Company and convert it to a 512x512 PNG
--
-- > action UpdateCompanyAction { companyId } = do
-- >     let uploadLogo = uploadToStorageWithOptions $ def
-- >             { preprocess = applyImageMagick "png" "-resize '512x512^' -gravity north -extent 512x512 -quality 100% -strip"  }
-- >
-- >     company <- fetch companyId
-- >     company
-- >         |> fill @'["name"]
-- >         |> uploadLogo #logoUrl
-- >         >>= ifValid \case
-- >             Left company -> render EditView { .. }
-- >             Right company -> do
-- >                 company <- company |> updateRecord
-- >                 redirectTo EditCompanyAction { .. }
--
uploadToStorageWithOptions :: forall (fieldName :: Symbol) record (tableName :: Symbol). (
        ?context :: ControllerContext
        , ?request :: Request
        , SetField fieldName record (Maybe Text)
        , KnownSymbol fieldName
        , HasField "id" record (ModelSupport.Id (ModelSupport.NormalizeModel record))
        , Show (ModelSupport.PrimaryKey (ModelSupport.GetTableName (ModelSupport.NormalizeModel record)))
        , tableName ~ ModelSupport.GetTableName record
        , KnownSymbol tableName
        , HasField "meta" record MetaBag
        , SetField "meta" record MetaBag
    ) => StoreFileOptions -> Proxy fieldName -> record -> IO record
uploadToStorageWithOptions :: forall (fieldName :: Symbol) record (tableName :: Symbol).
(?context::ControllerContext, ?request::Request,
 SetField fieldName record (Maybe Text), KnownSymbol fieldName,
 HasField "id" record (Id (NormalizeModel record)),
 Show (PrimaryKey (GetTableName (NormalizeModel record))),
 tableName ~ GetTableName record, KnownSymbol tableName,
 HasField "meta" record MetaBag, SetField "meta" record MetaBag) =>
StoreFileOptions -> Proxy fieldName -> record -> IO record
uploadToStorageWithOptions StoreFileOptions
options Proxy fieldName
field record
record = do
    let ByteString
fieldName :: ByteString = FilePath -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy fieldName -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @fieldName))
    let Text
tableName :: Text = FilePath -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy tableName -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @tableName))
    let directory :: Text
directory = Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
fieldName

    case (?request::Request) => ByteString -> Maybe (FileInfo LByteString)
ByteString -> Maybe (FileInfo LByteString)
fileOrNothing ByteString
fieldName of
        Just FileInfo LByteString
fileInfo -> do
            FileInfo LByteString -> StoreFileOptions -> IO StoredFile
forall context.
(?context::context, ConfigProvider context) =>
FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions FileInfo LByteString
fileInfo StoreFileOptions
options { directory }
            IO StoredFile
-> (IO StoredFile -> IO (Either SomeException StoredFile))
-> IO (Either SomeException StoredFile)
forall a b. a -> (a -> b) -> b
|> IO StoredFile -> IO (Either SomeException StoredFile)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
Exception.try
            IO (Either SomeException StoredFile)
-> (Either SomeException StoredFile -> IO record) -> IO record
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left (SomeException
exception :: SomeException) -> record
record
                            record -> (record -> record) -> record
forall a b. a -> (a -> b) -> b
|> Proxy fieldName -> Text -> record -> record
forall (field :: Symbol) model.
(KnownSymbol field, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag) =>
Proxy field -> Text -> model -> model
attachFailure Proxy fieldName
field (Text
"Failed uploading to storage: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
show SomeException
exception)
                            record -> (record -> IO record) -> IO record
forall a b. a -> (a -> b) -> b
|> record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                Right StoredFile
storedFile -> record
record
                            record -> (record -> record) -> record
forall a b. a -> (a -> b) -> b
|> forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @fieldName (Text -> Maybe Text
forall a. a -> Maybe a
Just (StoredFile
storedFile.url))
                            record -> (record -> IO record) -> IO record
forall a b. a -> (a -> b) -> b
|> record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

        Maybe (FileInfo LByteString)
_ -> record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure record
record

-- | Saves an upload to the storage and sets the record attribute to the url.
--
-- Uses the table name of the record as the upload directory (e.g. @companies@ when saving an attachment for a @Company@ record).
--
-- See 'uploadToStorageWithOptions' if you want to provide custom options.
--
-- __Example:__ Upload a logo for a Company
--
-- > action UpdateCompanyAction { companyId } = do
-- >     company <- fetch companyId
-- >     company
-- >         |> fill @'["name"]
-- >         |> uploadToStorage #logoUrl
-- >         >>= ifValid \case
-- >             Left company -> render EditView { .. }
-- >             Right company -> do
-- >                 company <- company |> updateRecord
-- >                 redirectTo EditCompanyAction { .. }
--
uploadToStorage :: forall (fieldName :: Symbol) record (tableName :: Symbol). (
        ?context :: ControllerContext
        , ?request :: Request
        , SetField fieldName record (Maybe Text)
        , KnownSymbol fieldName
        , HasField "id" record (ModelSupport.Id (ModelSupport.NormalizeModel record))
        , Show (ModelSupport.PrimaryKey (ModelSupport.GetTableName (ModelSupport.NormalizeModel record)))
        , tableName ~ ModelSupport.GetTableName record
        , KnownSymbol tableName
        , HasField "meta" record MetaBag
        , SetField "meta" record MetaBag
    ) => Proxy fieldName -> record -> IO record
uploadToStorage :: forall (fieldName :: Symbol) record (tableName :: Symbol).
(?context::ControllerContext, ?request::Request,
 SetField fieldName record (Maybe Text), KnownSymbol fieldName,
 HasField "id" record (Id (NormalizeModel record)),
 Show (PrimaryKey (GetTableName (NormalizeModel record))),
 tableName ~ GetTableName record, KnownSymbol tableName,
 HasField "meta" record MetaBag, SetField "meta" record MetaBag) =>
Proxy fieldName -> record -> IO record
uploadToStorage Proxy fieldName
field record
record = StoreFileOptions -> Proxy fieldName -> record -> IO record
forall (fieldName :: Symbol) record (tableName :: Symbol).
(?context::ControllerContext, ?request::Request,
 SetField fieldName record (Maybe Text), KnownSymbol fieldName,
 HasField "id" record (Id (NormalizeModel record)),
 Show (PrimaryKey (GetTableName (NormalizeModel record))),
 tableName ~ GetTableName record, KnownSymbol tableName,
 HasField "meta" record MetaBag, SetField "meta" record MetaBag) =>
StoreFileOptions -> Proxy fieldName -> record -> IO record
uploadToStorageWithOptions StoreFileOptions
forall a. Default a => a
def Proxy fieldName
field record
record

-- | Permanently removes a previously stored file from storage.
--
-- __Example:__ Delete a previously uploaded file. The objectPath and url are stored in the database in this example.
--
-- > action DeleteUploadedFileAction { uploadedFileId } = do
-- >     uploadedFile <- fetch uploadedFile
-- >     let storedFile = StoredFile
-- >             { path = uploadedFile.objectPath
-- >             , url = uploadedFile.url
-- >             }
-- >     removeFileFromStorage storedFile
-- >     deleteRecord uploadedFile
-- >     redirectTo UploadedFilesAction
removeFileFromStorage :: (?context :: context, ConfigProvider context) => StoredFile -> IO (Either MinioErr ())
removeFileFromStorage :: forall context.
(?context::context, ConfigProvider context) =>
StoredFile -> IO (Either MinioErr ())
removeFileFromStorage StoredFile { Text
path :: StoredFile -> Text
path :: Text
path, Text
url :: StoredFile -> Text
url :: Text
url } = do
    case FileStorage
forall context.
(?context::context, ConfigProvider context) =>
FileStorage
storage of
        StaticDirStorage { Text
directory :: FileStorage -> Text
directory :: Text
directory } -> do
            fullOsPath <- FilePath -> IO OsPath
forall (m :: * -> *). MonadThrow m => FilePath -> m OsPath
encodeUtf (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
directory Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
            Directory.removeFile fullOsPath
            pure $ Right ()
        S3Storage { ConnectInfo
connectInfo :: FileStorage -> ConnectInfo
connectInfo :: ConnectInfo
connectInfo, Text
bucket :: FileStorage -> Text
bucket :: Text
bucket} -> do
            ConnectInfo -> Minio () -> IO (Either MinioErr ())
forall a. ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ConnectInfo
connectInfo do
              Text -> Text -> Minio ()
removeObject Text
bucket Text
path

-- | Returns the current storage configured in Config.hs
storage :: (?context :: context, ConfigProvider context) => FileStorage
storage :: forall context.
(?context::context, ConfigProvider context) =>
FileStorage
storage = context
?context::context
?context.frameworkConfig.appConfig
        TMap -> (TMap -> Maybe FileStorage) -> Maybe FileStorage
forall a b. a -> (a -> b) -> b
|> forall a. Typeable a => TMap -> Maybe a
TMap.lookup @FileStorage
        Maybe FileStorage
-> (Maybe FileStorage -> FileStorage) -> FileStorage
forall a b. a -> (a -> b) -> b
|> FileStorage -> Maybe FileStorage -> FileStorage
forall a. a -> Maybe a -> a
fromMaybe (Text -> FileStorage
forall a. Text -> a
error Text
"Could not find FileStorage in config. Did you call initS3Storage from your Config.hs?")

-- | Returns the prefix for the storage. This is either @static/@ or an empty string depending on the storage.
storagePrefix :: (?context :: ControllerContext) => Text
storagePrefix :: (?context::ControllerContext) => Text
storagePrefix = case FileStorage
forall context.
(?context::context, ConfigProvider context) =>
FileStorage
storage of
    StaticDirStorage { Text
directory :: FileStorage -> Text
directory :: Text
directory } -> Text
directory
    S3Storage { Text
baseUrl :: FileStorage -> Text
baseUrl :: Text
baseUrl} -> Text
baseUrl