{-# 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.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 :: (?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"