{-# 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 Network.Wai (Request)
import qualified IHP.ModelSupport as ModelSupport
import qualified Data.ByteString.Lazy as LBS
import Wai.Request.Params.Middleware (RequestBody (..))
import IHP.RequestVault () -- HasField "parsedBody" Request RequestBody
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 :: (?request :: Request) => ByteString -> Maybe (FileInfo LBS.ByteString)
fileOrNothing :: (?request::Request) => ByteString -> Maybe (FileInfo ByteString)
fileOrNothing !ByteString
name =
        case ?request::Request
Request
?request.parsedBody 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 :: (?request :: Request) => ByteString -> [FileInfo LBS.ByteString]
filesByName :: (?request::Request) => ByteString -> [FileInfo ByteString]
filesByName !ByteString
name =
        case ?request::Request
Request
?request.parsedBody of
            FormBody { [File ByteString]
files :: RequestBody -> [File ByteString]
files :: [File ByteString]
files } -> [File ByteString]
files
                    [File ByteString]
-> ([File ByteString] -> [File ByteString]) -> [File ByteString]
forall a b. a -> (a -> b) -> b
|> (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 a b. a -> (a -> b) -> b
|> (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). (
        ?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
    ) => ImageUploadOptions -> Proxy fieldName -> record -> IO record
uploadImageWithOptions :: forall (fieldName :: Symbol) record (tableName :: Symbol).
(?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) =>
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 (?request::Request) => 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
            _ <- 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
uploadDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imagePath
            fileContent file |> LBS.writeFile (cs (uploadDir <> uploadFilePath))
            Process.runCommand (cs ("convert " <> cs uploadDir <> uploadFilePath <> " " <> (getField @"imageMagickOptions" options) <> " " <> cs fullImagePath))
            user
                |> setField @fieldName (Just (cs imagePath :: Text))
                |> 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). (
        ?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
    ) => Text -> Proxy fieldName -> record -> IO record
uploadImageFile :: forall (fieldName :: Symbol) record (tableName :: Symbol).
(?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) =>
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 (?request::Request) => 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
            _ <- 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
"`")
            fileContent file |> LBS.writeFile (cs $ uploadDir <> imagePath)
            user
                |> setField @fieldName (Just (cs imagePath :: Text))
                |> 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 ::
    ( ?request :: Request
    , 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.
(?request::Request, 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).
(?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) =>
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 ::
    ( ?request :: Request
    , 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.
(?request::Request, 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).
(?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) =>
Text -> Proxy fieldName -> record -> IO record
uploadImageFile Text
"svg"