Merge branch 'dev-phylo' of https://gitlab.iscpif.fr/gargantext/haskell-gargantext...
[gargantext.git] / src / Gargantext / Database / Facet.hs
index 895323395b37df97ff4f74e6794d42d53a94e1c8..31e15fb83fdd2ee00b99d2e544eaa7f05bc59f02 100644 (file)
@@ -11,54 +11,50 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
-
 {-# LANGUAGE Arrows                    #-}
 {-# LANGUAGE DeriveGeneric             #-}
 {-# LANGUAGE FlexibleContexts          #-}
 {-# LANGUAGE FlexibleInstances         #-}
 {-# LANGUAGE FunctionalDependencies    #-}
 {-# LANGUAGE MultiParamTypeClasses     #-}
+{-# LANGUAGE QuasiQuotes               #-}
 {-# LANGUAGE NoImplicitPrelude         #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE TemplateHaskell           #-}
 ------------------------------------------------------------------------
-module Gargantext.Database.Facet 
+module Gargantext.Database.Facet
   where
 ------------------------------------------------------------------------
-
-import Prelude hiding (null, id, map, sum, not, read)
-import Prelude (Enum, Bounded, minBound, maxBound)
-import GHC.Generics (Generic)
-
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Either(Either(Left))
 import Control.Arrow (returnA)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
-
+import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson.TH (deriveJSON)
+import Data.Either(Either(Left))
 import Data.Maybe (Maybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Swagger
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Data.Time.Segment (jour)
-import Data.Swagger
-
-import Database.PostgreSQL.Simple (Connection)
-import           Opaleye
-import qualified Opaleye.Internal.Unpackspec()
-
-import Servant.API
-import Test.QuickCheck.Arbitrary
-import Test.QuickCheck (elements)
-
+import GHC.Generics (Generic)
 import Gargantext.Core.Types
 import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.NodeNode
-import Gargantext.Database.Node
-import Gargantext.Database.Queries
 import Gargantext.Database.Config (nodeTypeId)
--- import Gargantext.Database.NodeNgram
+import Gargantext.Database.Schema.Ngrams
+import Gargantext.Database.Schema.Node
+import Gargantext.Database.Schema.NodeNgram
+import Gargantext.Database.Schema.NodeNode
+import Gargantext.Database.Utils
+import Gargantext.Database.Queries.Join
+import Gargantext.Database.Queries.Filter
+import Opaleye
+import Prelude hiding (null, id, map, sum, not, read)
+import Servant.API
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary
+import qualified Opaleye.Internal.Unpackspec()
 
 ------------------------------------------------------------------------
 -- | DocFacet
@@ -77,7 +73,6 @@ type FacetAuthors = FacetDoc
 type FacetTerms   = FacetDoc
 
 
-
 data Facet id created title hyperdata favorite ngramCount = 
      FacetDoc { facetDoc_id         :: id
               , facetDoc_created    :: created
@@ -86,16 +81,68 @@ data Facet id created title hyperdata favorite ngramCount =
               , facetDoc_favorite   :: favorite
               , facetDoc_ngramCount :: ngramCount
               } deriving (Show, Generic)
+{- | TODO after demo
+data Facet id date hyperdata score = 
+     FacetDoc { facetDoc_id        :: id
+              , facetDoc_date      :: date
+              , facetDoc_hyperdata :: hyperdata
+              , facetDoc_score     :: score
+              } deriving (Show, Generic)
+-}
 
--- | JSON instance
+data Pair i l = Pair {_p_id    :: i
+                     ,_p_label :: l
+  } deriving (Show, Generic)
+$(deriveJSON (unPrefix "_p_") ''Pair)
+$(makeAdaptorAndInstance "pPair" ''Pair)
+
+instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
+instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
+  arbitrary = Pair <$> arbitrary <*> arbitrary
+
+data FacetPaired id date hyperdata score pairs =
+  FacetPaired {_fp_id        :: id
+              ,_fp_date      :: date
+              ,_fp_hyperdata :: hyperdata
+              ,_fp_score     :: score
+              ,_fp_pairs     :: pairs
+  } deriving (Show, Generic)
+$(deriveJSON (unPrefix "_fp_") ''FacetPaired)
+$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
+
+instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
+
+instance ( Arbitrary id
+         , Arbitrary date
+         , Arbitrary hyperdata
+         , Arbitrary score
+         , Arbitrary pairs
+         ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
+  arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+--{-
+type FacetPairedRead = FacetPaired (Column PGInt4       )
+                                   (Column PGTimestamptz)
+                                   (Column PGJsonb      )
+                                   (Column PGInt4       )
+                                   (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
+--}
 
+
+
+-- | JSON instance
 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 
 -- | Documentation instance
 instance ToSchema FacetDoc
 
 -- | Mock and Quickcheck instances
-
 instance Arbitrary FacetDoc where
     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
                          | id'  <- [1..10]
@@ -132,9 +179,9 @@ instance Arbitrary FacetChart where
 
 -----------------------------------------------------------------------
 type Trash   = Bool
-data OrderBy =  DateAsc | DateDesc
-             | TitleAsc | TitleDesc
-             | FavDesc  | FavAsc
+data OrderBy =  DateAsc   | DateDesc
+             | TitleAsc   | TitleDesc
+             | ScoreDesc  | ScoreAsc
              deriving (Generic, Enum, Bounded, Read, Show)
              -- | NgramCoun
 
@@ -144,8 +191,8 @@ instance FromHttpApiData OrderBy
     parseUrlPiece "DateDesc" = pure DateDesc
     parseUrlPiece "TitleAsc" = pure TitleAsc
     parseUrlPiece "TitleDesc" = pure TitleDesc
-    parseUrlPiece "FavAsc"   = pure FavAsc
-    parseUrlPiece "FavDesc"   = pure FavDesc
+    parseUrlPiece "ScoreAsc"   = pure ScoreAsc
+    parseUrlPiece "ScoreDesc"  = pure ScoreDesc
     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 
 instance ToParamSchema OrderBy
@@ -156,155 +203,82 @@ instance Arbitrary OrderBy
   where
     arbitrary = elements [minBound..maxBound]
 
-viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
-viewDocuments cId t ntId = proc () -> do
-  n  <- queryNodeTable -< ()
-  nn <- queryNodeNodeTable -< ()
-  restrict -< _node_id n .== nodeNode_node2_id nn
-  restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
-  restrict -< _node_typename    n  .== (pgInt4 ntId)
-  restrict -< nodeNode_delete   nn .== (pgBool t)
-  returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 
-
-filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
-     Maybe Gargantext.Core.Types.Offset
-     -> Maybe Gargantext.Core.Types.Limit
-     -> Maybe OrderBy
-     -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
-     -> Query  (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
-filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
+runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
   where
-    ordering = case order of
-      (Just DateAsc)   -> asc  facetDoc_created
-      
-      (Just TitleAsc)  -> asc  facetDoc_title
-      (Just TitleDesc) -> desc facetDoc_title
-      
-      (Just FavAsc)    -> asc  facetDoc_favorite
-      (Just FavDesc)   -> desc facetDoc_favorite
-      _                -> desc facetDoc_created
-
-
-runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
-runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
-
--- | TODO use only Cmd with Reader and delete function below
-runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
-                                                $ viewDocuments cId t ntId)
-  where
-    ntId = nodeTypeId NodeDocument
+    ntId = NodeDocument
 
+-- TODO add delete ?
+viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
+viewAuthorsDoc cId _ nt = proc () -> do
+  (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 
+  {-nn         <- queryNodeNodeTable -< ()
+  restrict -< nodeNode_node1_id nn .== _node_id doc
+  -- restrict -< nodeNode_delete   nn .== (pgBool t)
+  -}
 
+  restrict -< _node_id   contact   .== (toNullable $ pgNodeId cId)
+  restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 
-{-
-getDocFacet :: Connection -> NodeType -> Int -> Maybe NodeType 
-            -> Maybe Offset -> Maybe Limit
-            -> IO [FacetDoc]
-getDocFacet conn parentType parentId nodeType maybeOffset maybeLimit =
-    runQuery conn $ selectDocFacet parentType parentId nodeType maybeOffset maybeLimit
+  returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 
-selectDocFacet :: NodeType -> ParentId -> Maybe NodeType
-               -> Maybe Offset -> Maybe Limit
-               -> Query FacetDocRead
-selectDocFacet pType parentId maybeNodeType maybeOffset maybeLimit =
-        limit' maybeLimit $ offset' maybeOffset
-                          $ orderBy (asc facetDoc_created)
-                          $ selectDocFacet' pType parentId maybeNodeType
-
-
--- | Left join to the favorites
-nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
-nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
+queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
+queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
     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
-
-
-leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
-leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
-    where
-         cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
-                = (.==) occId occId'
-
-         cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
-         cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
-                = (.||) ((.==) (toNullable docId) docId') (isNull docId')
+         cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
+         cond12 (nodeNgram, doc) =  _node_id                  doc
+                                .== _nn_node_id nodeNgram
 
+         cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
+         cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
+                                        .== _nn_ngrams_id nodeNgram
+         
+         cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
+         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== _nn_ngrams_id       nodeNgram2
+         
+         cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
+         cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== _nn_node_id         nodeNgram2
 
-leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
-leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
-    where
-         cond12 (NodeNode favId _ _ _ _, Node favId' _ _ _ _ _ _)
-                = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
-
-         cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
-         cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _ _ _, Node _ _ _ _ _ _ _ ))
-                = ((.==) (nId) (nId'))
 
+------------------------------------------------------------------------
 
--- | Building the facet
-selectDocFacet' :: NodeType -> ParentId -> Maybe NodeType -> Query FacetDocRead
-selectDocFacet' _ pId _ = proc () -> do
-        (n1,(nn,_n2)) <- leftJoin3''' -< ()
-        restrict -< (.&&) (_node_parentId n1 .== (toNullable $ pgInt4 pId))
-                          (_node_typename n1 .== (pgInt4 $ nodeTypeId NodeDocument))
+runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+runViewDocuments cId t o l order =
+    runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
+  where
+    ntId = nodeTypeId NodeDocument
 
---        restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
---                          (isNull $ node_typename n2)
---
---        restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
---                          (isNull $ node_parentId n2)
+viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
+viewDocuments cId t ntId = proc () -> do
+  n  <- queryNodeTable     -< ()
+  nn <- queryNodeNodeTable -< ()
+  restrict -< _node_id          n  .== nodeNode_node2_id nn
+  restrict -< nodeNode_node1_id nn .== (pgNodeId cId)
+  restrict -< _node_typename    n  .== (pgInt4 ntId)
+  restrict -< nodeNode_delete   nn .== (pgBool t)
+  returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 
-        let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 
-        returnA  -< FacetDoc (_node_id n1) (_node_date n1) (_node_hyperdata n1) (isFav) (pgInt4 1)
+------------------------------------------------------------------------
+filterWith :: (PGOrd date, PGOrd title, PGOrd score) =>
+     Maybe Gargantext.Core.Types.Offset
+     -> Maybe Gargantext.Core.Types.Limit
+     -> Maybe OrderBy
+     -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
+     -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
+filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
+
+
+orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3) => Maybe OrderBy -> Order (Facet id (Column b1) (Column b2) hyperdata (Column b3) score)
+orderWith order = case order of
+  (Just DateAsc)   -> asc  facetDoc_created
+  
+  (Just TitleAsc)  -> asc  facetDoc_title
+  (Just TitleDesc) -> desc facetDoc_title
+  
+  (Just ScoreAsc)  -> asc  facetDoc_favorite
+  (Just ScoreDesc) -> desc facetDoc_favorite
+  _                -> desc facetDoc_created
 
--}