Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev
[gargantext.git] / src / Gargantext / Database / Schema / Ngrams.hs
index 96000518beae77c1b12e0e93f69e5e08f50c2c60..0364a18580f9f5d60817fa9d074016dd4daf9fe1 100644 (file)
@@ -11,31 +11,37 @@ Ngrams connection to the Database.
 
 -}
 
-{-# LANGUAGE Arrows                     #-}
-{-# LANGUAGE FunctionalDependencies     #-}
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Schema.Ngrams
   where
 
-import Data.HashMap.Strict (HashMap)
-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.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 Servant (FromHttpApiData(..), Proxy(..), ToHttpApiData(..))
+import Test.QuickCheck (elements)
 import Text.Read (read)
-import Gargantext.Database.Types
-import Gargantext.Database.Schema.Prelude
-import qualified Database.PostgreSQL.Simple as PGS
+import qualified Data.ByteString.Char8 as B
 import qualified Data.HashMap.Strict as HashMap
+import qualified Database.PostgreSQL.Simple as PGS
 
 
 type NgramsId  = Int
@@ -46,17 +52,17 @@ data NgramsPoly id terms n = NgramsDB { _ngrams_id    :: !id
                                       , _ngrams_n     :: !n
                                       } deriving (Show)
 
-type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
-                                   (Column PGText)
-                                   (Column PGInt4)
+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
 
@@ -81,6 +87,52 @@ data NgramsType = Authors | Institutes | Sources | NgramsTerms
   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..]
@@ -92,41 +144,21 @@ instance ToSchema NgramsType
 
 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 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 ToHttpApiData NgramsType where
-  toUrlPiece = pack . show
-
-instance ToParamSchema NgramsType where
-  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
-
-
-instance DefaultFromField (Nullable PGInt4) NgramsTypeId
+instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
   where
-    defaultFromField = fieldQueryRunnerColumn
+    defaultFromField = fromPGSFromField
 
-pgNgramsType :: NgramsType -> Column PGInt4
+pgNgramsType :: NgramsType -> Column SqlInt4
 pgNgramsType = pgNgramsTypeId . ngramsTypeId
 
-pgNgramsTypeId :: NgramsTypeId -> Column PGInt4
+pgNgramsTypeId :: NgramsTypeId -> Column SqlInt4
 pgNgramsTypeId (NgramsTypeId n) = sqlInt4 n
 
 ngramsTypeId :: NgramsType -> NgramsTypeId
@@ -141,6 +173,16 @@ fromNgramsTypeId id = lookup id
                                | nt <- [minBound .. maxBound] :: [NgramsType]
                                ]
 
+unNgramsTypeId :: NgramsTypeId -> Int
+unNgramsTypeId (NgramsTypeId i) = i
+
+toNgramsTypeId :: Int -> NgramsTypeId
+toNgramsTypeId i = NgramsTypeId i
+
+instance HasDBid NgramsType where
+  toDBid   = unNgramsTypeId . ngramsTypeId
+  fromDBid = fromMaybe (panic "NgramsType id not indexed") . fromNgramsTypeId . toNgramsTypeId
+
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | TODO put it in Gargantext.Core.Text.Ngrams
@@ -160,6 +202,9 @@ instance FromField Ngrams where
     x <- fromField fld mdata
     pure $ text2ngrams x
 
+instance PGS.ToRow Text where
+  toRow t = [toField t]
+
 text2ngrams :: Text -> Ngrams
 text2ngrams txt = UnsafeNgrams txt' $ length $ splitOn " " txt'
   where