{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-}

{-|
Module: IHP.Controller.FileUpload
Description: Easy access to uploaded files
Copyright: (c) digitally induced GmbH, 2020

This modules provides high-level file and image upload functionality.

All uploaded files are saved to the `uploads` directory. Given e.g. an User entity with @id = 550e8400-e29b-11d4-a716-446655440000@, the file is saved to @\/uploads\/users\/550e8400-e29b-11d4-a716-446655440000\/picture.jpg@. If the directory does not exists, it will be created.

-}
module IHP.Controller.FileUpload where

import IHP.Prelude

import Network.Wai.Parse (FileInfo, fileContent)
import qualified IHP.ModelSupport as ModelSupport
import qualified Data.ByteString.Lazy as LBS
import IHP.Controller.RequestContext
import IHP.Controller.Context
import qualified System.Process as Process

-- | Returns a file upload from the request as a ByteString.
--
-- Returns `Nothing` when the file is not found in the request body.
--
-- __Example:__
--
-- Given a form like this:
--
-- > <form method="POST" action={SubmitMarkdownAction}>
-- >     <input
-- >         type="file"
-- >         name="markdown"
-- >         accept="text/markdown, text/plain"
-- >     >
-- > </form>
--
-- The file can be accessed within the action like this:
--
-- > action SubmitMarkdownAction = do
-- >     let content :: Text =
-- >             fileOrNothing "markdown"
-- >             |> fromMaybe (error "no file given")
-- >             |> (.fileContent)
-- >             |> cs -- content is a LazyByteString, so we use `cs` to convert it to Text
-- >
--
-- See 'filesByName' if multiple files can be uploaded by the user in a single form submission.
--
-- See 'IHP.FileStorage.ControllerFunctions.storeFile' to upload the file to S3 or similar cloud storages.
--
fileOrNothing :: (?context :: ControllerContext) => ByteString -> Maybe (FileInfo LBS.ByteString)
fileOrNothing :: (?context::ControllerContext) =>
ByteString -> Maybe (FileInfo ByteString)
fileOrNothing !ByteString
name =
        case ?context::ControllerContext
ControllerContext
?context.requestContext.requestBody of
            FormBody { [File ByteString]
files :: [File ByteString]
files :: RequestBody -> [File ByteString]
files } ->
                -- Search for the file, and confirm it's not an empty one.
                case ByteString -> [File ByteString] -> Maybe (FileInfo ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
name [File ByteString]
files of
                    Just FileInfo ByteString
fileInfo | Bool -> Bool
not (ByteString -> Bool
LBS.null (FileInfo ByteString
fileInfo.fileContent)) -> FileInfo ByteString -> Maybe (FileInfo ByteString)
forall a. a -> Maybe a
Just FileInfo ByteString
fileInfo
                    Maybe (FileInfo ByteString)
_ -> Maybe (FileInfo ByteString)
forall a. Maybe a
Nothing
            RequestBody
_ -> Maybe (FileInfo ByteString)
forall a. Maybe a
Nothing

-- | Like 'fileOrNothing' but allows uploading multiple files in the same request
--
-- __Example:__
--
-- For uploading multiple files we need to set the multiple attribute on the file input:
--
-- > <form method="POST" action={SubmitMarkdownAction}>
-- >     <input
-- >         type="file"
-- >         name="markdown"
-- >         accept="text/markdown, text/plain"
-- >         multiple
-- >     >
-- > </form>
--
-- When the user selects multiple files, we can access them like this:
--
-- > action SubmitMarkdownAction = do
-- >     let contents :: [Text] =
-- >             filesByName "markdown"
-- >             |> map (.fileContent)
-- >             |> map cs -- content is a LazyByteString, so we use `cs` to convert it to Text
-- >
--
-- Use 'IHP.HaskellSupport.forEach' to store multiple files inside the cloud storage:
--
-- > action SubmitMarkdownAction = do
-- >     let markdownFiles = filesByName "markdown"
-- >
-- >     forEach markdownFiles \file -> do
-- >         storeFile file "notes"
-- >
-- >         pure ()
-- >
--
filesByName :: (?context :: ControllerContext) => ByteString -> [FileInfo LBS.ByteString]
filesByName :: (?context::ControllerContext) =>
ByteString -> [FileInfo ByteString]
filesByName !ByteString
name =
        case ?context::ControllerContext
ControllerContext
?context.requestContext.requestBody of
            FormBody { [File ByteString]
files :: RequestBody -> [File ByteString]
files :: [File ByteString]
files } -> [File ByteString]
files
                    [File ByteString]
-> ([File ByteString] -> [File ByteString]) -> [File ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (File ByteString -> Bool) -> [File ByteString] -> [File ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString
filename, FileInfo ByteString
_) -> ByteString
filename ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name)
                    [File ByteString]
-> ([File ByteString] -> [FileInfo ByteString])
-> [FileInfo ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (File ByteString -> FileInfo ByteString)
-> [File ByteString] -> [FileInfo ByteString]
forall a b. (a -> b) -> [a] -> [b]
map File ByteString -> FileInfo ByteString
forall a b. (a, b) -> b
snd
            RequestBody
_ -> []

-- | Options to be used together with 'uploadImageWithOptions'
--
-- __Example:__
--
-- > ImageUploadOptions { convertTo = "jpg", imageMagickOptions = "-resize '1024x1024^' -gravity north -extent 1024x1024 -quality 85% -strip" }
data ImageUploadOptions = ImageUploadOptions {
    -- | The file extension to be used when saving the file, e.g. @"jpg"@ or @"png"@.
      ImageUploadOptions -> Text
convertTo :: Text
    -- | Command line options passed to imagemagick. Can used for e.g. resizing, rotating, file size reduction.
    , ImageUploadOptions -> Text
imageMagickOptions :: Text
    }

-- | Saves an uploaded image file to the @uploads@ directory and writes the relative path to the given record attribute.
--
-- Given e.g. an User entity with @id = 550e8400-e29b-11d4-a716-446655440000@, the file is saved to @\/uploads\/users\/550e8400-e29b-11d4-a716-446655440000\/picture.jpg@.
--
-- Before saving, the image is converted using imagemagick. You can supply custom image magick options using the options attribute.
--
-- If the upload directory does not exists, it will be created.
--
-- __Example:__ Uploading a user profile picture
--
-- > let profilePictureOptions = ImageUploadOptions
-- >         { convertTo = "jpg"
-- >         , imageMagickOptions = "-resize '1024x1024^' -gravity north -extent 1024x1024 -quality 85% -strip"
-- >         }
-- >
-- > user
-- >     |> fill @["firstname", "lastname", "pictureUrl"]
-- >     |> uploadImageWithOptions profilePictureOptions #pictureUrl
-- >     >>= ifValid \case
-- >         Left user -> render EditView { .. }
-- >         Right user -> do
-- >             user <- user |> updateRecord
-- >             redirectTo EditUserAction { .. }
--
-- The uploaded image path is now stored in #pictureUrl.
uploadImageWithOptions :: 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
    ) => ImageUploadOptions -> Proxy fieldName -> record -> IO record
uploadImageWithOptions :: 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) =>
ImageUploadOptions -> Proxy fieldName -> record -> IO record
uploadImageWithOptions ImageUploadOptions
options Proxy fieldName
_ record
user =
    let
        ByteString
fieldName :: ByteString = String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy fieldName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @fieldName))
        Text
tableName :: Text = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy tableName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @tableName))
        Text
uploadDir :: Text = Text
"static"
        Text
baseImagePath :: Text = Text
"/uploads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id' (GetTableName (GetModelByTableName tableName)) -> Text
forall a. Show a => a -> Text
tshow record
user.id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/picture."
        Text
imagePath :: Text = Text
baseImagePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"jpg"
        uploadFilePath :: Text
uploadFilePath = Text
baseImagePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"upload"
    in case (?context::ControllerContext) =>
ByteString -> Maybe (FileInfo ByteString)
ByteString -> Maybe (FileInfo ByteString)
fileOrNothing ByteString
fieldName of
        Just FileInfo ByteString
file -> IO record -> IO record
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            ExitCode
_ <- String -> IO ExitCode
Process.system (String
"mkdir -p `dirname " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uploadFilePath) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`")
            let fullImagePath :: Text
fullImagePath = Text
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imagePath
            FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent FileInfo ByteString
file ByteString -> (ByteString -> IO ()) -> IO ()
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> String -> ByteString -> IO ()
LBS.writeFile (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uploadFilePath))
            String -> IO ProcessHandle
Process.runCommand (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text
"convert " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uploadFilePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"imageMagickOptions" ImageUploadOptions
options) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
fullImagePath))
            record
user
                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 (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
imagePath :: Text))
                record -> (record -> IO record) -> IO record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> record -> IO record
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        Maybe (FileInfo ByteString)
_ -> record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure record
user

-- | Saves an uploaded image file to the `uploads` directory.
--
-- Given e.g. an User entity with @id = 550e8400-e29b-11d4-a716-446655440000@, the file is saved to @\/uploads\/users\/550e8400-e29b-11d4-a716-446655440000\/picture.jpg@.
--
-- No transformation or validation is applied to the given uploaded file. If you need this, take a look at 'uploadImageWithOptions'.
--
-- __Example:__ Uploading a user profile picture
--
-- > let profilePictureOptions = ImageUploadOptions
-- >         { convertTo = "jpg"
-- >         , imageMagickOptions = "-resize '1024x1024^' -gravity north -extent 1024x1024 -quality 85% -strip"
-- >         }
-- >
-- > user
-- >     |> fill @["firstname", "lastname", "pictureUrl"]
-- >     |> uploadImageFile "png" #pictureUrl
-- >     >>= ifValid \case
-- >         Left user -> render EditView { .. }
-- >         Right user -> do
-- >             user <- user |> updateRecord
-- >             redirectTo EditUserAction { .. }
--
uploadImageFile :: 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
    ) => Text -> Proxy fieldName -> record -> IO record
uploadImageFile :: 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) =>
Text -> Proxy fieldName -> record -> IO record
uploadImageFile Text
ext Proxy fieldName
_ record
user =
    let
        ByteString
fieldName :: ByteString = String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy fieldName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @fieldName))
        Text
tableName :: Text = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy tableName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @tableName))
        Text
uploadDir :: Text = Text
"static"
        Text
imagePath :: Text = Text
"/uploads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id' (GetTableName (GetModelByTableName tableName)) -> Text
forall a. Show a => a -> Text
tshow record
user.id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/picture." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ext
    in case (?context::ControllerContext) =>
ByteString -> Maybe (FileInfo ByteString)
ByteString -> Maybe (FileInfo ByteString)
fileOrNothing ByteString
fieldName of
        Just FileInfo ByteString
file -> IO record -> IO record
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            ExitCode
_ <- String -> IO ExitCode
Process.system (String
"mkdir -p `dirname " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imagePath) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`")
            FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent FileInfo ByteString
file ByteString -> (ByteString -> IO ()) -> IO ()
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> String -> ByteString -> IO ()
LBS.writeFile (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imagePath)
            record
user
                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 (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
imagePath :: Text))
                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 ByteString)
_ -> record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure record
user

-- | Saves an uploaded png file. No validation or transformation applied.
-- See 'uploadImageFile' for details.
uploadPng ::
    ( ?context :: ControllerContext
    , SetField fieldName record (Maybe Text)
    , HasField "id" record (ModelSupport.Id' (GetTableName (ModelSupport.GetModelByTableName (GetTableName record))))
    , Show (ModelSupport.PrimaryKey (GetTableName (ModelSupport.GetModelByTableName (GetTableName record))))
    , KnownSymbol fieldName
    , KnownSymbol (GetTableName record)
    ) => Proxy fieldName -> record -> IO record
uploadPng :: forall (fieldName :: Symbol) record.
(?context::ControllerContext,
 SetField fieldName record (Maybe Text),
 HasField
   "id"
   record
   (Id' (GetTableName (GetModelByTableName (GetTableName record)))),
 Show
   (PrimaryKey
      (GetTableName (GetModelByTableName (GetTableName record)))),
 KnownSymbol fieldName, KnownSymbol (GetTableName record)) =>
Proxy fieldName -> record -> IO record
uploadPng Proxy fieldName
field record
record = Text -> 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) =>
Text -> Proxy fieldName -> record -> IO record
uploadImageFile Text
"png" Proxy fieldName
field record
record

-- | Saves an uploaded svg file. No validation or transformation applied.
-- See 'uploadImageFile' for details.
uploadSVG ::
    ( ?context :: ControllerContext
    , SetField fieldName record (Maybe Text)
    , HasField "id" record (ModelSupport.Id' (GetTableName (ModelSupport.GetModelByTableName (GetTableName record))))
    , Show (ModelSupport.PrimaryKey (GetTableName (ModelSupport.GetModelByTableName (GetTableName record))))
    , KnownSymbol fieldName
    , KnownSymbol (GetTableName record)
    ) => Proxy fieldName -> record -> IO record
uploadSVG :: forall (fieldName :: Symbol) record.
(?context::ControllerContext,
 SetField fieldName record (Maybe Text),
 HasField
   "id"
   record
   (Id' (GetTableName (GetModelByTableName (GetTableName record)))),
 Show
   (PrimaryKey
      (GetTableName (GetModelByTableName (GetTableName record)))),
 KnownSymbol fieldName, KnownSymbol (GetTableName record)) =>
Proxy fieldName -> record -> IO record
uploadSVG = Text -> 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) =>
Text -> Proxy fieldName -> record -> IO record
uploadImageFile Text
"svg"