Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev
[gargantext.git] / src / Gargantext / Database / Schema / Ngrams.hs
index 2d5a2613b04296865d3b0bb9cf09e4e00ae9fead..0364a18580f9f5d60817fa9d074016dd4daf9fe1 100644 (file)
@@ -1,5 +1,5 @@
 {-|
-Module      : Gargantext.Database.Schema.Ngrams
+Module      : Gargantext.Database.Schema.NgramsPostag
 Description : Ngram connection to the Database
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
@@ -11,114 +11,155 @@ Ngrams connection to the Database.
 
 -}
 
-{-# LANGUAGE Arrows                     #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE FunctionalDependencies     #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE NoImplicitPrelude      #-}
-{-# LANGUAGE OverloadedStrings      #-}
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}
-{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
-module Gargantext.Database.Schema.Ngrams where
-
+module Gargantext.Database.Schema.Ngrams
+  where
 
-import Control.Lens (makeLenses, view, over)
+import Codec.Serialise (Serialise())
+import Control.Lens (over)
 import Control.Monad (mzero)
-import Data.ByteString.Internal (ByteString)
-import Data.Map (Map, fromList, lookup, fromListWith)
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Set (Set)
-import Data.Text (Text, splitOn)
-import Database.PostgreSQL.Simple ((:.)(..))
-import Database.PostgreSQL.Simple.FromRow (fromRow, field)
-import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Database.PostgreSQL.Simple.ToField (toField, ToField)
-import Database.PostgreSQL.Simple.FromField (FromField, fromField)
-import Database.PostgreSQL.Simple.ToRow   (toRow)
-import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
---import Debug.Trace (trace)
-import GHC.Generics (Generic)
-import Gargantext.Core.Types -- (fromListTypeId, ListType, NodePoly(Node))
-import Gargantext.Database.Config (nodeTypeId,userMaster)
-import Gargantext.Database.Root (getRoot)
-import Gargantext.Database.Types.Node (NodeType)
-import Gargantext.Database.Schema.Node (getListsWithParentId, getCorporaWithParentId)
-import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, formatPGSQuery)
+import Data.Aeson
+import Data.Aeson.Types (toJSONKeyText)
+import Data.HashMap.Strict (HashMap)
+import Data.Hashable (Hashable)
+import Data.Map (fromList, lookup)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, splitOn, pack, strip)
+import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..))
+import Gargantext.Core (HasDBid(..))
+import Gargantext.Core.Types (TODO(..), Typed(..))
+import Gargantext.Database.Schema.Prelude
+import Gargantext.Database.Types
 import Gargantext.Prelude
-import Opaleye hiding (FromField)
-import Prelude (Enum, Bounded, minBound, maxBound, Functor)
-import qualified Data.Set as DS
+import Servant (FromHttpApiData(..), Proxy(..), ToHttpApiData(..))
+import Test.QuickCheck (elements)
+import Text.Read (read)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.HashMap.Strict as HashMap
 import qualified Database.PostgreSQL.Simple as PGS
 
---{-
-data NgramsPoly id terms n = NgramsDb { ngrams_id    :: id
-                                    , ngrams_terms :: terms
-                                    , ngrams_n     :: n
-                                    } deriving (Show)
 
---}
-type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
-                                   (Column PGText)
-                                   (Column PGInt4)
+type NgramsId  = Int
+type Size      = Int
+
+data NgramsPoly id terms n = NgramsDB { _ngrams_id    :: !id
+                                      , _ngrams_terms :: !terms
+                                      , _ngrams_n     :: !n
+                                      } deriving (Show)
+
+type NgramsWrite = NgramsPoly (Maybe (Column SqlInt4))
+                                   (Column SqlText)
+                                   (Column SqlInt4)
 
-type NgramsRead  = NgramsPoly (Column PGInt4)
-                              (Column PGText)
-                              (Column PGInt4)
+type NgramsRead  = NgramsPoly (Column SqlInt4)
+                              (Column SqlText)
+                              (Column SqlInt4)
 
-type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
-                                 (Column (Nullable PGText))
-                                 (Column (Nullable PGInt4))
+type NgramsReadNull = NgramsPoly (Column (Nullable SqlInt4))
+                                 (Column (Nullable SqlText))
+                                 (Column (Nullable SqlInt4))
 
---{-
-type NgramsDb = NgramsPoly Int Text Int
+type NgramsDB = NgramsPoly Int Text Int
 
 $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
--- $(makeLensesWith abbreviatedFields   ''NgramsPoly)
+makeLenses ''NgramsPoly
+
 
 ngramsTable :: Table NgramsWrite NgramsRead
-ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id    = optional "id"
-                                            , ngrams_terms = required "terms"
-                                            , ngrams_n     = required "n"
-                                            }
-                                )
---{-
-queryNgramsTable :: Query NgramsRead
-queryNgramsTable = queryTable ngramsTable
-
-dbGetNgramsDb :: Cmd err [NgramsDb]
-dbGetNgramsDb = runOpaQuery queryNgramsTable
---}
+ngramsTable = Table "ngrams" (pNgramsDb NgramsDB { _ngrams_id    = optionalTableField "id"
+                                                 , _ngrams_terms = requiredTableField "terms"
+                                                 , _ngrams_n     = requiredTableField "n"
+                                                 }
+                              )
 
 -- | Main Ngrams Types
 -- | Typed Ngrams
 -- Typed Ngrams localize the context of the ngrams
--- ngrams in source field of document has Sources Type
--- ngrams in authors field of document has Authors Type
--- ngrams in text (title or abstract) of documents has Terms Type
+-- ngrams in source  field  of document  has Sources Type
+-- ngrams in authors field  of document  has Authors Type
+-- ngrams in text    fields of documents has Terms   Type (i.e. either title or abstract)
 data NgramsType = Authors | Institutes | Sources | NgramsTerms
-  deriving (Eq, Show, Ord, Enum, Bounded)
+  deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
+
+instance Serialise NgramsType
+instance FromJSON NgramsType
+  where
+    parseJSON (String "Authors")     = pure Authors
+    parseJSON (String "Institutes")  = pure Institutes
+    parseJSON (String "Sources")     = pure Sources
+    parseJSON (String "Terms")       = pure NgramsTerms
+    parseJSON (String "NgramsTerms") = pure NgramsTerms
+    parseJSON _                      = mzero
+
+instance FromJSONKey NgramsType where
+   fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
+
+instance ToJSON NgramsType
+  where
+    toJSON Authors     = String "Authors"
+    toJSON Institutes  = String "Institutes"
+    toJSON Sources     = String "Sources"
+    toJSON NgramsTerms = String "Terms"
+
+instance ToJSONKey NgramsType where
+   toJSONKey = toJSONKeyText (pack . show)
+instance FromHttpApiData NgramsType where
+  parseUrlPiece n = pure $ (read . cs) n
+instance ToHttpApiData NgramsType where
+  toUrlPiece = pack . show
+instance ToParamSchema NgramsType where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+instance Arbitrary NgramsType where
+  arbitrary = elements [ minBound .. maxBound ]
+
+-- map NgramsType to its assigned id
+instance FromField NgramsType where
+  fromField fld mdata =
+    case B.unpack `fmap` mdata of
+      Nothing -> returnError UnexpectedNull fld ""
+      Just dat -> do
+        n <- fromField fld mdata
+        if (n :: Int) > 0 then
+          case fromNgramsTypeId (NgramsTypeId n) of
+            Nothing -> returnError ConversionFailed fld dat
+            Just nt -> pure nt
+        else
+          returnError ConversionFailed fld dat
+instance ToField NgramsType where
+  toField nt = toField $ ngramsTypeId nt
+
+
+ngramsTypes :: [NgramsType]
+ngramsTypes = [minBound..]
+
+instance ToSchema NgramsType
+{-  where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
+--}
 
 newtype NgramsTypeId = NgramsTypeId Int
   deriving (Eq, Show, Ord, Num)
-
 instance ToField NgramsTypeId where
   toField (NgramsTypeId n) = toField n
-
 instance FromField NgramsTypeId where
   fromField fld mdata = do
     n <- fromField fld mdata
     if (n :: Int) > 0 then return $ NgramsTypeId n
                       else mzero
+instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
+  where
+    defaultFromField = fromPGSFromField
 
-pgNgramsType :: NgramsType -> Column PGInt4
+pgNgramsType :: NgramsType -> Column SqlInt4
 pgNgramsType = pgNgramsTypeId . ngramsTypeId
 
-pgNgramsTypeId :: NgramsTypeId -> Column PGInt4
-pgNgramsTypeId (NgramsTypeId n) = pgInt4 n
+pgNgramsTypeId :: NgramsTypeId -> Column SqlInt4
+pgNgramsTypeId (NgramsTypeId n) = sqlInt4 n
 
 ngramsTypeId :: NgramsType -> NgramsTypeId
 ngramsTypeId Authors     = 1
@@ -127,27 +168,52 @@ ngramsTypeId Sources     = 3
 ngramsTypeId NgramsTerms = 4
 
 fromNgramsTypeId :: NgramsTypeId -> Maybe NgramsType
-fromNgramsTypeId id = lookup id $ fromList [(ngramsTypeId nt,nt) | nt <- [minBound .. maxBound] :: [NgramsType]]
+fromNgramsTypeId id = lookup id
+                    $ fromList [ (ngramsTypeId nt,nt)
+                               | nt <- [minBound .. maxBound] :: [NgramsType]
+                               ]
+
+unNgramsTypeId :: NgramsTypeId -> Int
+unNgramsTypeId (NgramsTypeId i) = i
+
+toNgramsTypeId :: Int -> NgramsTypeId
+toNgramsTypeId i = NgramsTypeId i
 
-type NgramsTerms = Text
-type NgramsId    = Int
-type Size        = Int
+instance HasDBid NgramsType where
+  toDBid   = unNgramsTypeId . ngramsTypeId
+  fromDBid = fromMaybe (panic "NgramsType id not indexed") . fromNgramsTypeId . toNgramsTypeId
 
 ------------------------------------------------------------------------
--- | TODO put it in Gargantext.Text.Ngrams
-data Ngrams = Ngrams { _ngramsTerms :: Text
-                     , _ngramsSize  :: Int
-           } deriving (Generic, Show, Eq, Ord)
+------------------------------------------------------------------------
+-- | TODO put it in Gargantext.Core.Text.Ngrams
+data Ngrams = UnsafeNgrams { _ngramsTerms :: Text
+                           , _ngramsSize  :: Int
+                           }
+  deriving (Generic, Show, Eq, Ord)
+
+instance Hashable Ngrams
 
 makeLenses ''Ngrams
 instance PGS.ToRow Ngrams where
-  toRow (Ngrams t s) = [toField t, toField s]
+  toRow (UnsafeNgrams t s) = [toField t, toField s]
+
+instance FromField Ngrams where
+  fromField fld mdata = do
+    x <- fromField fld mdata
+    pure $ text2ngrams x
+
+instance PGS.ToRow Text where
+  toRow t = [toField t]
 
 text2ngrams :: Text -> Ngrams
-text2ngrams txt = Ngrams txt $ length $ splitOn " " txt
+text2ngrams txt = UnsafeNgrams txt' $ length $ splitOn " " txt'
+  where
+    txt' = strip txt
+
 
+------------------------------------------------------------------------
 -------------------------------------------------------------------------
--- | TODO put it in Gargantext.Text.Ngrams
+-- | TODO put it in Gargantext.Core.Text.Ngrams
 -- Named entity are typed ngrams of Terms Ngrams
 data NgramsT a =
   NgramsT { _ngramsType :: NgramsType
@@ -158,202 +224,23 @@ makeLenses ''NgramsT
 
 instance Functor NgramsT where
   fmap = over ngramsT
------------------------------------------------------------------------
-data NgramsIndexed =
-  NgramsIndexed
-  { _ngrams   :: Ngrams
-  , _ngramsId :: NgramsId
-  } deriving (Show, Generic, Eq, Ord)
-
-makeLenses ''NgramsIndexed
-------------------------------------------------------------------------
-data NgramIds =
-  NgramIds
-  { ngramId    :: Int
-  , ngramTerms :: Text
-  } deriving (Show, Generic, Eq, Ord)
-
-instance PGS.FromRow NgramIds where
-  fromRow = NgramIds <$> field <*> field
 
-----------------------
-withMap :: Map NgramsTerms NgramsId -> NgramsTerms -> NgramsId
-withMap m n = maybe (panic "withMap: should not happen") identity (lookup n m)
+-----------------------------------------------------------------------
+withMap :: HashMap Text NgramsId -> Text -> NgramsId
+withMap m n = maybe (panic $ "[G.D.S.Ngrams.withMap] Should not happen" <> (cs $ show n))
+                    identity (HashMap.lookup n m)
 
-indexNgramsT :: Map NgramsTerms NgramsId -> NgramsT Ngrams -> NgramsT NgramsIndexed
+indexNgramsT :: HashMap Text NgramsId -> NgramsT Ngrams -> NgramsT (Indexed Int Ngrams)
 indexNgramsT = fmap . indexNgramsWith . withMap
 
-indexNgrams :: Map NgramsTerms NgramsId -> Ngrams -> NgramsIndexed
-indexNgrams = indexNgramsWith . withMap
-
--- NP: not sure we need it anymore
-indexNgramsTWith :: (NgramsTerms -> NgramsId) -> NgramsT Ngrams -> NgramsT NgramsIndexed
-indexNgramsTWith = fmap . indexNgramsWith
-
-indexNgramsWith :: (NgramsTerms -> NgramsId) -> Ngrams -> NgramsIndexed
-indexNgramsWith f n = NgramsIndexed n (f $ _ngramsTerms n)
-
-insertNgrams :: [Ngrams] -> Cmd err (Map NgramsTerms NgramsId)
-insertNgrams ns = fromList <$> map (\(NgramIds i t) -> (t, i)) <$> (insertNgrams' ns)
+-- | TODO replace NgramsT whith Typed NgramsType Ngrams
+indexTypedNgrams :: HashMap Text NgramsId
+                 -> Typed NgramsType Ngrams
+                 -> Typed NgramsType (Indexed Int Ngrams)
+indexTypedNgrams = fmap . indexNgramsWith . withMap
 
-insertNgrams' :: [Ngrams] -> Cmd err [NgramIds]
-insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
-  where
-    fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
-
-insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd err ByteString
-insertNgrams_Debug ns = formatPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
-  where
-    fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
-
-----------------------
-queryInsertNgrams :: PGS.Query
-queryInsertNgrams = [sql|
-    WITH input_rows(terms,n) AS (?)
-    , ins AS (
-       INSERT INTO ngrams (terms,n)
-       SELECT * FROM input_rows
-       ON CONFLICT (terms) DO NOTHING -- unique index created here
-       RETURNING id,terms
-       )
-
-    SELECT id, terms
-    FROM   ins
-    UNION  ALL
-    SELECT c.id, terms
-    FROM   input_rows
-    JOIN   ngrams c USING (terms);     -- columns of unique index
-           |]
-
-
--- | Ngrams Table
--- TODO: the way we are getting main Master Corpus and List ID is not clean
--- TODO: if ids are not present -> create
--- TODO: Global Env State Monad to keep in memory the ids without retrieving it each time
-getNgramsTableDb :: NodeType -> NgramsType
-                 -> NgramsTableParamUser
-                 -> Limit -> Offset
-                 -> Cmd err ([NgramsTableData], MapToParent, MapToChildren)
-getNgramsTableDb nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
-  
-  
-  maybeRoot <- head <$> getRoot userMaster
-  let path = "Garg.Db.Ngrams.getTableNgrams: "
-  let masterRootId = maybe (panic $ path <> "no userMaster Tree") (view node_id) maybeRoot
-  -- let errMess = panic "Error"
-
-  corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId masterRootId
-  
-  listMasterId   <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId corpusMasterId
-  
-  ngramsTableData <- getNgramsTableData nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
-  
-  (mapToParent,mapToChildren) <- getNgramsGroup listIdUser listMasterId
-  pure (ngramsTableData, mapToParent,mapToChildren)
-
-
-data NgramsTableParam =
-     NgramsTableParam { _nt_listId     :: NodeId
-                      , _nt_corpusId   :: NodeId
-                      }
-
-type NgramsTableParamUser   = NgramsTableParam
-type NgramsTableParamMaster = NgramsTableParam
-
-data NgramsTableData = NgramsTableData { _ntd_ngrams   :: Text
-                                       , _ntd_n        :: Int
-                                       , _ntd_listType :: Maybe ListType
-                                       , _ntd_weight   :: Double
-    } deriving (Show)
-
-getNgramsTableData :: NodeType -> NgramsType
-                   -> NgramsTableParamUser -> NgramsTableParamMaster 
-                   -> Limit -> Offset
-                   -> Cmd err [NgramsTableData]
-getNgramsTableData nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
-  -- trace ("Ngrams table params" <> show params) <$>
-  map (\(t,n,nt,w) -> NgramsTableData t n (fromListTypeId nt) w) <$>
-    runPGSQuery querySelectTableNgrams params
-      where
-        nodeTId = nodeTypeId   nodeT
-        ngrmTId = ngramsTypeId ngrmT
-        params  = (ul,uc,nodeTId,ngrmTId,ml,mc,nodeTId,ngrmTId,uc) :.
-                  (limit_, offset_)
-
-
-
-querySelectTableNgrams :: PGS.Query
-querySelectTableNgrams = [sql|
-
-    WITH tableUser AS (
-      SELECT ngs.terms, ngs.n, list.list_type, corp.weight FROM ngrams ngs
-        JOIN nodes_ngrams list ON list.ngrams_id = ngs.id
-        JOIN nodes_ngrams corp ON corp.ngrams_id = ngs.id
-        JOIN nodes_nodes  nn   ON nn.node2_id    = corp.node_id
-        JOIN nodes        n    ON n.id           = corp.node_id
-      
-      WHERE list.node_id     = ?   -- User listId
-        AND nn.node1_id      = ?   -- User CorpusId or AnnuaireId
-        AND n.typename       = ?   -- both type of childs (Documents or Contacts)
-        AND corp.ngrams_type = ?   -- both type of ngrams (Authors or Terms or...)
-    )
-    , tableMaster AS (
-      SELECT ngs.terms, ngs.n, list.list_type, corp.weight FROM ngrams ngs
-        JOIN nodes_ngrams list ON list.ngrams_id = ngs.id
-        JOIN nodes_ngrams corp ON corp.ngrams_id = ngs.id
-        JOIN nodes        n    ON n.id          = corp.node_id
-        JOIN nodes_nodes  nn   ON nn.node2_id  = n.id
-        
-      WHERE list.node_id     = ?   -- Master listId
-        AND n.parent_id      = ?   -- Master CorpusId or AnnuaireId
-        AND n.typename       = ?   -- Master childs (Documents or Contacts)
-        AND corp.ngrams_type = ?   -- both type of ngrams (Authors or Terms?)
-        AND nn.node1_id      = ?   -- User CorpusId or AnnuaireId
-    )
-    
-  SELECT COALESCE(tu.terms,tm.terms) AS terms
-       , COALESCE(tu.n,tm.n)         AS n
-       , COALESCE(tu.list_type,tm.list_type) AS ngrams_type
-       , SUM(COALESCE(tu.weight,tm.weight)) AS weight
-  FROM tableUser tu RIGHT JOIN tableMaster tm ON tu.terms = tm.terms
-  GROUP BY tu.terms,tm.terms,tu.n,tm.n,tu.list_type,tm.list_type
-  ORDER BY 1,2
-  LIMIT ?
-  OFFSET ?;
-
-  |]
-
-type ListIdUser   = NodeId
-type ListIdMaster = NodeId
-
-type MapToChildren = Map Text (Set Text)
-type MapToParent   = Map Text Text
-
-getNgramsGroup :: ListIdUser -> ListIdMaster -> Cmd err (MapToParent, MapToChildren)
-getNgramsGroup lu lm = do
-  groups <- runPGSQuery querySelectNgramsGroup (lu,lm)
-  let mapChildren = fromListWith (<>) $ map (\(a,b) -> (a, DS.singleton b)) groups
-  let mapParent   = fromListWith (<>) $ map (\(a,b) -> (b, a)) groups
-  pure (mapParent, mapChildren)
-
-querySelectNgramsGroup :: PGS.Query
-querySelectNgramsGroup = [sql|
-    WITH groupUser AS (
-      SELECT n1.terms AS t1, n2.terms AS t2 FROM nodes_ngrams_ngrams nnn
-        JOIN ngrams n1 ON n1.id = nnn.ngram1_id
-        JOIN ngrams n2 ON n2.id = nnn.ngram2_id
-        WHERE
-        nnn.node_id = ? -- User listId
-      ),
-      groupMaster AS (
-      SELECT n1.terms AS t1, n2.terms AS t2 FROM nodes_ngrams_ngrams nnn
-        JOIN ngrams n1 ON n1.id = nnn.ngram1_id
-        JOIN ngrams n2 ON n2.id = nnn.ngram2_id
-        WHERE
-        nnn.node_id = ? -- Master listId
-      )
-    SELECT COALESCE(gu.t1,gm.t1) AS ngram1_id
-         , COALESCE(gu.t2,gm.t2) AS ngram2_id
-      FROM groupUser gu LEFT JOIN groupMaster gm ON gu.t1 = gm.t1
-  |]
+indexNgrams :: HashMap Text NgramsId -> Ngrams -> Indexed Int Ngrams
+indexNgrams = indexNgramsWith . withMap
 
+indexNgramsWith :: (Text -> NgramsId) -> Ngrams -> Indexed Int Ngrams
+indexNgramsWith f n = Indexed (f $ _ngramsTerms n) n