src/Gargantext/API/Upload.hs

   1 {-|
   2 Module      : Gargantext.API.Upload
   3 Description : Server API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13
  14 {-# LANGUAGE DataKinds             #-}
  15 {-# LANGUAGE DeriveGeneric         #-}
  16 {-# LANGUAGE FlexibleContexts      #-}
  17 {-# LANGUAGE FlexibleInstances     #-}
  18 {-# LANGUAGE NoImplicitPrelude     #-}
  19 {-# LANGUAGE MultiParamTypeClasses #-}
  20 {-# LANGUAGE OverloadedStrings     #-}
  21 {-# LANGUAGE RankNTypes            #-}
  22 {-# LANGUAGE ScopedTypeVariables   #-}
  23 {-# LANGUAGE TemplateHaskell       #-}
  24 {-# LANGUAGE TypeOperators         #-}
  25
  26 module Gargantext.API.Upload
  27   where
  28
  29 import Control.Lens ((.~), (?~))
  30 import Gargantext.Prelude
  31 import Data.Text (Text)
  32 import Data.Monoid
  33 import Servant
  34 import Servant.Multipart
  35 --import Servant.Mock (HasMock(mock))
  36 import Servant.Swagger (HasSwagger(toSwagger))
  37 import Servant.Swagger.Internal
  38 -- import qualified Data.ByteString.Lazy as LBS
  39 import Control.Monad
  40 import Control.Monad.IO.Class
  41 import Gargantext.API.Types
  42 --import Servant.CSV.Cassava (CSV'(..))
  43 --import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  44 import Data.Swagger
  45 import Gargantext.API.Ngrams (TODO)
  46 import Gargantext.Prelude.Utils (hash)
  47
  48 -- | Upload files
  49 -- TODO Is it possible to adapt the function according to iValue input ?
  50 --type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer
  51
  52 -- instance Generic Mem
  53
  54 --instance ToSchema Mem
  55 --instance Arbitrary Mem
  56
  57 instance ToParamSchema (MultipartData Mem) where
  58   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
  59
  60 --instance Arbitrary ( MultipartData Mem)
  61
  62 instance (ToParamSchema a, HasSwagger sub) =>
  63          HasSwagger (MultipartForm tag a :> sub) where
  64   -- TODO
  65   toSwagger _ = toSwagger (Proxy :: Proxy sub)
  66     & addParam param
  67     where
  68       param = mempty
  69         & required ?~ True
  70         & schema   .~ ParamOther sch
  71       sch = mempty
  72         & in_         .~ ParamFormData
  73         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
  74 --declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  75 --instance Arbitrary (MultipartForm Mem (MultipartData Mem))
  76
  77 {-
  78 instance (FromMultipart tag a, MultipartBackend tag, Servant.Multipart.LookupContext context (MultipartOptions tag))
  79       => HasMock (MultipartForm tag a :> sub) context where
  80   mock _ _ = undefined
  81
  82 instance HasMock (MultipartForm Mem (MultipartData Mem) :> sub) context where
  83   mock _ _ = undefined
  84 -}
  85
  86 type Hash = Text
  87
  88 type ApiUpload = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] [Hash]
  89 -- MultipartData consists in textual inputs,
  90 -- accessible through its "inputs" field, as well
  91 -- as files, accessible through its "files" field.
  92 upload :: GargServer ApiUpload
  93 upload multipartData = do
  94
  95 --{-
  96   is <- liftIO $ do
  97     putStrLn ("Inputs:" :: Text)
  98     forM (inputs multipartData) $ \input -> do
  99       putStrLn $ ("iName  " :: Text) <> (iName input)
 100             <> ("iValue " :: Text) <> (iValue input)
 101       pure $ iName input
 102
 103 --{-
 104   _ <- forM (files multipartData) $ \file -> do
 105     let content = fdPayload file
 106     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 107     putStrLn $ ("YYY " :: Text) <>  cs content
 108     --pure $ cs content
 109   -- is <- inputs multipartData
 110 --}
 111
 112   pure $ map (hash . cs) is
 113 -------------------------------------------------------------------------------
 114
 115