{-|
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
, uploadToStorage
, uploadToStorageWithOptions
) 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 = get #url storedFile
-- >
--
storeFile :: (?context :: context, ConfigProvider context) => Wai.FileInfo LByteString -> Text -> IO StoredFile
storeFile :: 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 { Text
$sel:directory:StoreFileOptions :: Text
directory :: Text
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 = get #url storedFile
--
--
-- __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 = get #url storedFile
--
storeFileWithOptions :: (?context :: context, ConfigProvider context) => Wai.FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions :: FileInfo LByteString -> StoreFileOptions -> IO StoredFile
storeFileWithOptions FileInfo LByteString
fileInfo StoreFileOptions
options = do
    UUID
objectId <- IO UUID
UUID.nextRandom

    let directory :: Text
directory = Proxy "directory" -> StoreFileOptions -> Text
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "directory" (Proxy "directory")
Proxy "directory"
#directory StoreFileOptions
options
    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
objectId
    let preprocess :: FileInfo LByteString -> IO (FileInfo LByteString)
preprocess = Proxy "preprocess"
-> StoreFileOptions
-> FileInfo LByteString
-> IO (FileInfo LByteString)
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "preprocess" (Proxy "preprocess")
Proxy "preprocess"
#preprocess StoreFileOptions
options

    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
|> Proxy "fileContent" -> FileInfo LByteString -> LByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "fileContent" (Proxy "fileContent")
Proxy "fileContent"
#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 -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig context
?context::context
?context
            Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ (Proxy "baseUrl" -> FrameworkConfig -> Text
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "baseUrl" (Proxy "baseUrl")
Proxy "baseUrl"
#baseUrl FrameworkConfig
frameworkConfig) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectPath
        S3Storage { ConnectInfo
$sel:connectInfo:StaticDirStorage :: FileStorage -> ConnectInfo
connectInfo :: ConnectInfo
connectInfo, Text
$sel:bucket:StaticDirStorage :: FileStorage -> Text
bucket :: Text
bucket, Text
$sel:baseUrl:StaticDirStorage :: FileStorage -> Text
baseUrl :: 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
|> Proxy "fileContent" -> FileInfo LByteString -> LByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "fileContent" (Proxy "fileContent")
Proxy "fileContent"
#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 <- (Proxy "contentDisposition"
-> StoreFileOptions -> FileInfo LByteString -> IO (Maybe Text)
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "contentDisposition" (Proxy "contentDisposition")
Proxy "contentDisposition"
#contentDisposition StoreFileOptions
options) 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 :: Maybe Text
pooContentType = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
contentType, pooContentDisposition :: Maybe Text
pooContentDisposition = Maybe Text
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

            Text -> IO Text
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 (f :: * -> *) a. Applicative f => a -> f a
pure StoredFile :: Text -> Text -> StoredFile
StoredFile { $sel:path:StoredFile :: Text
path = Text
objectPath, Text
$sel:url:StoredFile :: 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 = get #url storedFile
--
storeFileFromUrl :: (?context :: context, ConfigProvider context) => Text -> StoreFileOptions -> IO StoredFile
storeFileFromUrl :: 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.
Lens (Response body0) (Response body1) body0 body1
Wreq.responseBody
        (ByteString, LByteString) -> IO (ByteString, LByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
contentType, LByteString
responseBody)

    let file :: FileInfo LByteString
file = FileInfo :: forall c. ByteString -> ByteString -> c -> FileInfo c
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 = get #url storedFile
--
storeFileFromPath :: (?context :: context, ConfigProvider context) => Text -> StoreFileOptions -> IO StoredFile
storeFileFromPath :: 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 = FileInfo :: forall c. ByteString -> ByteString -> c -> FileInfo c
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 = get #url signedUrl
-- > let expiredAt :: UTCTime = get #expiredAt signedUrl
--
-- See 'createTemporaryDownloadUrlFromPathWithExpiredAt' if you want to customize the url expiration time of 7 days.
--
createTemporaryDownloadUrlFromPath :: (?context :: context, ConfigProvider context) => Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPath :: 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 = get #url signedUrl
-- > let expiredAt :: UTCTime = get #expiredAt signedUrl
--
createTemporaryDownloadUrlFromPathWithExpiredAt :: (?context :: context, ConfigProvider context) => Int -> Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPathWithExpiredAt :: 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 -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig context
?context::context
?context
            let url :: Text
url = (Proxy "baseUrl" -> FrameworkConfig -> Text
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "baseUrl" (Proxy "baseUrl")
Proxy "baseUrl"
#baseUrl FrameworkConfig
frameworkConfig) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectPath

            TemporaryDownloadUrl -> IO TemporaryDownloadUrl
forall (f :: * -> *) a. Applicative f => a -> f a
pure TemporaryDownloadUrl :: Text -> UTCTime -> TemporaryDownloadUrl
TemporaryDownloadUrl { $sel:url:TemporaryDownloadUrl :: Text
url = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
url, $sel:expiredAt:TemporaryDownloadUrl :: UTCTime
expiredAt = UTCTime
publicUrlExpiredAt }
        S3Storage { ConnectInfo
connectInfo :: ConnectInfo
$sel:connectInfo:StaticDirStorage :: FileStorage -> ConnectInfo
connectInfo, Text
bucket :: Text
$sel:bucket:StaticDirStorage :: FileStorage -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure TemporaryDownloadUrl :: Text -> UTCTime -> TemporaryDownloadUrl
TemporaryDownloadUrl { $sel:url:TemporaryDownloadUrl :: Text
url = ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
url, $sel:expiredAt:TemporaryDownloadUrl :: 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 = get #url signedUrl
-- > let expiredAt :: UTCTime = get #expiredAt signedUrl
--
createTemporaryDownloadUrl :: (?context :: context, ConfigProvider context) => StoredFile -> IO TemporaryDownloadUrl
createTemporaryDownloadUrl :: StoredFile -> IO TemporaryDownloadUrl
createTemporaryDownloadUrl StoredFile
storedFile = Text -> IO TemporaryDownloadUrl
forall context.
(?context::context, ConfigProvider context) =>
Text -> IO TemporaryDownloadUrl
createTemporaryDownloadUrlFromPath (Proxy "path" -> StoredFile -> Text
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "path" (Proxy "path")
Proxy "path"
#path StoredFile
storedFile)

contentDispositionAttachmentAndFileName :: Wai.FileInfo LByteString -> IO (Maybe Text)
contentDispositionAttachmentAndFileName :: FileInfo LByteString -> IO (Maybe Text)
contentDispositionAttachmentAndFileName FileInfo LByteString
fileInfo = Maybe Text -> IO (Maybe Text)
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 (Proxy "fileName" -> FileInfo LByteString -> ByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "fileName" (Proxy "fileName")
Proxy "fileName"
#fileName FileInfo LByteString
fileInfo) 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 :: 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 (Proxy fieldName
forall k (t :: k). 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 (Proxy tableName
forall k (t :: k). 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 | Bool -> Bool
not (LByteString -> Bool
LBS.null (Proxy "fileContent" -> FileInfo LByteString -> LByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "fileContent" (Proxy "fileContent")
Proxy "fileContent"
#fileContent 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 { Text
directory :: Text
$sel:directory:StoreFileOptions :: Text
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure
                Right StoredFile
storedFile -> record
record
                            record -> (record -> record) -> record
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Maybe Text -> record -> record
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @fieldName (Text -> Maybe Text
forall a. a -> Maybe a
Just (Proxy "url" -> StoredFile -> Text
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "url" (Proxy "url")
Proxy "url"
#url StoredFile
storedFile))
                            record -> (record -> IO record) -> IO record
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> record -> IO record
forall (f :: * -> *) a. Applicative f => a -> f a
pure

        Maybe (FileInfo LByteString)
_ -> record -> IO record
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 :: 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 = get #objectPath uploadedFile
-- >             , url = get #url uploadedFile
-- >             }
-- >     removeFileFromStorage storedFile
-- >     deleteRecord uploadedFile
-- >     redirectTo UploadedFilesAction
removeFileFromStorage :: (?context :: context, ConfigProvider context) => StoredFile -> IO (Either MinioErr ())
removeFileFromStorage :: StoredFile -> IO (Either MinioErr ())
removeFileFromStorage StoredFile { Text
path :: Text
$sel:path:StoredFile :: StoredFile -> Text
path, Text
url :: Text
$sel:url:StoredFile :: StoredFile -> 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 (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 :: ConnectInfo
$sel:connectInfo:StaticDirStorage :: FileStorage -> ConnectInfo
connectInfo, Text
bucket :: Text
$sel:bucket:StaticDirStorage :: FileStorage -> 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 :: FileStorage
storage = context -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig context
?context::context
?context
        FrameworkConfig -> (FrameworkConfig -> TMap) -> TMap
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "appConfig" -> FrameworkConfig -> TMap
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "appConfig" (Proxy "appConfig")
Proxy "appConfig"
#appConfig
        TMap -> (TMap -> Maybe FileStorage) -> Maybe FileStorage
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Typeable FileStorage => TMap -> Maybe FileStorage
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?")