Merge branch 'master' into fromRFC3339

app/Main.hs

@@ -3,7 +3,7 @@
 module Main where
 
 import Gargantext.Prelude
-import Gargantext.Server (startGargantext)
+import Gargantext.API (startGargantext)
 import Text.Read (read)
 import System.Environment (getArgs)
 

gargantext.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1afbb68941e4a0da5a3c812595ca12ed611c36aa9ab55736742c3f093dbf7f06
+-- hash: 84f85626582b6f0f3f7b0c3dadf65d7f797a14e8a50389db1167f6652ec74e28
 
 name:                gargantext
 version:             0.1.0.0
@@ -13,8 +13,7 @@ license:             BSD3
 license-file:        LICENSE
 author:              Gargantext Team
 maintainer:          team@gargantext.org
-copyright:           Copyright: (c) 2017,
-                     2018 CNRS Alexandre Delanoë
+copyright:           Copyright: (c) 2017-2018: see git logs and README
 category:            Data
 build-type:          Simple
 cabal-version:       >= 1.10
@@ -58,6 +57,7 @@ library
     , safe
     , semigroups
     , servant
+    , servant-auth
     , servant-client
     , servant-multipart
     , servant-server
@@ -105,13 +105,15 @@ library
       Gargantext.Parsers.Date
       Gargantext.Prelude
       Gargantext.RCT
-      Gargantext.Server
+      Gargantext.API
+      Gargantext.API.Auth
       Gargantext.Types
       Gargantext.Types.Main
       Gargantext.Types.Node
       Gargantext.Utils.DateUtils
       Gargantext.Utils.Prefix
   other-modules:
+      Gargantext.API.Node
       Gargantext.Utils
       Paths_gargantext
   default-language: Haskell2010

package.yaml

@@ -6,8 +6,7 @@ category: Data
 author: Gargantext Team
 maintainer: team@gargantext.org
 copyright:
-- ! 'Copyright: (c) 2017'
-- 2018 CNRS Alexandre Delanoë
+    - ! 'Copyright: (c) 2017-2018: see git logs and README'
 license: BSD3
 homepage: https://gargantext.org
 ghc-options: -Wall
@@ -50,7 +49,8 @@ library:
   - Gargantext.Parsers.Date
   - Gargantext.Prelude
   - Gargantext.RCT
-  - Gargantext.Server
+  - Gargantext.API
+  - Gargantext.API.Auth
   - Gargantext.Types
   - Gargantext.Types.Main
   - Gargantext.Types.Node
@@ -93,6 +93,7 @@ library:
   - servant-client
   - servant-multipart
   - servant-server
+  - servant-auth
   - split
   - tagsoup
   - text-metrics

src/Gargantext/Server.hs → src/Gargantext/API.hs

-
 {-|
 Module      : Gargantext.Server
 Description : Server API
@@ -10,64 +9,61 @@ Portability : POSIX
 
 Main REST API of Gargantext (both Server and Client sides)
 
+TODO/IDEA, use MOCK feature of Servant to generate fake data (for tests)
 -}
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE DataKinds       #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators   #-}
-module Gargantext.Server
---    ( startApp
---    , app
---    )
+
+module Gargantext.API
       where
 
 import Gargantext.Prelude
 
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Aeson
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Servant
-import Servant.Multipart
 import Database.PostgreSQL.Simple (Connection, connect)
-import Opaleye
-import System.IO (FilePath, putStrLn, readFile, print)
-import Data.Text (Text(), pack)
-import Gargantext.Types.Main (Node, NodeId)
-import Gargantext.Database.Node (getNodesWithParentId, getNode)
-import Gargantext.Database.Private (databaseParameters)
+import System.IO (FilePath, print)
 
--- | TODO, use MOCK feature of Servant to generate fake data (for tests)
 
-type NodeAPI = Get '[JSON] (Node Value)
-           :<|> "children" :> Get '[JSON] [Node Value]
+-- import Gargantext.API.Auth
+import Gargantext.API.Node ( Roots    , roots
+                           , NodeAPI  , nodeAPI
+                           , NodesAPI , nodesAPI
+                           )
 
-type API =  "roots"  :> Get '[JSON] [Node Value]
-       :<|> "node"   :> Capture "id" Int            :> NodeAPI
-       :<|> "echo"   :> Capture "string" Text     :> Get '[JSON] Text
-       :<|> "upload" :> MultipartForm MultipartData :> Post '[JSON] Text
+import Gargantext.Database.Private (databaseParameters)
 
-       -- :<|> "node"  :> Capture "id" Int        :> Get '[JSON] Node
 
-server :: Connection -> Server API
-server conn
-    = liftIO (getNodesWithParentId conn 0)
-  :<|> nodeAPI conn
-  :<|> echo
-  :<|> upload
-    where
-        echo s = pure s
 
+-- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: Int -> FilePath -> IO ()
 startGargantext port file = do
-  
   print ("Starting server on port " <> show port)
   param <- databaseParameters file
   conn  <- connect param
+  run port ( app conn )
 
-  run port $ app conn
+
+-- | Main routes of the API are typed
+type API =  "roots"  :> Roots
+       :<|> "node"   :> Capture "id" Int      :> NodeAPI
+       :<|> "nodes"  :> ReqBody '[JSON] [Int] :> NodesAPI
+
+       -- :<|> "static"   
+       -- :<|> "list"     :> Capture "id" Int  :> NodeAPI
+       -- :<|> "ngrams"   :> Capture "id" Int  :> NodeAPI
+       -- :<|> "auth"     :> Capture "id" Int  :> NodeAPI
+
+
+-- | Server declaration
+server :: Connection -> Server API
+server conn =  roots   conn
+          :<|> nodeAPI conn
+          :<|> nodesAPI conn
 
 -- | TODO App type, the main monad in which the bot code is written with.
 -- Provide config, state, logs and IO
@@ -82,26 +78,3 @@ app = serve api . server
 api :: Proxy API
 api = Proxy
 
-nodeAPI :: Connection -> NodeId -> Server NodeAPI
-nodeAPI conn id
-    =  liftIO (getNode conn id')
-  :<|> liftIO (getNodesWithParentId conn id)
-    where
-        id' = pgInt4 id
-
--- | Upload files
--- TODO Is it possible to adapt the function according to iValue input ?
-upload :: MultipartData -> Handler Text
-upload multipartData = do
-  liftIO $ do
-    putStrLn "Inputs:"
-    forM_ (inputs multipartData) $ \input ->
-      putStrLn $ "  " <> show (iName input)
-            <> " -> " <> show (iValue input)
-
-    forM_ (files multipartData) $ \file -> do
-      content <- readFile (fdFilePath file)
-      putStrLn $ "Content of " <> show (fdFileName file)
-              <> " at " <> fdFilePath file
-      putStrLn content
-  pure (pack "Data loaded")

src/Gargantext/API/Auth.hs

+{-|
+Module      : Gargantext.API.Auth
+Description : Server API Auth Module
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Main authorisation of Gargantext are managed in this module
+
+-- 1: Implement the Server / Client JWT authentication
+      -> Client towards Python Backend
+      -> Server towards Purescript Front-End
+
+-- 2: Implement the Auth API backend
+    https://github.com/haskell-servant/servant-auth
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Gargantext.API.Auth
+      where
+
+--import Gargantext.Prelude
+
+--data Auth = Auth { username :: Text
+--                 , password :: Text
+--                 } deriving (Generics)
+

src/Gargantext/API/Node.hs

+{-|
+Module      : Gargantext.API.Node
+Description : Server API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Node API
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators   #-}
+
+module Gargantext.API.Node
+      where
+
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (Value())
+import Servant
+import Servant.Multipart
+import System.IO (putStrLn, readFile)
+import Data.Text (Text(), pack)
+import Database.PostgreSQL.Simple (Connection)
+import Gargantext.Prelude
+import Gargantext.Types.Main (Node, NodeId, NodeType)
+import Gargantext.Database.Node (getNodesWithParentId
+                                , getNode, getNodesWith
+                                , deleteNode, deleteNodes)
+
+
+-- | Node API Types management
+type Roots = Get '[JSON] [Node Value]
+
+type NodesAPI  = Delete '[JSON] Int
+
+type NodeAPI   = Get '[JSON] (Node Value)
+             :<|> Delete '[JSON] Int
+
+                -- Example for Document Facet view, to populate the tabular:
+                -- http://localhost:8008/node/347476/children?type=Document&limit=3
+                -- /!\ FIXME : nodeType is case sensitive
+                -- /!\ see NodeTypes in Types/Main.hs
+             :<|> "children" :> QueryParam "type"   NodeType
+                             :> QueryParam "offset" Int
+                             :> QueryParam "limit"  Int
+                             :> Get '[JSON] [Node Value]
+             
+                -- Depending on the Type of the Node, we could post
+                -- New documents for a corpus
+                -- New map list terms
+             :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
+                
+                -- To launch a query and update the corpus
+             :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
+
+
+
+-- | Node API functions
+roots :: Connection -> Server Roots
+roots conn = liftIO (getNodesWithParentId conn 0 Nothing)
+
+nodeAPI :: Connection -> NodeId -> Server NodeAPI
+nodeAPI conn id =  liftIO (getNode              conn id)
+              :<|> deleteNode' conn id
+              :<|> getNodesWith' conn id
+              :<|> upload
+              :<|> query
+
+nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
+nodesAPI conn ids = deleteNodes' conn ids
+
+deleteNodes' :: Connection -> [NodeId] -> Handler Int
+deleteNodes' conn ids = liftIO (deleteNodes conn ids)
+
+deleteNode' :: Connection -> NodeId -> Handler Int
+deleteNode' conn id = liftIO (deleteNode conn id)
+
+getNodesWith' :: Connection -> NodeId -> Maybe NodeType -> Maybe Int -> Maybe Int 
+                        -> Handler [Node Value]
+getNodesWith' conn id nodeType offset limit  = liftIO (getNodesWith conn id nodeType offset limit)
+
+
+query :: Text -> Handler Text
+query s = pure s
+
+
+-- | Upload files
+-- TODO Is it possible to adapt the function according to iValue input ?
+upload :: MultipartData -> Handler Text
+upload multipartData = do
+  liftIO $ do
+    putStrLn "Inputs:"
+    forM_ (inputs multipartData) $ \input ->
+      putStrLn $ "  " <> show (iName input)
+            <> " -> " <> show (iValue input)
+
+    forM_ (files multipartData) $ \file -> do
+      content <- readFile (fdFilePath file)
+      putStrLn $ "Content of " <> show (fdFileName file)
+              <> " at " <> fdFilePath file
+      putStrLn content
+  pure (pack "Data loaded")
+

src/Gargantext/Database/Node.hs

+{-|
+Module      : Gargantext.Database.Node
+Description : Main requests of Node to the database
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -15,7 +25,8 @@ import Database.PostgreSQL.Simple.FromField ( Conversion
                                             , fromField
                                             , returnError
                                             )
-import Prelude hiding (null, id)
+import Prelude hiding (null, id, map)
+import Gargantext.Types.Main (NodeType)
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Control.Arrow (returnA)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
@@ -106,21 +117,76 @@ nodeTable = Table "nodes" (pNode Node { node_id                = optional "id"
                             )
 
 
+queryNodeTable :: Query NodeRead
+queryNodeTable = queryTable nodeTable
+
+
 selectNodes :: Column PGInt4 -> Query NodeRead
 selectNodes id = proc () -> do
     row <- queryNodeTable -< ()
     restrict -< node_id row .== id
     returnA -< row
 
-runGetNodes :: Connection -> Query NodeRead -> IO [Document]
+runGetNodes :: Connection -> Query NodeRead -> IO [Node Value]
 runGetNodes = runQuery
 
 
+type ParentId = NodeId
+type Limit    = Int
+type Offset    = Int
+
+-- | order by publication date
+-- Favorites (Bool), node_ngrams
+selectNodesWith :: ParentId -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Query NodeRead
+selectNodesWith parentId maybeNodeType maybeOffset maybeLimit = 
+        --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
+        offset' maybeOffset $ limit' maybeLimit $ orderBy (asc node_id) $ selectNodesWith' parentId maybeNodeType
+
+
+limit' ::  Maybe Limit -> Query NodeRead -> Query NodeRead
+limit' maybeLimit query = maybe query (\l -> limit l query) maybeLimit
+
+
+offset' :: Maybe Offset -> Query NodeRead  -> Query NodeRead
+offset' maybeOffset query = maybe query (\o -> offset o query) maybeOffset
+
+
+selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
+selectNodesWith' parentId maybeNodeType = proc () -> do
+    node <- (proc () -> do
+            row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
+            restrict -< parentId' .== (toNullable $ pgInt4 parentId)
+            
+            let typeId' = maybe 0 nodeTypeId maybeNodeType
+            
+            restrict -< if typeId' > 0
+                           then typeId   .== (pgInt4 (typeId' :: Int))
+                           else (pgBool True)
+            returnA  -< row ) -< ()
+    returnA -< node
+
+
+
+deleteNode :: Connection -> Int -> IO Int
+deleteNode conn n = fromIntegral 
+                 <$> runDelete conn nodeTable 
+                 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
+
+deleteNodes :: Connection -> [Int] -> IO Int
+deleteNodes conn ns = fromIntegral 
+                   <$> runDelete conn nodeTable 
+                   (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
+
+
+getNodesWith :: Connection -> Int -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [Node Value]
+getNodesWith conn parentId nodeType maybeOffset maybeLimit = 
+    runQuery conn $ selectNodesWith 
+                  parentId nodeType maybeOffset maybeLimit
 
 
 -- NP check type
-getNodesWithParentId :: Connection -> Int -> IO [Node Value]
-getNodesWithParentId conn n = runQuery conn $ selectNodesWithParentID n
+getNodesWithParentId :: Connection -> Int -> Maybe Text -> IO [Node Value]
+getNodesWithParentId conn n _ = runQuery conn $ selectNodesWithParentID n
 
 selectNodesWithParentID :: Int -> Query NodeRead
 selectNodesWithParentID n = proc () -> do
@@ -132,9 +198,6 @@ selectNodesWithParentID n = proc () -> do
                         isNull parent_id
     returnA -< row
 
-queryNodeTable :: Query NodeRead
-queryNodeTable = queryTable nodeTable
-
 
 
 
@@ -144,20 +207,12 @@ selectNodesWithType type_id = proc () -> do
     restrict -< tn .== type_id
     returnA -< row
 
-getNode :: Connection -> Column PGInt4 -> IO (Node Value)
+getNode :: Connection -> Int -> IO (Node Value)
 getNode conn id = do
-    fromMaybe (error "TODO: 404") . headMay <$> runQuery conn (limit 1 $ selectNodes id)
+    fromMaybe (error "TODO: 404") . headMay <$> runQuery conn (limit 1 $ selectNodes (pgInt4 id))
 
 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node Value]
 getNodesWithType conn type_id = do
     runQuery conn $ selectNodesWithType type_id
 
 
--- NP check type
-getCorpusDocument :: Connection -> Int -> IO [Document]
-getCorpusDocument conn n = runQuery conn (selectNodesWithParentID n)
-
--- NP check type
-getProjectCorpora :: Connection -> Int -> IO [Corpus]
-getProjectCorpora conn node_id = do
-    runQuery conn $ selectNodesWithParentID node_id

src/Gargantext/Types/Main.hs

@@ -11,6 +11,7 @@ Here is a longer description of this module, containing some
 commentary with @some markup@.
 -}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric     #-}
 
 module Gargantext.Types.Main where
 
@@ -19,7 +20,12 @@ import Prelude
 import Data.Eq (Eq())
 import Data.Monoid ((<>))
 import Protolude (fromMaybe)
-
+import Data.Aeson
+import GHC.Generics
+import Servant
+import Data.Text (unpack)
+import Text.Read (read)
+import Data.Either (Either(Right))
 --import Data.ByteString (ByteString())
 import Data.Text (Text)
 import Data.Time (UTCTime)
@@ -87,7 +93,11 @@ data NodeType = NodeUser | Project | Corpus | Document | DocumentCopy
               | Classification
               | Lists
               | Metrics
-              deriving (Show, Read, Eq)
+              deriving (Show, Read, Eq, Generic)
+
+instance FromJSON NodeType
+instance ToJSON NodeType
+instance FromHttpApiData NodeType where parseUrlPiece = Right . read . unpack
 
 data Classification = Favorites | MyClassifcation
 

stack.yaml

@@ -9,4 +9,5 @@ extra-deps:
 - duckling-0.1.3.0
 - protolude-0.2
 - servant-multipart-0.10.0.1
+- servant-auth-0.3.0.1
 resolver: lts-9.2