WIP: [User] Image upload API

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.5.9.5
+version:        0.0.5.9.5
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -115,6 +115,7 @@ library
       Gargantext.API.GraphQL.User
       Gargantext.API.GraphQL.UserInfo
       Gargantext.API.GraphQL.Utils
+      Gargantext.API.Image
       Gargantext.API.Job
       Gargantext.API.Metrics
       Gargantext.API.Ngrams.List

src/Gargantext/API/Client.hs

@@ -58,6 +58,8 @@ import Servant.Client
 import Servant.Job.Core
 import Servant.Job.Types
 import System.Metrics.Json (Sample, Value)
+import Gargantext.API.Image (IntResponse)
+import Servant.Multipart (MultipartData, Mem, MultipartForm)
 
 
 -- * version API
@@ -421,6 +423,9 @@ killListCsvUpdateAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit  ->
 pollListCsvUpdateAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit  -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitListCsvUpdateAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
+-- * image upload api
+postUploadImage :: Token -> MultipartForm Mem (MultipartData Mem) -> ClientM IntResponse
+
 -- * public API
 getPublicData :: ClientM [PublicData]
 getPublicNodeFile :: NodeId -> ClientM (Headers '[Header "Content-Type" Text] BSResponse)
@@ -727,6 +732,7 @@ postAuth
   :<|> killListCsvUpdateAsyncJob
   :<|> pollListCsvUpdateAsyncJob
   :<|> waitListCsvUpdateAsyncJob
+  :<|> postUploadImage
   :<|> getPublicData
   :<|> getPublicNodeFile
   = clientApi

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -35,6 +35,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
   , cw_role
   , cw_touch
   , cw_description
+  , cw_imagePath
   , ct_mail
   , ct_phone
   , hc_who
@@ -220,3 +221,5 @@ ui_cwTouchPhoneL = hu_shared . _Just . (hc_where . (ix 0) . cw_touch . _Just . c
 --ui_cwTouchPhoneL = contactWhereL . cw_touch . _Just . ct_phone
 ui_cwDescriptionL :: Traversal' HyperdataUser (Maybe Text)
 ui_cwDescriptionL = contactWhoL . cw_description
+ui_cwImagePathL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwImagePathL = contactWhoL . cw_imagePath

src/Gargantext/API/Image.hs

+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Gargantext.API.Image where
+
+import Data.Swagger
+import GHC.Generics (Generic)
+import Servant
+import Servant.Multipart
+import Gargantext.API.Prelude
+import Gargantext.Prelude
+import Gargantext.Database.Admin.Types.Node
+import qualified Data.ByteString.Lazy as LBS
+import Gargantext.Core.Types (TODO)
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
+import qualified Gargantext.Database.GargDB as GargDB
+import Gargantext.API.Admin.Types (HasSettings)
+import Data.Maybe (fromMaybe)
+import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata, UserLight (UserLight))
+import qualified Data.Text as T
+import Gargantext.API.GraphQL.UserInfo (ui_cwImagePathL)
+import Gargantext.Database.Schema.Node (node_id, node_hyperdata)
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Control.Lens
+import Data.Aeson (ToJSON)
+import Servant.Swagger.Internal
+import Data.Monoid (mempty)
+
+type ImageUploadAPI = Summary "Image upload endpoint" 
+                      :> "image" 
+                      :> MultipartForm Mem (MultipartData Mem) :> Post '[JSON] IntResponse
+
+imageUploadAPI :: UserId -> GargServer ImageUploadAPI
+imageUploadAPI = upload
+
+instance ToParamSchema (MultipartData Mem) where toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+
+instance (ToParamSchema a, HasSwagger sub) =>
+         HasSwagger (MultipartForm tag a :> sub) where
+  -- TODO
+  toSwagger _ = toSwagger (Proxy :: Proxy sub)
+              & addParam param
+    where
+      param = mempty
+            & required ?~ True
+            & schema   .~ ParamOther sch
+      sch = mempty
+          & in_         .~ ParamFormData
+          & paramSchema .~ toParamSchema (Proxy :: Proxy a)
+
+newtype IntResponse = IntResponse Int
+  deriving (Generic)
+
+instance ToJSON IntResponse
+instance ToSchema IntResponse where
+   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+
+newtype LBSContent = LBSContent LBS.ByteString
+
+instance GargDB.SaveFile LBSContent where
+  saveFile' fp (LBSContent a) = do
+    LBS.writeFile fp a
+
+upload :: (HasSettings env, FlowCmdM env err m) => UserId -> MultipartData Mem -> m IntResponse
+upload uId multipartData = do
+  let content = LBSContent $ fromMaybe "" $ head $ map fdPayload (files multipartData)
+  fpath <- GargDB.writeFile content
+  users <- getUsersWithNodeHyperdata uId
+  _ <- case users of
+    [] -> panic $ "[updateUserInfo] User with id " <> (T.pack $ show uId) <> " doesn't exist."
+    ((UserLight { }, node_u):_) -> do
+      let u_hyperdata = node_u ^. node_hyperdata
+      let u_hyperdata' = u_hyperdata & ui_cwImagePathL .~ Just (T.pack fpath)
+      updateHyperdata (node_u ^. node_id) u_hyperdata'
+  pure (IntResponse 0)

src/Gargantext/API/Routes.hs

@@ -45,6 +45,7 @@ import Gargantext.Database.Prelude (HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_max_docs_scrapers)
 import qualified Gargantext.API.GraphQL                    as GraphQL
+import qualified Gargantext.API.Image                      as Image
 import qualified Gargantext.API.Ngrams.List                as List
 import qualified Gargantext.API.Node.Contact               as Contact
 import qualified Gargantext.API.Node.Corpus.Annuaire       as Annuaire
@@ -176,6 +177,8 @@ type GargPrivateAPI' =
            :<|> List.GETAPI
            :<|> List.JSONAPI
            :<|> List.CSVAPI
+
+           :<|> Image.ImageUploadAPI
 {-
            :<|> "wait"   :> Summary "Wait test"
                          :> Capture "x" Int
@@ -245,7 +248,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
           <$> PathNode <*> graphAPI uid -- TODO: mock
 
      :<|> withAccess (Proxy :: Proxy TreeAPI)        Proxy uid
-          <$> PathNode <*> treeAPI
+          <$> PathNode <*> treeAPI 
      -- TODO access
      :<|> addCorpusWithForm  (RootId (NodeId uid))
     -- :<|> addCorpusWithFile  (RootId (NodeId uid))
@@ -258,6 +261,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
      :<|> List.jsonApi
      :<|> List.csvApi
 --     :<|> waitAPI
+     :<|> Image.imageUploadAPI uid
 
 
 ----------------------------------------------------------------------

src/Gargantext/API/Search.hs

@@ -272,7 +272,7 @@ instance ToHyperdataRow HyperdataDocument where
       , _hr_uniqIdBdd = fromMaybe "" _hd_uniqIdBdd }
 
 instance ToHyperdataRow HyperdataContact where
-  toHyperdataRow (HyperdataContact { _hc_who = Just (ContactWho _ fn ln _ _ _), _hc_where = ou} ) =
+  toHyperdataRow (HyperdataContact { _hc_who = Just (ContactWho _ fn ln _ _ _ _), _hc_where = ou} ) =
     HyperdataRowContact (fromMaybe "FirstName" fn) (fromMaybe "LastName" ln) ou'
       where
         ou' = maybe "CNRS" (Text.intercalate " " . _cw_organization) (head ou)

src/Gargantext/Core/Ext/IMTUser.hs

@@ -170,7 +170,8 @@ imtUser2gargContact (IMTUser { id
                      , _cw_lastName = nom
                      , _cw_keywords = catMaybes [service]
                      , _cw_freetags = []
-                     , _cw_description = Nothing }
+                     , _cw_description = Nothing
+                     , _cw_imagePath = Nothing }
     ou  = ContactWhere { _cw_organization = toList entite
                        , _cw_labTeamDepts = toList service
                        , _cw_role = fonction

src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs

@@ -104,6 +104,7 @@ data ContactWho =
              , _cw_keywords :: [Text]
              , _cw_freetags :: [Text]
              , _cw_description :: Maybe Text
+             , _cw_imagePath   :: Maybe Text
   } deriving (Eq, Show, Generic)
 
 instance GQLType ContactWho where
@@ -122,7 +123,8 @@ contactWho fn ln =
              , _cw_lastName = Just ln
              , _cw_keywords = []
              , _cw_freetags = []
-             , _cw_description = Nothing }
+             , _cw_description = Nothing
+             , _cw_imagePath = Nothing }
 
 data ContactWhere =
   ContactWhere { _cw_organization :: [Text]