{-|
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 qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import qualified Data.TMap as TMap
import qualified Data.ByteString.Lazy as LBS
import qualified System.Directory as Directory
import qualified Control.Exception as Exception
import qualified Network.Wreq as Wreq
import Control.Lens hiding ((|>), set)
import IHP.FileStorage.MimeTypes

-- | 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
    UUID
objectId <- IO UUID
UUID.nextRandom

    let fileName :: UUID
fileName = StoreFileOptions
options.fileName Maybe UUID -> (Maybe UUID -> UUID) -> UUID
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> UUID -> Maybe UUID -> UUID
forall a. a -> Maybe a -> a
fromMaybe UUID
objectId

    let directory :: Text
directory = StoreFileOptions
options.directory
    let objectPath :: Text
objectPath = Text
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 :: FileInfo LByteString -> IO (FileInfo LByteString)
preprocess = StoreFileOptions
options.preprocess

    FileInfo LByteString
fileInfo <- FileInfo LByteString -> IO (FileInfo LByteString)
preprocess FileInfo LByteString
fileInfo

    Text
url <- case FileStorage
forall context.
(?context::context, ConfigProvider context) =>
FileStorage
storage of
        FileStorage
StaticDirStorage -> do
            let Text
destPath :: Text = Text
"static/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectPath
            Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
True (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"static/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
directory)

            FileInfo LByteString
fileInfo
                FileInfo LByteString
-> (FileInfo LByteString -> LByteString) -> LByteString
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (.fileContent)
                LByteString -> (LByteString -> IO ()) -> IO ()
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> FilePath -> LByteString -> IO ()
LBS.writeFile (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs Text
destPath)

            let frameworkConfig :: FrameworkConfig
frameworkConfig = context
?context::context
?context.frameworkConfig
            -- Prefix with a slash so it can be used in URLs, even if the baseUrl is empty.
            Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (.fileContent)
                    LByteString
-> (LByteString -> ConduitT () ByteString Minio ())
-> ConduitT () ByteString Minio ()
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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)
            Maybe Text
contentDisposition <- (StoreFileOptions
options.contentDisposition) FileInfo LByteString
fileInfo
            Either MinioErr ()
trySaveFile <- ConnectInfo -> Minio () -> IO (Either MinioErr ())
forall a. ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ConnectInfo
connectInfo do
                let PutObjectOptions
options :: PutObjectOptions = PutObjectOptions
defaultPutObjectOptions { pooContentType = Just contentType, pooContentDisposition = contentDisposition }
                Text
-> Text
-> ConduitT () ByteString Minio ()
-> Maybe Int64
-> PutObjectOptions
-> Minio ()
putObject Text
bucket Text
objectPath ConduitT () ByteString Minio ()
payload Maybe Int64
forall a. Maybe a
Nothing PutObjectOptions
options
            case Either MinioErr ()
trySaveFile of
                Left MinioErr
e -> MinioErr -> IO ()
forall a e. Exception e => e -> a
throw MinioErr
e
                Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

            Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectPath

    StoredFile -> IO StoredFile
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StoredFile { path :: Text
path = Text
objectPath, Text
url :: Text
url :: Text
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
    (ByteString
contentType, LByteString
responseBody) <- do
        Response LByteString
response <- FilePath -> IO (Response LByteString)
Wreq.get (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs Text
url)
        let contentType :: ByteString
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 :: LByteString
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
        (ByteString, LByteString) -> IO (ByteString, LByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
contentType, LByteString
responseBody)

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

    FileInfo LByteString -> StoreFileOptions -> IO StoredFile
forall context.
(?context::context, ConfigProvider context) =>
FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions FileInfo LByteString
file StoreFileOptions
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
path Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text
guessMimeType Text -> (Text -> ByteString) -> ByteString
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs

    LByteString
fileContent <- FilePath -> IO LByteString
LBS.readFile (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs Text
path)
    let file :: FileInfo LByteString
file = Wai.FileInfo
            { fileName :: ByteString
fileName = ByteString
""
            , ByteString
fileContentType :: ByteString
fileContentType :: ByteString
fileContentType
            , LByteString
fileContent :: LByteString
fileContent :: LByteString
fileContent
            }

    FileInfo LByteString -> StoreFileOptions -> IO StoredFile
forall context.
(?context::context, ConfigProvider context) =>
FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions FileInfo LByteString
file StoreFileOptions
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
    UTCTime
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 FileStorage
forall context.
(?context::context, ConfigProvider context) =>
FileStorage
storage of
        FileStorage
StaticDirStorage -> do
            let frameworkConfig :: FrameworkConfig
frameworkConfig = context
?context::context
?context.frameworkConfig
            let urlSchemes :: [Text]
urlSchemes = [Text
"http://", Text
"https://"]

            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
                    -- BC, before we saved only the relative path of a file, we saved the full URL. So use it as is.
                    then Text
objectPath
                    -- We have the relative path (prefixed with slash), so add the baseUrl.
                    else FrameworkConfig
frameworkConfig.baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectPath

            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

            Either MinioErr ByteString
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 Either MinioErr ByteString
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
    UTCTime
now <- IO UTCTime
getCurrentTime
    let diff :: NominalDiffTime
diff = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now record
record.signedUrlExpiredAt
    if NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0
        then do
            TemporaryDownloadUrl
temporaryDownloadUrl <- Text -> IO TemporaryDownloadUrl
forall context.
(?context::context, ConfigProvider context) =>
Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPath record
record.path
            record
record
                record -> (record -> record) -> record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Proxy "signedUrl" -> Text -> record -> record
forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set Proxy "signedUrl"
#signedUrl (TemporaryDownloadUrl
temporaryDownloadUrl TemporaryDownloadUrl -> (TemporaryDownloadUrl -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Proxy "url" -> TemporaryDownloadUrl -> Text
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy "url"
#url)
                record -> (record -> record) -> record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Proxy "signedUrlExpiredAt" -> UTCTime -> record -> record
forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set Proxy "signedUrlExpiredAt"
#signedUrlExpiredAt (TemporaryDownloadUrl
temporaryDownloadUrl TemporaryDownloadUrl
-> (TemporaryDownloadUrl -> UTCTime) -> UTCTime
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Proxy "expiredAt" -> TemporaryDownloadUrl -> UTCTime
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy "expiredAt"
#expiredAt)
                record -> (record -> IO record) -> IO record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> record -> IO record
forall a. (CanUpdate a, ?modelContext::ModelContext) => a -> IO a
updateRecord

        else
            record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure record
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
        , 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,
 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 (?context::ControllerContext) =>
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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> IO StoredFile -> IO (Either SomeException StoredFile)
forall e a. Exception e => IO a -> IO (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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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
        , 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,
 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,
 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
        FileStorage
StaticDirStorage -> do
            let FilePath
fullPath :: String = Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"static/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
            FilePath -> IO ()
Directory.removeFile FilePath
fullPath
            Either MinioErr () -> IO (Either MinioErr ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MinioErr () -> IO (Either MinioErr ()))
-> Either MinioErr () -> IO (Either MinioErr ())
forall a b. (a -> b) -> a -> b
$ () -> Either MinioErr ()
forall a b. b -> Either a b
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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Typeable a => TMap -> Maybe a
TMap.lookup @FileStorage
        Maybe FileStorage
-> (Maybe FileStorage -> FileStorage) -> FileStorage
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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
    FileStorage
StaticDirStorage -> Text
"static/"
    FileStorage
_ -> Text
""