Eleve...
[gargantext.git] / src / Gargantext / Database / Facet.hs
index 38a0ab793abd9c0230d86b8abe14bdd6915fdbc3..166c51df86fbe68b30742f75b7a6ebff954b0e37 100644 (file)
@@ -21,37 +21,36 @@ Portability : POSIX
 {-# LANGUAGE NoImplicitPrelude         #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE TemplateHaskell           #-}
+{-# LANGUAGE TypeFamilies              #-}
 ------------------------------------------------------------------------
 module Gargantext.Database.Facet
   where
 ------------------------------------------------------------------------
-
 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.Default
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.Swagger
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Data.Time.Segment (jour)
-import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 import Gargantext.Core.Types
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Config (nodeTypeId)
-import Gargantext.Database.Ngrams
-import Gargantext.Database.Node
-import Gargantext.Database.NodeNgram
-import Gargantext.Database.NodeNode
-import Gargantext.Database.Queries
+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 Opaleye.Internal.Join (NullMaker(..))
-import Prelude (Enum, Bounded, minBound, maxBound)
 import Prelude hiding (null, id, map, sum, not, read)
 import Servant.API
 import Test.QuickCheck (elements)
@@ -75,7 +74,6 @@ type FacetAuthors = FacetDoc
 type FacetTerms   = FacetDoc
 
 
-
 data Facet id created title hyperdata favorite ngramCount = 
      FacetDoc { facetDoc_id         :: id
               , facetDoc_created    :: created
@@ -84,22 +82,74 @@ 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)
+-}
+
+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
 
+
+-- | 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]
                          , year <- [1990..2000]
                          , t    <- ["title", "another title"]
-                         , hp   <- hyperdataDocuments
+                         , hp   <- arbitraryHyperdataDocuments
                          , fav  <- [True, False]
                          , ngramCount <- [3..100]
                          ]
@@ -117,34 +167,25 @@ type FacetDocRead = Facet (Column PGInt4       )
                           (Column PGInt4       )
 
 -----------------------------------------------------------------------
-
-data FacetChart = FacetChart { facetChart_time  :: UTCTime'
-                             , facetChart_count :: Double
-                        }
-        deriving (Show, Generic)
-$(deriveJSON (unPrefix "facetChart_") ''FacetChart)
-instance ToSchema FacetChart
-
-instance Arbitrary FacetChart where
-    arbitrary = FacetChart <$> arbitrary <*> arbitrary
-
 -----------------------------------------------------------------------
 type Trash   = Bool
-data OrderBy =  DateAsc | DateDesc
-             | TitleAsc | TitleDesc
-             | FavDesc  | FavAsc
+data OrderBy =  DateAsc   | DateDesc
+             | TitleAsc   | TitleDesc
+             | ScoreDesc  | ScoreAsc
+             | SourceAsc  | SourceDesc
              deriving (Generic, Enum, Bounded, Read, Show)
-             -- | NgramCoun
 
 instance FromHttpApiData OrderBy
   where
-    parseUrlPiece "DateAsc"  = pure DateAsc
-    parseUrlPiece "DateDesc" = pure DateDesc
-    parseUrlPiece "TitleAsc" = pure TitleAsc
-    parseUrlPiece "TitleDesc" = pure TitleDesc
-    parseUrlPiece "FavAsc"   = pure FavAsc
-    parseUrlPiece "FavDesc"   = pure FavDesc
-    parseUrlPiece _           = Left "Unexpected value of OrderBy"
+    parseUrlPiece "DateAsc"    = pure DateAsc
+    parseUrlPiece "DateDesc"   = pure DateDesc
+    parseUrlPiece "TitleAsc"   = pure TitleAsc
+    parseUrlPiece "TitleDesc"  = pure TitleDesc
+    parseUrlPiece "ScoreAsc"   = pure ScoreAsc
+    parseUrlPiece "ScoreDesc"  = pure ScoreDesc
+    parseUrlPiece "SourceAsc"  = pure SourceAsc
+    parseUrlPiece "SourceDesc" = pure SourceDesc
+    parseUrlPiece _            = Left "Unexpected value of OrderBy"
 
 instance ToParamSchema OrderBy
 instance FromJSON  OrderBy
@@ -155,8 +196,8 @@ instance Arbitrary OrderBy
     arbitrary = elements [minBound..maxBound]
 
 
-runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-runViewAuthorsDoc c cId t o l order = runQuery c (filterDocuments o l order $ viewAuthorsDoc cId t ntId)
+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
     ntId = NodeDocument
 
@@ -166,11 +207,11 @@ 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 -< nn_node1_id nn .== _node_id doc
+  -- restrict -< nn_delete   nn .== (pgBool t)
   -}
 
-  restrict -< _node_id   contact   .== (toNullable $ pgInt4 cId)
+  restrict -< _node_id   contact   .== (toNullable $ pgNodeId cId)
   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 
   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
@@ -180,28 +221,24 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
     where
          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
          cond12 (nodeNgram, doc) =  _node_id                  doc
-                                .== nodeNgram_NodeNgramNodeId nodeNgram
+                                .== nng_node_id nodeNgram
 
          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
-                                        .== nodeNgram_NodeNgramNgramId nodeNgram
+                                        .== nng_ngrams_id nodeNgram
          
          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
-         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nodeNgram_NodeNgramNgramId        nodeNgram2
+         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nng_ngrams_id       nodeNgram2
          
          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
-         cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nodeNgram_NodeNgramNodeId         nodeNgram2
+         cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nng_node_id         nodeNgram2
 
 
 ------------------------------------------------------------------------
 
-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)
+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
 
@@ -209,171 +246,41 @@ 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)
+  restrict -< _node_id        n .== nn_node2_id nn
+  restrict -< nn_node1_id    nn .== (pgNodeId cId)
+  restrict -< _node_typename  n .== (pgInt4 ntId)
+  restrict -< nn_delete      nn .== (pgBool t)
+  returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nn_favorite nn) (pgInt4 1)
 
 
 ------------------------------------------------------------------------
-
-filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
+filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
      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
-  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
-
-
-
+     -> 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
 
-------------------------------------------------------------------------
--- | TODO move this queries utilties elsewhere
 
-leftJoin3' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
-leftJoin3' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
-    where
-         cond12 = undefined
-         cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
-         cond23 = undefined
-
-
-leftJoin3 :: ( Default Unpackspec columnsL1 columnsL1
-             , Default Unpackspec columnsL2 columnsL2
-             , Default Unpackspec columnsL3 columnsL3
-             
-             , Default Unpackspec nullableColumnsL2 nullableColumnsL2
-             
-             , Default NullMaker  columnsL2  nullableColumnsL2
-             , Default NullMaker (columnsL1, nullableColumnsL2) nullableColumnsL3
-             )
-             =>
-              Query columnsL1 -> Query columnsL2 -> Query columnsL3
-                -> ((columnsL1, columnsL2) -> Column PGBool)
-                -> ((columnsL3, (columnsL1, nullableColumnsL2)) -> Column PGBool)
-                -> Query (columnsL3, nullableColumnsL3)
-leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
+orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
+          => Maybe OrderBy
+          -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
+orderWith (Just DateAsc)   = asc  facetDoc_created
+orderWith (Just DateDesc)  = desc facetDoc_created
 
---{-
+orderWith (Just TitleAsc)  = asc  facetDoc_title
+orderWith (Just TitleDesc) = desc facetDoc_title
 
-leftJoin4' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))
-leftJoin4' = leftJoin4 queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
-    where
-         cond12 = undefined
-         
-         cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
-         cond23 = undefined
-         
-         cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
-         cond34 = undefined
-
-
-leftJoin4 :: ( Default Unpackspec fieldsL1 fieldsL1,
-               Default Unpackspec fieldsL2 fieldsL2,
-               Default Unpackspec fieldsL3 fieldsL3,
-               Default Unpackspec fieldsR fieldsR,
-               
-               Default Unpackspec nullableFieldsL1 nullableFieldsL1,
-               Default Unpackspec nullableFieldsL2 nullableFieldsL2,
-               Default NullMaker fieldsR nullableFieldsL2,
-               Default NullMaker (fieldsL2, nullableFieldsL1) nullableFieldsL3,
-               Default NullMaker (fieldsL3, nullableFieldsL2) nullableFieldsL1) =>
-     Query fieldsL3
-     -> Query fieldsR
-     -> Query fieldsL2
-     -> Query fieldsL1
-     -> ((fieldsL3, fieldsR)
-         -> Column PGBool)
-     -> ((fieldsL2, (fieldsL3, nullableFieldsL2))
-         -> Column PGBool)
-     -> ((fieldsL1, (fieldsL2, nullableFieldsL1))
-         -> Column PGBool)
-     -> Query (fieldsL1, nullableFieldsL3)
-leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q1 q2 cond12) cond23) cond34
---}
+orderWith (Just ScoreAsc)  = asc  facetDoc_favorite
+orderWith (Just ScoreDesc) = desc facetDoc_favorite
 
-{-
--}
-leftJoin5' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, (NodeReadNull, NodeReadNull))))
-leftJoin5' = leftJoin5 queryNodeTable queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34 cond45
-    where
-         cond12 :: (NodeRead, NodeRead) -> Column PGBool
-         cond12 = undefined
-         
-         cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
-         cond23 = undefined
-         
-         cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
-         cond34 = undefined
-         
-         cond45 :: (NodeRead, (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))) -> Column PGBool
-         cond45 = undefined
-
-
-leftJoin5 :: ( Default Unpackspec fieldsL1 fieldsL1,
-               Default Unpackspec fieldsL2 fieldsL2,
-               Default Unpackspec nullableFieldsR1 nullableFieldsR1,
-               Default Unpackspec fieldsL3 fieldsL3,
-               Default Unpackspec nullableFieldsR2 nullableFieldsR2,
-               Default Unpackspec fieldsL4 fieldsL4,
-               Default Unpackspec nullableFieldsR3 nullableFieldsR3,
-               Default Unpackspec fieldsR fieldsR,
-               Default NullMaker fieldsR nullableFieldsR3,
-               Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR4,
-               Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
-               Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2) =>
-               Query fieldsR
-               -> Query fieldsL4
-               -> Query fieldsL3
-               -> Query fieldsL2
-               -> Query fieldsL1
-               -> ((fieldsL4, fieldsR) -> Column PGBool)
-               -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
-               -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
-               -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
-               -> Query (fieldsL1, nullableFieldsR4)
-leftJoin5 q1 q2 q3 q4 q5 cond12 cond23 cond34 cond45 = leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45
-
-
-leftJoin6 :: ( Default Unpackspec fieldsL1 fieldsL1,
-               Default Unpackspec fieldsL2 fieldsL2,
-               Default Unpackspec nullableFieldsR1 nullableFieldsR1,
-               Default Unpackspec fieldsL3 fieldsL3,
-               Default Unpackspec nullableFieldsR2 nullableFieldsR2,
-               Default Unpackspec fieldsL4 fieldsL4,
-               Default Unpackspec nullableFieldsR3 nullableFieldsR3,
-               Default Unpackspec fieldsL5 fieldsL5,
-               Default Unpackspec nullableFieldsR4 nullableFieldsR4,
-               Default Unpackspec fieldsR fieldsR,
-               Default NullMaker fieldsR nullableFieldsR4,
-               Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR5,
-               Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
-               Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2,
-               Default NullMaker (fieldsL5, nullableFieldsR4) nullableFieldsR3) =>
-     Query fieldsR
-     -> Query fieldsL5
-     -> Query fieldsL4
-     -> Query fieldsL3
-     -> Query fieldsL2
-     -> Query fieldsL1 -> ((fieldsL5, fieldsR) -> Column PGBool)
-     -> ((fieldsL4, (fieldsL5, nullableFieldsR4)) -> Column PGBool)
-     -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
-     -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
-     -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
-     -> Query (fieldsL1, nullableFieldsR5)
-leftJoin6 q1 q2 q3 q4 q5 q6 cond12 cond23 cond34 cond45 cond56 =
-  leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56
+orderWith (Just SourceAsc)  = asc  facetDoc_source
+orderWith (Just SourceDesc) = desc facetDoc_source
 
+orderWith _                = asc facetDoc_created
 
+facetDoc_source :: PGIsJson a
+                => Facet id created title (Column a) favorite ngramCount
+                -> Column (Nullable PGText)
+facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"