gargantext.cabal

@@ -116,6 +116,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
@@ -467,6 +468,7 @@ library
     , servant-job
     , servant-mock
     , servant-multipart
+    , servant-multipart-client
     , servant-server
     , servant-static-th
     , servant-swagger

package.yaml

@@ -252,6 +252,7 @@ library:
   - servant-job
   - servant-mock
   - servant-multipart
+  - servant-multipart-client
   - servant-server
   - servant-static-th
   - servant-swagger

src/Gargantext/API/Client.hs

@@ -4,6 +4,7 @@
 
 module Gargantext.API.Client where
 
+import qualified Data.ByteString.Lazy as LBS
 import Data.Int
 import Data.Maybe
 import Data.Map (Map)
@@ -58,6 +59,9 @@ 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)
+import Servant.Multipart.Client ()
 
 
 -- * version API
@@ -421,6 +425,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 -> (LBS.ByteString, MultipartData Mem) -> ClientM IntResponse
+
 -- * public API
 getPublicData :: ClientM [PublicData]
 getPublicNodeFile :: NodeId -> ClientM (Headers '[Header "Content-Type" Text] BSResponse)
@@ -727,6 +734,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
@@ -66,6 +67,7 @@ data UserInfo = UserInfo
   , ui_cwTouchPhone   :: Maybe Text
   , ui_cwTouchMail    :: Maybe Text  -- TODO: Remove. userLight_email should be used instead
   , ui_cwDescription  :: Maybe Text
+  , ui_cwImagePath    :: Maybe Text
   }
   deriving (Generic, GQLType, Show)
 
@@ -184,7 +186,8 @@ toUser (UserLight { .. }, u_hyperdata) =
            --, ui_cwTouchMail    = u_hyperdata ^. ui_cwTouchMailL
            , ui_cwTouchMail    = Just userLight_email
            , ui_cwTouchPhone   = u_hyperdata ^. ui_cwTouchPhoneL
-           , ui_cwDescription  = u_hyperdata ^. ui_cwDescriptionL }
+           , ui_cwDescription  = u_hyperdata ^. ui_cwDescriptionL
+           , ui_cwImagePath    = u_hyperdata ^. ui_cwImagePathL }
 
 sharedL :: Traversal' HyperdataUser HyperdataContact
 sharedL = hu_shared . _Just
@@ -220,3 +223,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 (FromJSON, ToJSON)
+import Servant.Ekg
+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 HasEndpoint sub => HasEndpoint (MultipartForm backend a :> sub) where
+  getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+  enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub)
+
+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 FromJSON IntResponse
+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]

stack.yaml

@@ -153,6 +153,7 @@ extra-deps:
 - servant-cassava-0.10.1@sha256:07e7b6ca67cf57dcb4a0041a399a25d058844505837c6479e01d62be59d01fdf,1665
 - servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
 - servant-mock-0.8.7@sha256:64cb3e52bbd51ab6cb25e3f412a99ea712c6c26f1efd117f01a8d1664df49c67,2306
+- servant-multipart-client-0.12.1@sha256:fdaeea6a7e3b5459321520606a5dc0be55e16ebc3abe245fddb14df8a34a08cb,1976
 - servant-xml-1.0.1.4@sha256:6c9f2986ac42e72fe24b794c660763a1966a18d696b34cd4f4ed15165edd4aa0,851
 - stemmer-0.5.2@sha256:823aec56249ec2619f60a2c0d1384b732894dbbbe642856d337ebfe9629a0efd,4082
 - xmlbf-0.6.1@sha256:57867fcb39e0514d17b3328ff5de8d241a18482fc89bb742d9ed820a6a2a5187,1540