[API/Count] Adding route and types.

gargantext.cabal

@@ -2,26 +2,27 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 20ddea403b5eab78aff204d088cc635422d7b9b34369ff1c4263e3ba67969442
+-- hash: 3346e420cce910077cbb6172c7e942960a4edd72fbab96679d4b45dacd84dcd9
 
-name:                gargantext
-version:             0.1.0.0
-synopsis:            Deep (Collaborative) Text mining project
-description:         Please see README.md
-homepage:            https://gargantext.org
-license:             BSD3
-license-file:        LICENSE
-author:              Gargantext Team
-maintainer:          team@gargantext.org
-copyright:           Copyright: (c) 2017-2018: see git logs and README
-category:            Data
-build-type:          Simple
-cabal-version:       >= 1.10
+name:           gargantext
+version:        0.1.0.0
+synopsis:       Deep (Collaborative) Text mining project
+description:    Please see README.md
+category:       Data
+homepage:       https://gargantext.org
+author:         Gargantext Team
+maintainer:     team@gargantext.org
+copyright:      Copyright: (c) 2017-2018: see git logs and README
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
 
 library
   hs-source-dirs:
       src
   default-extensions: NoImplicitPrelude
+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Werror
   build-depends:
       aeson
     , aeson-lens
@@ -59,6 +60,7 @@ library
     , servant
     , servant-auth
     , servant-client
+    , servant-mock
     , servant-multipart
     , servant-server
     , split
@@ -114,12 +116,12 @@ library
       Gargantext.Utils.DateUtils
       Gargantext.Utils.Prefix
   other-modules:
+      Gargantext.API.Count
       Gargantext.API.Node
       Gargantext.Database.Queries
       Gargantext.Utils
       Paths_gargantext
   default-language: Haskell2010
-  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Werror
 
 executable gargantext
   main-is: Main.hs

package.yaml

@@ -90,6 +90,7 @@ library:
   - safe
   - semigroups
   - servant
+  - servant-mock
   - servant-client
   - servant-multipart
   - servant-server

src/Gargantext/API.hs

 {-|
-Module      : Gargantext.Server
+Module      : Gargantext.API
 Description : Server API
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
@@ -16,6 +16,7 @@ TODO/IDEA, use MOCK feature of Servant to generate fake data (for tests)
 {-# LANGUAGE DataKinds       #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators   #-}
+{-# LANGUAGE DeriveGeneric   #-}
 
 module Gargantext.API
       where
@@ -24,16 +25,19 @@ import Gargantext.Prelude
 
 import Network.Wai
 import Network.Wai.Handler.Warp
+
 import Servant
+-- import Servant.API.Stream
+
 import Database.PostgreSQL.Simple (Connection, connect)
 import System.IO (FilePath, print)
 
-
 -- import Gargantext.API.Auth
 import Gargantext.API.Node ( Roots    , roots
                            , NodeAPI  , nodeAPI
                            , NodesAPI , nodesAPI
                            )
+import Gargantext.API.Count ( CountAPI, count, Query)
 
 import Gargantext.Database.Utils (databaseParameters)
 
@@ -50,9 +54,16 @@ startGargantext port file = do
 
 -- | Main routes of the API are typed
 type API =  "roots"  :> Roots
+       
        :<|> "node"   :> Capture "id" Int      :> NodeAPI
        :<|> "nodes"  :> ReqBody '[JSON] [Int] :> NodesAPI
+       
+       :<|> "count"  :> ReqBody '[JSON] Query :> CountAPI 
+       -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
 
+-- /mv/<id>/<id>
+-- /merge/<id>/<id>
+-- /rename/<id>
        -- :<|> "static"   
        -- :<|> "list"     :> Capture "id" Int  :> NodeAPI
        -- :<|> "ngrams"   :> Capture "id" Int  :> NodeAPI
@@ -64,6 +75,10 @@ server :: Connection -> Server API
 server conn =  roots   conn
           :<|> nodeAPI conn
           :<|> nodesAPI conn
+          :<|> count
+
+
+
 
 -- | TODO App type, the main monad in which the bot code is written with.
 -- Provide config, state, logs and IO

src/Gargantext/API/Count.hs

+{-|
+Module      : Gargantext.API.Count
+Description : Server API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Count API part of Gargantext.
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators   #-}
+{-# LANGUAGE DeriveGeneric   #-}
+
+module Gargantext.API.Count
+      where
+
+import Gargantext.Prelude
+
+import Data.Text (Text, pack)
+import Servant
+import GHC.Generics (Generic)
+import Data.Aeson hiding (Error)
+
+
+
+type CountAPI = Post '[JSON] Count
+
+data Scraper = Pubmed | Hal 
+  deriving (Generic)
+instance FromJSON Scraper
+instance ToJSON   Scraper
+
+
+data Query = Query { query_query :: Text
+                   , query_name  :: Maybe [Scraper]
+                   }
+                    deriving (Generic)
+instance FromJSON Query
+instance ToJSON   Query
+
+data Error = Error { error_message :: Text
+                   , error_code    :: Int
+             } deriving (Generic)
+instance FromJSON Error
+instance ToJSON   Error
+
+data Count = Count { count_name   :: Scraper
+                   , count_count  :: Maybe Int
+                   , count_errors :: Maybe [Error]
+                    } 
+                    deriving (Generic)
+instance FromJSON Count
+instance ToJSON   Count
+
+
+count :: Query -> Handler Count
+count _ = pure (Count Pubmed (Just 10) (Just [Error (pack "error message") 202]))
+
+

src/Gargantext/API/Node.hs

@@ -18,13 +18,13 @@ Node API
 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 Servant.Multipart
+--import System.IO (putStrLn, readFile)
+import Data.Text (Text())
+--import Data.Text (Text(), pack)
 import Database.PostgreSQL.Simple (Connection)
 import Gargantext.Prelude
 import Gargantext.Types.Main (Node, NodeId, NodeType)
@@ -57,7 +57,7 @@ type NodeAPI   = 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
+             -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
                 
                 -- To launch a query and update the corpus
              :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
@@ -73,7 +73,7 @@ nodeAPI conn id =  liftIO (getNode              conn id)
               :<|> deleteNode'   conn id
               :<|> getNodesWith' conn id
               :<|> getDocFacet'  conn id
-              :<|> upload
+              -- :<|> upload
               :<|> query
 
 nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
@@ -99,18 +99,18 @@ 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")
+--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/Facet.hs

+{-|
+Module      : Gargantext.Database.Facet
+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 #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE Arrows #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Gargantext.Database.Facet where
+
+import Prelude hiding (null, id, map, sum, not)
+
+import Gargantext.Types
+import Gargantext.Types.Main (NodeType)
+import Gargantext.Database.NodeNode
+import Gargantext.Database.NodeNodeNgram
+import Gargantext.Database.Node
+import Gargantext.Database.Queries
+import Gargantext.Utils.Prefix (unPrefix)
+-- import Gargantext.Database.NodeNgram
+
+-- import Data.Aeson (Value)
+import Data.Aeson.TH (deriveJSON)
+import Control.Arrow (returnA)
+import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Data.Maybe (Maybe)
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Time (UTCTime)
+import Database.PostgreSQL.Simple (Connection)
+import Opaleye
+import Opaleye.Internal.Join (NullMaker)
+
+import qualified Opaleye.Internal.Unpackspec()
+import Data.Profunctor.Product.Default (Default)
+
+-- DocFacet
+
+type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
+
+data Facet id created hyperdata favorite  = FacetDoc { facetDoc_id :: id
+                                                       , facetDoc_created   :: created
+                                                       , facetDoc_hyperdata :: hyperdata
+                                                       , facetDoc_favorite  :: favorite
+                                          -- To be added: Double
+                                          --             , facetDoc_ngramCount :: ngramCount
+                                                       } deriving (Show)
+$(deriveJSON (unPrefix "facetDoc_") ''Facet)
+
+
+
+-- Facets / Views for the Front End
+type FacetDocRead  = Facet (Column PGInt4) (Column PGTimestamptz) (Column PGJsonb) (Column PGBool) -- (Column PGFloat8)
+
+$(makeAdaptorAndInstance "pFacetDoc" ''Facet)
+$(makeLensesWith abbreviatedFields   ''Facet)
+
+getDocFacet :: Connection -> Int -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [FacetDoc]
+getDocFacet conn parentId nodeType maybeOffset maybeLimit = 
+    runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
+
+selectDocFacet :: ParentId -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Query FacetDocRead
+selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
+        limit' maybeLimit $ offset' maybeOffset $ orderBy (asc facetDoc_created) $ selectDocFacet' parentId maybeNodeType
+
+
+-- | Left join to the favorites
+nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
+nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
+    where
+        eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
+
+
+nodeNodeLeftJoin' :: (Column (Nullable PGInt4)) 
+                  -> Query (NodeRead, NodeNodeReadNull)
+nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
+        where
+            eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _) 
+                   = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
+                                               , ((.==) n1' n)
+                                               ]
+
+nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
+nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
+        where
+            eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _) 
+                   = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
+                                               , ((.==) (toNullable n1) n1')
+                                               ]
+
+-- | Left join to the ngram count per document
+nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
+nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
+     where
+        eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
+
+
+nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4) 
+                       -> Query (NodeRead, NodeNodeNgramReadNull)
+nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
+     where
+        eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _) 
+                 = (.&&) ((.==) n1 n1')
+                         ((.==) nId' (toNullable n2))
+
+
+leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
+                    Default NullMaker columnsR nullableColumnsR,
+                    Default Unpackspec columnsR columnsR,
+                    Default Unpackspec nullableColumnsR nullableColumnsR,
+                    Default Unpackspec columnsL1 columnsL1,
+                    Default Unpackspec columnsL columnsL) =>
+                   Query columnsL1
+                   -> Query columnsR
+                   -> Query columnsL
+                   -> ((columnsL1, columnsR) -> Column PGBool)
+                   -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
+                   -> Query (columnsL, nullableColumnsR1)
+leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
+
+-- | Building the facet
+selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
+selectDocFacet' parentId _ = proc () -> do
+    node <- (proc () -> do
+
+            -- Favorite Column
+            (Node _ favTypeId _ favParentId _ _ _)      <- queryNodeTable -< ()
+            restrict -< favTypeId .== 15 .&& favParentId .== (toNullable $ pgInt4 parentId)
+            
+            -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
+            -- Selecting the documents and joining Favorite Node
+            (Node docId docTypeId _ docParentId _ created docHyperdata, NodeNode _ docTypeId' _) <- nodeNodeLeftJoin' (toNullable $ pgInt4 347537) -< ()
+            restrict -< docParentId .== (toNullable $ pgInt4 parentId)
+            let docTypeId'' = maybe 0 nodeTypeId (Just Document)
+            restrict -< if docTypeId'' > 0
+                           then docTypeId   .== (pgInt4 (docTypeId'' :: Int))
+                           else (pgBool True)
+            
+            -- Getting favorite data
+            let isFav = ifThenElse (isNull docTypeId') (pgBool False) (pgBool True)
+            
+            -- Ngram count by document
+            -- Counting the ngram
+            -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
+            -- restrict -< occId .== 347540
+            
+            --returnA  -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
+            returnA  -< (FacetDoc docId created docHyperdata isFav)) -< ()
+    returnA -< node
+
+

src/Gargantext/Database/Queries.hs

+{-|
+Module      : Gargantext.Database.Queries
+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 #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE Arrows #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Gargantext.Database.Queries where
+
+import Gargantext.Prelude
+import Gargantext.Types (Limit, Offset, NodePoly)
+import Data.Maybe (Maybe, maybe)
+import Control.Arrow ((>>>))
+import Control.Applicative ((<*>))
+import Opaleye 
+-- (Query, limit, offset)
+
+
+type NodeWrite = NodePoly  (Maybe (Column PGInt4))  (Column PGInt4)
+                                  (Column PGInt4)   (Column (Nullable PGInt4))
+                                  (Column (PGText)) (Maybe (Column PGTimestamptz))
+                                  (Column PGJsonb) -- (Maybe (Column PGTSVector))
+
+type NodeRead = NodePoly  (Column PGInt4)   (Column PGInt4)
+                          (Column PGInt4)   (Column (Nullable PGInt4))
+                          (Column (PGText)) (Column PGTimestamptz)
+                          (Column PGJsonb) -- (Column PGTSVector)
+
+
+join3 :: Query columnsA -> Query columnsB -> Query columnsC 
+      -> ((columnsA, columnsB, columnsC) -> Column PGBool) 
+      -> Query (columnsA, columnsB, columnsC)
+join3 q1 q2 q3 cond = ((,,) <$> q1 <*> q2 <*> q3) >>> keepWhen cond
+
+
+--leftJoin3 :: Query columnsL1 -> Query columnsR -> Query columnsL
+--     -> ((columnsL1, columnsR) -> Column PGBool)
+--     -> ((columnsL, (columnsL1, nullableColumnsR1)) -> Column PGBool)
+--     -> Query (columnsL, nullableColumnsR)
+--leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
+
+
+limit' ::  Maybe Limit -> Query a -> Query a
+limit' maybeLimit query = maybe query (\l -> limit l query) maybeLimit
+
+
+offset' :: Maybe Offset -> Query a  -> Query a
+offset' maybeOffset query = maybe query (\o -> offset o query) maybeOffset
+
+
+
+

stack.yaml

@@ -2,12 +2,21 @@ flags: {}
 extra-package-dbs: []
 packages:
 - .
-#- /home/alexandre/local/logiciels/haskell/servant/servant-multipart
-#- /home/alexandre/local/logiciels/haskell/utc
 extra-deps:
 - aeson-1.0.2.1
+- attoparsec-0.13.2.2
 - duckling-0.1.3.0
+- http-media-0.7.1.2
+- http-types-0.11
+- mmorph-1.1.0
 - protolude-0.2
-- servant-multipart-0.10.0.1
+- servant-0.12.1
 - servant-auth-0.3.0.1
+- servant-client-0.12.0.1
+- servant-client-core-0.12
+- servant-docs-0.11.1
+- servant-mock-0.8.3
+- servant-multipart-0.11.1
+- servant-server-0.12
+- text-1.2.3.0
 resolver: lts-9.2