{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, TypeInType, 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 qualified System.Process as Process
import IHP.Controller.RequestContext
import IHP.Controller.Context
import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
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.
fileOrNothing :: (?context :: ControllerContext) => ByteString -> Maybe (FileInfo LBS.ByteString)
fileOrNothing :: ByteString -> Maybe (FileInfo ByteString)
fileOrNothing !ByteString
name =
        ?context::ControllerContext
ControllerContext
?context
        ControllerContext
-> (ControllerContext -> RequestContext) -> RequestContext
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext
        RequestContext -> (RequestContext -> RequestBody) -> RequestBody
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "requestBody" -> RequestContext -> RequestBody
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestBody" (Proxy "requestBody")
Proxy "requestBody"
#requestBody
        RequestBody
-> (RequestBody -> Maybe (FileInfo ByteString))
-> Maybe (FileInfo ByteString)
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
            FormBody { [File ByteString]
$sel:files:FormBody :: RequestBody -> [File ByteString]
files :: [File ByteString]
files } -> ByteString -> [File ByteString] -> Maybe (FileInfo ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
name [File ByteString]
files
            RequestBody
_ -> Maybe (FileInfo ByteString)
forall a. Maybe a
Nothing
{-# INLINE fileOrNothing #-}

-- | 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) context 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 :: 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 (Proxy fieldName
forall k (t :: k). 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 (Proxy tableName
forall k (t :: k). 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 -> Id' (GetTableName (GetModelByTableName tableName))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"id" record
user) 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 | FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent FileInfo ByteString
file ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"" -> IO record -> IO record
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
<> (ImageUploadOptions -> Text
forall k (x :: k) 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
|> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return
        Maybe (FileInfo ByteString)
_ -> record -> IO record
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) context 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 :: 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 (Proxy fieldName
forall k (t :: k). 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 (Proxy tableName
forall k (t :: k). 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 -> Id' (GetTableName (GetModelByTableName tableName))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"id" record
user) 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 | FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent FileInfo ByteString
file ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"" -> IO record -> IO record
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
|> 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure
        Maybe (FileInfo ByteString)
_ -> record -> IO record
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 :: Proxy fieldName -> record -> IO record
uploadPng Proxy fieldName
field record
record = Text -> Proxy fieldName -> record -> IO record
forall k (fieldName :: Symbol) (context :: k) 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 :: Proxy fieldName -> record -> IO record
uploadSVG = Text -> Proxy fieldName -> record -> IO record
forall k (fieldName :: Symbol) (context :: k) 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"