module Web.Minion.Request.Multipart (
  Multipart (..),
  multipartBody,
  Backend (..),
  Tmp,
  Mem,
  MultipartData (..),
  FromMultipart (..),
  MultipartM,
  getParam,
  lookupParam,
  getFile,
  lookupFile,
  Wai.File,
  Wai.Param,
) where

import Data.ByteString.Lazy qualified as Bytes.Lazy
import Data.Kind (Type)
import Network.Wai.Parse qualified as Wai

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Except (Except, except, runExcept)
import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
import Control.Monad.Trans.Resource
import Data.ByteString qualified as Bytes
import Data.String.Conversions (ConvertibleStrings (..))
import Data.Text (Text)
import Data.Text.Encoding qualified as Text.Encode
import Network.HTTP.Types qualified as Http
import Web.Minion.Args (WithReq)
import Web.Minion.Introspect qualified as I
import Web.Minion.Request (IsRequest (..))
import Web.Minion.Router

data Tmp
data Mem

newtype Multipart backend a = Multipart a

instance IsRequest (Multipart backend a) where
  type RequestValue (Multipart backend a) = a
  getRequestValue :: Multipart backend a -> RequestValue (Multipart backend a)
getRequestValue (Multipart a
a) = a
RequestValue (Multipart backend a)
a

type MultipartM backend = ReaderT (MultipartData backend) (Except Text)

class (MonadIO m) => Backend m backend where
  type BackendFile backend :: Type
  waiBackend :: m (Wai.BackEnd (BackendFile backend))

instance (MonadResource m) => Backend m Tmp where
  type BackendFile Tmp = FilePath
  waiBackend :: m (BackEnd (BackendFile Tmp))
waiBackend = ResourceT
  IO (ByteString -> FileInfo () -> IO ByteString -> IO FilePath)
-> m (ByteString -> FileInfo () -> IO ByteString -> IO FilePath)
forall a. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT do
    InternalState
-> ByteString -> FileInfo () -> IO ByteString -> IO FilePath
forall ignored1 ignored2.
InternalState
-> ignored1 -> ignored2 -> IO ByteString -> IO FilePath
Wai.tempFileBackEnd (InternalState
 -> ByteString -> FileInfo () -> IO ByteString -> IO FilePath)
-> ResourceT IO InternalState
-> ResourceT
     IO (ByteString -> FileInfo () -> IO ByteString -> IO FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResourceT IO InternalState
forall (m :: * -> *). Monad m => ResourceT m InternalState
getInternalState

instance (MonadIO m) => Backend m Mem where
  type BackendFile Mem = Bytes.Lazy.ByteString
  waiBackend :: m (BackEnd (BackendFile Mem))
waiBackend = (ByteString -> FileInfo () -> IO ByteString -> IO ByteString)
-> m (ByteString -> FileInfo () -> IO ByteString -> IO ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> FileInfo () -> IO ByteString -> IO ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
Wai.lbsBackEnd

data MultipartData backend = MultipartData
  { forall {k} (backend :: k). MultipartData backend -> [Param]
params :: [Wai.Param]
  , forall {k} (backend :: k).
MultipartData backend -> [File (BackendFile backend)]
files :: [Wai.File (BackendFile backend)]
  }

class FromMultipart backend a where
  fromMultipart :: MultipartM backend a

instance FromMultipart backend (MultipartData backend) where
  fromMultipart :: MultipartM backend (MultipartData backend)
fromMultipart = MultipartM backend (MultipartData backend)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

{- | Extracts multipart data from request body

@
... /> 'multipartBody' \@'Tmp' @Foo .> ...
@
-}
multipartBody ::
  forall backend r m i ts.
  (I.Introspection i I.Request (Multipart backend r)) =>
  (MonadThrow m) =>
  (FromMultipart backend r) =>
  (Backend m backend) =>
  -- | .
  ValueCombinator i (WithReq m (Multipart backend r)) ts m
multipartBody :: forall {k} (backend :: k) r (m :: * -> *) i ts.
(Introspection i 'Request (Multipart backend r), MonadThrow m,
 FromMultipart backend r, Backend m backend) =>
ValueCombinator i (WithReq m (Multipart backend r)) ts m
multipartBody = (ErrorBuilder -> Request -> m (Multipart backend r))
-> Router' i (ts :+ WithReq m (Multipart backend r)) m
-> Router' i ts m
forall r (m :: * -> *) i ts.
(Introspection i 'Request r, IsRequest r) =>
(ErrorBuilder -> Request -> m r)
-> Router' i (ts :+ WithReq m r) m -> Router' i ts m
Request \ErrorBuilder
makeError Request
req -> do
  BackEnd (BackendFile backend)
backend <- (forall {k} (m :: * -> *) (backend :: k).
Backend m backend =>
m (BackEnd (BackendFile backend))
forall (m :: * -> *) (backend :: k).
Backend m backend =>
m (BackEnd (BackendFile backend))
waiBackend @m @backend)
  ([Param]
params, [File (BackendFile backend)]
files) <- IO ([Param], [File (BackendFile backend)])
-> m ([Param], [File (BackendFile backend)])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Param], [File (BackendFile backend)])
 -> m ([Param], [File (BackendFile backend)]))
-> IO ([Param], [File (BackendFile backend)])
-> m ([Param], [File (BackendFile backend)])
forall a b. (a -> b) -> a -> b
$ BackEnd (BackendFile backend)
-> Request -> IO ([Param], [File (BackendFile backend)])
forall y. BackEnd y -> Request -> IO ([Param], [File y])
Wai.parseRequestBody BackEnd (BackendFile backend)
backend Request
req
  case Except Text r -> Either Text r
forall e a. Except e a -> Either e a
runExcept (Except Text r -> Either Text r) -> Except Text r -> Either Text r
forall a b. (a -> b) -> a -> b
$ ReaderT (MultipartData backend) (Except Text) r
-> MultipartData backend -> Except Text r
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (backend :: k) a.
FromMultipart backend a =>
MultipartM backend a
forall {k} (backend :: k) a.
FromMultipart backend a =>
MultipartM backend a
fromMultipart @backend @r) MultipartData{[Param]
[File (BackendFile backend)]
$sel:params:MultipartData :: [Param]
$sel:files:MultipartData :: [File (BackendFile backend)]
params :: [Param]
files :: [File (BackendFile backend)]
..} of
    Left Text
e -> ServerError -> m (Multipart backend r)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerError -> m (Multipart backend r))
-> ServerError -> m (Multipart backend r)
forall a b. (a -> b) -> a -> b
$ ErrorBuilder
makeError Request
req Status
Http.status400 (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString Text
e)
    Right r
v -> Multipart backend r -> m (Multipart backend r)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Multipart backend r -> m (Multipart backend r))
-> Multipart backend r -> m (Multipart backend r)
forall a b. (a -> b) -> a -> b
$ r -> Multipart backend r
forall {k} (backend :: k) a. a -> Multipart backend a
Multipart r
v

{- |
@
instance 'FromMultipart' 'Tmp' MyData where
  'fromMultipart' = do
    param1 <- 'getParam' "param1"
    param2 <- 'getParam' "param2"
    pure MyData {..}
@
-}
getParam :: Bytes.ByteString -> MultipartM backend Bytes.ByteString
getParam :: forall {k} (backend :: k).
ByteString -> MultipartM backend ByteString
getParam ByteString
a =
  ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
-> (MultipartData backend
    -> ReaderT (MultipartData backend) (Except Text) ByteString)
-> ReaderT (MultipartData backend) (Except Text) ByteString
forall a b.
ReaderT (MultipartData backend) (Except Text) a
-> (a -> ReaderT (MultipartData backend) (Except Text) b)
-> ReaderT (MultipartData backend) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Except Text ByteString
-> ReaderT (MultipartData backend) (Except Text) ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (MultipartData backend) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (Except Text ByteString
 -> ReaderT (MultipartData backend) (Except Text) ByteString)
-> (MultipartData backend -> Except Text ByteString)
-> MultipartData backend
-> ReaderT (MultipartData backend) (Except Text) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text ByteString -> Except Text ByteString
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
      (Either Text ByteString -> Except Text ByteString)
-> (MultipartData backend -> Either Text ByteString)
-> MultipartData backend
-> Except Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text ByteString
-> (ByteString -> Either Text ByteString)
-> Maybe ByteString
-> Either Text ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ (Text
"Param not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.Encode.decodeUtf8 ByteString
a) ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right
      (Maybe ByteString -> Either Text ByteString)
-> (MultipartData backend -> Maybe ByteString)
-> MultipartData backend
-> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Param] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
a
      ([Param] -> Maybe ByteString)
-> (MultipartData backend -> [Param])
-> MultipartData backend
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipartData backend -> [Param]
forall {k} (backend :: k). MultipartData backend -> [Param]
params

{- |
@
instance 'FromMultipart' 'Tmp' MyData where
  'fromMultipart' = do
    param1 <- 'getParam' "param1"
    param2 <- 'getParam' "param2"
    pure MyData {..}
@
-}
lookupParam :: Bytes.ByteString -> MultipartM backend (Maybe Bytes.ByteString)
lookupParam :: forall {k} (backend :: k).
ByteString -> MultipartM backend (Maybe ByteString)
lookupParam ByteString
a =
  ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
-> (MultipartData backend
    -> ReaderT
         (MultipartData backend) (Except Text) (Maybe ByteString))
-> ReaderT (MultipartData backend) (Except Text) (Maybe ByteString)
forall a b.
ReaderT (MultipartData backend) (Except Text) a
-> (a -> ReaderT (MultipartData backend) (Except Text) b)
-> ReaderT (MultipartData backend) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Except Text (Maybe ByteString)
-> ReaderT (MultipartData backend) (Except Text) (Maybe ByteString)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (MultipartData backend) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (Except Text (Maybe ByteString)
 -> ReaderT
      (MultipartData backend) (Except Text) (Maybe ByteString))
-> (MultipartData backend -> Except Text (Maybe ByteString))
-> MultipartData backend
-> ReaderT (MultipartData backend) (Except Text) (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (Maybe ByteString) -> Except Text (Maybe ByteString)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
      (Either Text (Maybe ByteString) -> Except Text (Maybe ByteString))
-> (MultipartData backend -> Either Text (Maybe ByteString))
-> MultipartData backend
-> Except Text (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Either Text (Maybe ByteString)
forall a b. b -> Either a b
Right
      (Maybe ByteString -> Either Text (Maybe ByteString))
-> (MultipartData backend -> Maybe ByteString)
-> MultipartData backend
-> Either Text (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Param] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
a
      ([Param] -> Maybe ByteString)
-> (MultipartData backend -> [Param])
-> MultipartData backend
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipartData backend -> [Param]
forall {k} (backend :: k). MultipartData backend -> [Param]
params

{- |
@
instance 'FromMultipart' 'Tmp' MyData where
  'fromMultipart' = do
    file1 <- 'lookupFile' "file1"
    file2 <- 'lookupFile' "file2"
    pure MyData {..}
@
-}
lookupFile :: Bytes.ByteString -> MultipartM backend (Maybe (Wai.FileInfo (BackendFile backend)))
lookupFile :: forall {k} (backend :: k).
ByteString
-> MultipartM backend (Maybe (FileInfo (BackendFile backend)))
lookupFile ByteString
a =
  ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
-> (MultipartData backend
    -> ReaderT
         (MultipartData backend)
         (Except Text)
         (Maybe (FileInfo (BackendFile backend))))
-> ReaderT
     (MultipartData backend)
     (Except Text)
     (Maybe (FileInfo (BackendFile backend)))
forall a b.
ReaderT (MultipartData backend) (Except Text) a
-> (a -> ReaderT (MultipartData backend) (Except Text) b)
-> ReaderT (MultipartData backend) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Except Text (Maybe (FileInfo (BackendFile backend)))
-> ReaderT
     (MultipartData backend)
     (Except Text)
     (Maybe (FileInfo (BackendFile backend)))
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (MultipartData backend) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (Except Text (Maybe (FileInfo (BackendFile backend)))
 -> ReaderT
      (MultipartData backend)
      (Except Text)
      (Maybe (FileInfo (BackendFile backend))))
-> (MultipartData backend
    -> Except Text (Maybe (FileInfo (BackendFile backend))))
-> MultipartData backend
-> ReaderT
     (MultipartData backend)
     (Except Text)
     (Maybe (FileInfo (BackendFile backend)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (Maybe (FileInfo (BackendFile backend)))
-> Except Text (Maybe (FileInfo (BackendFile backend)))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
      (Either Text (Maybe (FileInfo (BackendFile backend)))
 -> Except Text (Maybe (FileInfo (BackendFile backend))))
-> (MultipartData backend
    -> Either Text (Maybe (FileInfo (BackendFile backend))))
-> MultipartData backend
-> Except Text (Maybe (FileInfo (BackendFile backend)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (FileInfo (BackendFile backend))
-> Either Text (Maybe (FileInfo (BackendFile backend)))
forall a b. b -> Either a b
Right
      (Maybe (FileInfo (BackendFile backend))
 -> Either Text (Maybe (FileInfo (BackendFile backend))))
-> (MultipartData backend
    -> Maybe (FileInfo (BackendFile backend)))
-> MultipartData backend
-> Either Text (Maybe (FileInfo (BackendFile backend)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> [(ByteString, FileInfo (BackendFile backend))]
-> Maybe (FileInfo (BackendFile backend))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
a
      ([(ByteString, FileInfo (BackendFile backend))]
 -> Maybe (FileInfo (BackendFile backend)))
-> (MultipartData backend
    -> [(ByteString, FileInfo (BackendFile backend))])
-> MultipartData backend
-> Maybe (FileInfo (BackendFile backend))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipartData backend
-> [(ByteString, FileInfo (BackendFile backend))]
forall {k} (backend :: k).
MultipartData backend -> [File (BackendFile backend)]
files

{- |
@
instance 'FromMultipart' 'Tmp' MyData where
  'fromMultipart' = do
    file1 <- 'getFile' "file1"
    file2 <- 'getFile' "file2"
    pure MyData {..}
@
-}
getFile :: Bytes.ByteString -> MultipartM backend (Wai.FileInfo (BackendFile backend))
getFile :: forall {k} (backend :: k).
ByteString -> MultipartM backend (FileInfo (BackendFile backend))
getFile ByteString
a =
  ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT
  (MultipartData backend) (Except Text) (MultipartData backend)
-> (MultipartData backend
    -> ReaderT
         (MultipartData backend)
         (Except Text)
         (FileInfo (BackendFile backend)))
-> ReaderT
     (MultipartData backend)
     (Except Text)
     (FileInfo (BackendFile backend))
forall a b.
ReaderT (MultipartData backend) (Except Text) a
-> (a -> ReaderT (MultipartData backend) (Except Text) b)
-> ReaderT (MultipartData backend) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Except Text (FileInfo (BackendFile backend))
-> ReaderT
     (MultipartData backend)
     (Except Text)
     (FileInfo (BackendFile backend))
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (MultipartData backend) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
      (Except Text (FileInfo (BackendFile backend))
 -> ReaderT
      (MultipartData backend)
      (Except Text)
      (FileInfo (BackendFile backend)))
-> (MultipartData backend
    -> Except Text (FileInfo (BackendFile backend)))
-> MultipartData backend
-> ReaderT
     (MultipartData backend)
     (Except Text)
     (FileInfo (BackendFile backend))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (FileInfo (BackendFile backend))
-> Except Text (FileInfo (BackendFile backend))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
      (Either Text (FileInfo (BackendFile backend))
 -> Except Text (FileInfo (BackendFile backend)))
-> (MultipartData backend
    -> Either Text (FileInfo (BackendFile backend)))
-> MultipartData backend
-> Except Text (FileInfo (BackendFile backend))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (FileInfo (BackendFile backend))
-> (FileInfo (BackendFile backend)
    -> Either Text (FileInfo (BackendFile backend)))
-> Maybe (FileInfo (BackendFile backend))
-> Either Text (FileInfo (BackendFile backend))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (FileInfo (BackendFile backend))
forall a b. a -> Either a b
Left (Text -> Either Text (FileInfo (BackendFile backend)))
-> Text -> Either Text (FileInfo (BackendFile backend))
forall a b. (a -> b) -> a -> b
$ (Text
"File not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.Encode.decodeUtf8 ByteString
a) FileInfo (BackendFile backend)
-> Either Text (FileInfo (BackendFile backend))
forall a b. b -> Either a b
Right
      (Maybe (FileInfo (BackendFile backend))
 -> Either Text (FileInfo (BackendFile backend)))
-> (MultipartData backend
    -> Maybe (FileInfo (BackendFile backend)))
-> MultipartData backend
-> Either Text (FileInfo (BackendFile backend))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> [(ByteString, FileInfo (BackendFile backend))]
-> Maybe (FileInfo (BackendFile backend))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
a
      ([(ByteString, FileInfo (BackendFile backend))]
 -> Maybe (FileInfo (BackendFile backend)))
-> (MultipartData backend
    -> [(ByteString, FileInfo (BackendFile backend))])
-> MultipartData backend
-> Maybe (FileInfo (BackendFile backend))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipartData backend
-> [(ByteString, FileInfo (BackendFile backend))]
forall {k} (backend :: k).
MultipartData backend -> [File (BackendFile backend)]
files