Merge branch 'dev-tree-reload' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell...
[gargantext.git] / src / Gargantext / Database / Schema / Ngrams.hs
index d9f784774d161834681f27ca94ac7459193353ff..2230cc3925361943cfc0469f8cbdd6e577bf7d38 100644 (file)
@@ -12,38 +12,27 @@ Ngrams connection to the Database.
 -}
 
 {-# LANGUAGE Arrows                     #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE FunctionalDependencies     #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE NoImplicitPrelude      #-}
-{-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE QuasiQuotes            #-}
-{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
-module Gargantext.Database.Schema.Ngrams where
+module Gargantext.Database.Schema.Ngrams
+  where
 
-import Control.Lens (makeLenses, over)
+import Data.Hashable (Hashable)
+import Codec.Serialise (Serialise())
+import Control.Lens (over)
 import Control.Monad (mzero)
 import Data.Aeson
 import Data.Aeson.Types (toJSONKeyText)
-import Data.ByteString.Internal (ByteString)
 import Data.Map (Map, fromList, lookup)
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Text (Text, splitOn, pack)
-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 GHC.Generics (Generic)
-import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, formatPGSQuery)
+import Data.Text (Text, splitOn, pack, strip)
+import Gargantext.Core.Types (TODO(..))
 import Gargantext.Prelude
-import Opaleye hiding (FromField)
-import Prelude (Enum, Bounded, minBound, maxBound, Functor)
+import Prelude (Functor)
+import Servant (FromHttpApiData, parseUrlPiece, Proxy(..))
+import Text.Read (read)
+import Gargantext.Database.Schema.Prelude
 import qualified Database.PostgreSQL.Simple as PGS
 
 
@@ -51,9 +40,9 @@ type NgramsId    = Int
 type NgramsTerms = Text
 type Size        = Int
 
-data NgramsPoly id terms n = NgramsDb { _ngrams_id    :: id
-                                      , _ngrams_terms :: terms
-                                      , _ngrams_n     :: n
+data NgramsPoly id terms n = NgramsDB { _ngrams_id    :: !id
+                                      , _ngrams_terms :: !terms
+                                      , _ngrams_n     :: !n
                                       } deriving (Show)
 
 type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
@@ -68,24 +57,20 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
                                  (Column (Nullable PGText))
                                  (Column (Nullable PGInt4))
 
-type NgramsDb = NgramsPoly Int Text Int
+type NgramsDB = NgramsPoly Int Text Int
 
 $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
 makeLenses ''NgramsPoly
 
 
 ngramsTable :: Table NgramsWrite NgramsRead
-ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { _ngrams_id    = optional "id"
+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
 
 -- | Main Ngrams Types
 -- | Typed Ngrams
@@ -94,14 +79,18 @@ dbGetNgramsDb = runOpaQuery queryNgramsTable
 -- ngrams in authors field of document has Authors Type
 -- ngrams in text (title or abstract) of documents has Terms Type
 data NgramsType = Authors | Institutes | Sources | NgramsTerms
-  deriving (Eq, Show, Ord, Enum, Bounded, Generic)
+  deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
 
-instance FromJSON NgramsType
-instance FromJSONKey NgramsType where
-   fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
-instance ToJSON NgramsType
-instance ToJSONKey NgramsType where
-   toJSONKey = toJSONKeyText (pack . show)
+instance Serialise NgramsType
+instance Hashable  NgramsType
+
+ngramsTypes :: [NgramsType]
+ngramsTypes = [minBound..]
+
+instance ToSchema NgramsType
+{-  where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
+--}
 
 newtype NgramsTypeId = NgramsTypeId Int
   deriving (Eq, Show, Ord, Num)
@@ -115,6 +104,20 @@ instance FromField NgramsTypeId where
     if (n :: Int) > 0 then return $ NgramsTypeId n
                       else mzero
 
+instance FromJSON NgramsType
+instance FromJSONKey NgramsType where
+   fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
+instance ToJSON NgramsType
+instance ToJSONKey NgramsType where
+   toJSONKey = toJSONKeyText (pack . show)
+
+instance FromHttpApiData NgramsType where
+  parseUrlPiece n = pure $ (read . cs) n
+
+instance ToParamSchema NgramsType where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+
+
 instance QueryRunnerColumnDefault (Nullable PGInt4) NgramsTypeId
   where
     queryRunnerColumnDefault = fieldQueryRunnerColumn
@@ -132,23 +135,29 @@ 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]
+                               ]
 
 ------------------------------------------------------------------------
--- | 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)
 
 makeLenses ''Ngrams
 instance PGS.ToRow Ngrams where
-  toRow (Ngrams t s) = [toField t, toField s]
+  toRow (UnsafeNgrams t s) = [toField t, toField s]
 
 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
@@ -194,39 +203,6 @@ indexNgramsTWith = fmap . indexNgramsWith
 indexNgramsWith :: (NgramsTerms -> NgramsId) -> Ngrams -> NgramsIndexed
 indexNgramsWith f n = NgramsIndexed n (f $ _ngramsTerms n)
 
--- TODO-ACCESS: access must not be checked here but when insertNgrams is called.
-insertNgrams :: [Ngrams] -> Cmd err (Map NgramsTerms NgramsId)
-insertNgrams ns = fromList <$> map (\(NgramIds i t) -> (t, i)) <$> (insertNgrams' ns)
-
--- TODO-ACCESS: access must not be checked here but when insertNgrams' is called.
-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
-           |]