{-# LANGUAGE DataKinds #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Validates an uploaded scenario
module Swarm.Web.Tournament.Validate.Upload where

import Control.Monad (void, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.Either.Extra (maybeToEither)
import Data.List.NonEmpty qualified as NE
import Servant.Multipart
import Swarm.Game.State
import Swarm.Web.Tournament.Database.Query
import Swarm.Web.Tournament.Type
import Swarm.Web.Tournament.Validate.FailureMode

data PersistenceArgs m a
  = PersistenceArgs
      UserAlias
      (MultipartData Mem)
      (ScenarioPersistence m a)

obtainFileUpload ::
  MultipartData Mem ->
  ExceptT GenericUploadFailure IO FileUpload
obtainFileUpload :: MultipartData Mem -> ExceptT GenericUploadFailure IO FileUpload
obtainFileUpload MultipartData Mem
multipartData =
  (FileUploadFailure -> GenericUploadFailure)
-> ExceptT FileUploadFailure IO FileUpload
-> ExceptT GenericUploadFailure IO FileUpload
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT FileUploadFailure -> GenericUploadFailure
GenericUploadFailure (ExceptT FileUploadFailure IO FileUpload
 -> ExceptT GenericUploadFailure IO FileUpload)
-> ExceptT FileUploadFailure IO FileUpload
-> ExceptT GenericUploadFailure IO FileUpload
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (FileData Mem)
nonemptyFiles <-
      Either FileUploadFailure (NonEmpty (FileData Mem))
-> ExceptT FileUploadFailure IO (NonEmpty (FileData Mem))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either FileUploadFailure (NonEmpty (FileData Mem))
 -> ExceptT FileUploadFailure IO (NonEmpty (FileData Mem)))
-> Either FileUploadFailure (NonEmpty (FileData Mem))
-> ExceptT FileUploadFailure IO (NonEmpty (FileData Mem))
forall a b. (a -> b) -> a -> b
$
        FileUploadFailure
-> Maybe (NonEmpty (FileData Mem))
-> Either FileUploadFailure (NonEmpty (FileData Mem))
forall a b. a -> Maybe b -> Either a b
maybeToEither FileUploadFailure
NoFileSupplied Maybe (NonEmpty (FileData Mem))
maybeNonemptyFiles

    let suppliedCount :: Int
suppliedCount = NonEmpty (FileData Mem) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (FileData Mem)
nonemptyFiles
    Bool
-> ExceptT FileUploadFailure IO ()
-> ExceptT FileUploadFailure IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
suppliedCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ExceptT FileUploadFailure IO ()
 -> ExceptT FileUploadFailure IO ())
-> (FileUploadFailure -> ExceptT FileUploadFailure IO ())
-> FileUploadFailure
-> ExceptT FileUploadFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FileUploadFailure () -> ExceptT FileUploadFailure IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either FileUploadFailure () -> ExceptT FileUploadFailure IO ())
-> (FileUploadFailure -> Either FileUploadFailure ())
-> FileUploadFailure
-> ExceptT FileUploadFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileUploadFailure -> Either FileUploadFailure ()
forall a b. a -> Either a b
Left (FileUploadFailure -> ExceptT FileUploadFailure IO ())
-> FileUploadFailure -> ExceptT FileUploadFailure IO ()
forall a b. (a -> b) -> a -> b
$ Int -> FileUploadFailure
MultipleFiles Int
suppliedCount

    let file :: FileData Mem
file = NonEmpty (FileData Mem) -> FileData Mem
forall a. NonEmpty a -> a
NE.head NonEmpty (FileData Mem)
nonemptyFiles
        content :: MultipartResult Mem
content = FileData Mem -> MultipartResult Mem
forall tag. FileData tag -> MultipartResult tag
fdPayload FileData Mem
file
        theSha1Hash :: Sha1
theSha1Hash = String -> Sha1
Sha1 (String -> Sha1) -> String -> Sha1
forall a b. (a -> b) -> a -> b
$ Digest SHA1State -> String
forall t. Digest t -> String
showDigest (Digest SHA1State -> String) -> Digest SHA1State -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Digest SHA1State
sha1 ByteString
content

    FileUpload -> ExceptT FileUploadFailure IO FileUpload
forall a. a -> ExceptT FileUploadFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileUpload -> ExceptT FileUploadFailure IO FileUpload)
-> FileUpload -> ExceptT FileUploadFailure IO FileUpload
forall a b. (a -> b) -> a -> b
$ ByteString -> FileMetadata -> FileUpload
FileUpload ByteString
content (FileMetadata -> FileUpload) -> FileMetadata -> FileUpload
forall a b. (a -> b) -> a -> b
$ Text -> Sha1 -> FileMetadata
FileMetadata (FileData Mem -> Text
forall tag. FileData tag -> Text
fdFileName FileData Mem
file) Sha1
theSha1Hash
 where
  maybeNonemptyFiles :: Maybe (NonEmpty (FileData Mem))
maybeNonemptyFiles = [FileData Mem] -> Maybe (NonEmpty (FileData Mem))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([FileData Mem] -> Maybe (NonEmpty (FileData Mem)))
-> [FileData Mem] -> Maybe (NonEmpty (FileData Mem))
forall a b. (a -> b) -> a -> b
$ MultipartData Mem -> [FileData Mem]
forall tag. MultipartData tag -> [FileData tag]
files MultipartData Mem
multipartData

withFileCache ::
  PersistenceArgs IO a ->
  (GenericUploadFailure -> e) ->
  (FileUpload -> ExceptT e IO (AssociatedSolutionCharacterization, a)) ->
  ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
withFileCache :: forall a e.
PersistenceArgs IO a
-> (GenericUploadFailure -> e)
-> (FileUpload
    -> ExceptT e IO (AssociatedSolutionCharacterization, a))
-> ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
withFileCache (PersistenceArgs UserAlias
userAlias MultipartData Mem
multipartData ScenarioPersistence IO a
persistenceFunctions) GenericUploadFailure -> e
errorWrapper FileUpload -> ExceptT e IO (AssociatedSolutionCharacterization, a)
cacheStoreFunction = do
  FileUpload
file <- (GenericUploadFailure -> e)
-> ExceptT GenericUploadFailure IO FileUpload
-> ExceptT e IO FileUpload
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenericUploadFailure -> e
errorWrapper (ExceptT GenericUploadFailure IO FileUpload
 -> ExceptT e IO FileUpload)
-> ExceptT GenericUploadFailure IO FileUpload
-> ExceptT e IO FileUpload
forall a b. (a -> b) -> a -> b
$ MultipartData Mem -> ExceptT GenericUploadFailure IO FileUpload
obtainFileUpload MultipartData Mem
multipartData
  Maybe AssociatedSolutionCharacterization
maybePreexisting <-
    IO (Maybe AssociatedSolutionCharacterization)
-> ExceptT e IO (Maybe AssociatedSolutionCharacterization)
forall a. IO a -> ExceptT e IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO (Maybe AssociatedSolutionCharacterization)
 -> ExceptT e IO (Maybe AssociatedSolutionCharacterization))
-> (FileMetadata -> IO (Maybe AssociatedSolutionCharacterization))
-> FileMetadata
-> ExceptT e IO (Maybe AssociatedSolutionCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScenarioPersistence IO a
-> Sha1 -> IO (Maybe AssociatedSolutionCharacterization)
forall (m :: * -> *) a.
ScenarioPersistence m a
-> Sha1 -> m (Maybe AssociatedSolutionCharacterization)
lookupCache ScenarioPersistence IO a
persistenceFunctions
      (Sha1 -> IO (Maybe AssociatedSolutionCharacterization))
-> (FileMetadata -> Sha1)
-> FileMetadata
-> IO (Maybe AssociatedSolutionCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileMetadata -> Sha1
fileHash
      (FileMetadata
 -> ExceptT e IO (Maybe AssociatedSolutionCharacterization))
-> FileMetadata
-> ExceptT e IO (Maybe AssociatedSolutionCharacterization)
forall a b. (a -> b) -> a -> b
$ FileUpload -> FileMetadata
fileMetadata FileUpload
file
  AssociatedSolutionCharacterization
solnMetrics <- ExceptT e IO AssociatedSolutionCharacterization
-> (AssociatedSolutionCharacterization
    -> ExceptT e IO AssociatedSolutionCharacterization)
-> Maybe AssociatedSolutionCharacterization
-> ExceptT e IO AssociatedSolutionCharacterization
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FileUpload -> ExceptT e IO AssociatedSolutionCharacterization
doStore FileUpload
file) AssociatedSolutionCharacterization
-> ExceptT e IO AssociatedSolutionCharacterization
forall a. a -> ExceptT e IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AssociatedSolutionCharacterization
maybePreexisting
  (FileMetadata, AssociatedSolutionCharacterization)
-> ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
forall a. a -> ExceptT e IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileUpload -> FileMetadata
fileMetadata FileUpload
file, AssociatedSolutionCharacterization
solnMetrics)
 where
  doStore :: FileUpload -> ExceptT e IO AssociatedSolutionCharacterization
doStore FileUpload
file = do
    (AssociatedSolutionCharacterization
result, a
a) <- FileUpload -> ExceptT e IO (AssociatedSolutionCharacterization, a)
cacheStoreFunction FileUpload
file

    IO () -> ExceptT e IO ()
forall a. IO a -> ExceptT e IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> ExceptT e IO ())
-> (CharacterizationResponse a -> IO ())
-> CharacterizationResponse a
-> ExceptT e IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Sha1 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
      (IO Sha1 -> IO ())
-> (CharacterizationResponse a -> IO Sha1)
-> CharacterizationResponse a
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScenarioPersistence IO a -> CharacterizationResponse a -> IO Sha1
forall (m :: * -> *) a.
ScenarioPersistence m a -> CharacterizationResponse a -> m Sha1
storeCache ScenarioPersistence IO a
persistenceFunctions
      (CharacterizationResponse a -> ExceptT e IO ())
-> CharacterizationResponse a -> ExceptT e IO ()
forall a b. (a -> b) -> a -> b
$ UserAttributedUpload
-> AssociatedSolutionCharacterization
-> a
-> CharacterizationResponse a
forall a.
UserAttributedUpload
-> AssociatedSolutionCharacterization
-> a
-> CharacterizationResponse a
CharacterizationResponse
        (UserAlias -> FileUpload -> UserAttributedUpload
UserAttributedUpload UserAlias
userAlias FileUpload
file)
        AssociatedSolutionCharacterization
result
        a
a

    AssociatedSolutionCharacterization
-> ExceptT e IO AssociatedSolutionCharacterization
forall a. a -> ExceptT e IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AssociatedSolutionCharacterization
result