ModelAPI.hs

type ModelAPI =
    "models" :>
        (    ProjectKey :> Get '[JSON] [Model]
        :<|> ProjectKey :> MultipartUpload :> Post '[JSON] Model
        :<|> ProjectKey :> Capture "modelId" ID :> Get '[JSON] Model
        :<|> ProjectKey :> Capture "modelId" ID :> "predictions" :> ReqBody '[JSON] PredictionInput :> Post '[JSON] Prediction
        :<|> ProjectKey :> Capture "modelId" ID :> "predictions" :> Get '[JSON] [Prediction]
        :<|> ProjectKey :> Capture "modelId" ID :> "predictions" :> Capture "predictionId" ID :> Get '[JSON] Prediction
        )

Multipart.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Servant.Multipart
  ( MultipartUpload
  , FileInfo(..)
  ) where

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as Lazy
import Network.HTTP.Types (status400)
import Network.Wai.Parse
import Network.Wai (responseLBS)
import Servant
import Servant.Server.Internal


data MultipartUpload

instance (HasServer sublayout) => HasServer (MultipartUpload :> sublayout) where
  type ServerT (MultipartUpload :> sublayout) m =
    FileInfo ByteString -> ServerT sublayout m

  route Proxy subserver req respond = do
    dat <- parseRequestBody lbsBackEnd req
    let files = snd dat
    case files of
      [(_, f)] ->
        if Lazy.null $ fileContent f
          then respond . succeedWith $ responseLBS status400 [] "Empty file"
          else route (Proxy :: Proxy sublayout) (subserver f) req respond
      [] ->
        respond . succeedWith $ responseLBS status400 [] "File upload required"

      _ ->
        respond . succeedWith $ responseLBS status400 [] "At most one file allowed"