Skip to content

haskell-gargantext
haskell-gargantext
Commit 84a3f5e3 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli Committed by Alfredo Di Napoli
Browse files
Options

Fix compilation errors due to switch to GHC 9.4.7

parent 0d442496
Hide whitespace changes
Inline Side-by-side
Showing with 455 additions and 368 deletions
cabal.project.freeze
View file @ 84a3f5e3
......@@ -1704,15 +1704,15 @@ constraints: any.AC-Angle ==1.0,
any.monoid-transformer ==0.0.4,
any.monoidal-containers ==0.6.4.0,
any.more-containers ==0.2.2.2,
any.morpheus-graphql ==0.27.3,
any.morpheus-graphql-app ==0.27.3,
any.morpheus-graphql-client ==0.27.3,
any.morpheus-graphql-code-gen ==0.27.3,
any.morpheus-graphql-code-gen-utils ==0.27.3,
any.morpheus-graphql-core ==0.27.3,
any.morpheus-graphql-server ==0.27.3,
any.morpheus-graphql-subscriptions ==0.27.3,
any.morpheus-graphql-tests ==0.27.3,
any.morpheus-graphql ==0.24.3,
any.morpheus-graphql-app ==0.24.3,
any.morpheus-graphql-client ==0.24.3,
any.morpheus-graphql-code-gen ==0.24.3,
any.morpheus-graphql-code-gen-utils ==0.24.3,
any.morpheus-graphql-core ==0.24.3,
any.morpheus-graphql-server ==0.24.3,
any.morpheus-graphql-subscriptions ==0.24.3,
any.morpheus-graphql-tests ==0.24.3,
any.moss ==0.2.0.1,
any.mountpoints ==1.0.2,
any.mpi-hs ==0.7.2.0,
......
gargantext.cabal
View file @ 84a3f5e3
......@@ -45,6 +45,10 @@ flag test-crypto
default: False
manual: True
flag disable-db-obfuscation-executable
default: False
manual: True
library
exposed-modules:
Gargantext
......@@ -165,6 +169,7 @@ library
Gargantext.Utils.Jobs.Settings
Gargantext.Utils.Jobs.State
Gargantext.Utils.SpacyNLP
Gargantext.Utils.SpacyNLP.Types
Gargantext.Utils.Tuple
Gargantext.Utils.Zip
other-modules:
......@@ -491,10 +496,11 @@ library
, matrix ^>= 0.3.6.1
, monad-control ^>= 1.0.3.1
, monad-logger ^>= 0.3.36
, morpheus-graphql ^>= 0.17.0
, morpheus-graphql-app ^>= 0.17.0
, morpheus-graphql-core ^>= 0.17.0
, morpheus-graphql-subscriptions ^>= 0.17.0
, morpheus-graphql >= 0.17.0 && < 0.25
, morpheus-graphql-app >= 0.17.0 && < 0.25
, morpheus-graphql-core >= 0.17.0 && < 0.25
, morpheus-graphql-server >= 0.17.0 && < 0.25
, morpheus-graphql-subscriptions >= 0.17.0 && < 0.25
, mtl ^>= 2.2.2
, natural-transformation ^>= 0.4
, network-uri ^>= 2.6.4.1
......@@ -547,6 +553,7 @@ library
, servant-xml-conduit >= 0.1.0.4
, simple-reflect ^>= 0.3.3
, singletons ^>= 2.7
, singletons-th >= 3.1
, split ^>= 0.2.3.4
, stemmer ^>= 0.5.2
, stm ^>= 2.5.0.1
......@@ -714,15 +721,18 @@ executable gargantext-db-obfuscation
RecordWildCards
StrictData
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -Wmissing-signatures
build-depends:
base
, extra
, gargantext
, gargantext-prelude
, optparse-simple
, postgresql-simple ^>= 0.6.4
, text
default-language: Haskell2010
if flag(disable-db-obfuscation-executable)
buildable: False
else
build-depends:
base
, extra
, gargantext
, gargantext-prelude
, optparse-simple
, postgresql-simple ^>= 0.6.4
, text
default-language: Haskell2010
executable gargantext-import
main-is: Main.hs
......
src/Gargantext/API/Admin/Auth/Types.hs
View file @ 84a3f5e3
......@@ -52,16 +52,11 @@ data AuthenticatedUser = AuthenticatedUser
, _auth_user_id :: UserId
} deriving (Generic)
$(deriveJSON (JSON.defaultOptions { JSON.fieldLabelModifier = tail . dropWhile ((/=) '_') . tail }) ''AuthenticatedUser)
makeLenses ''AuthenticatedUser
instance ToSchema AuthenticatedUser where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
instance ToJWT AuthenticatedUser
instance FromJWT AuthenticatedUser
data AuthenticationError
= LoginFailed NodeId UserId Jose.Error
| InvalidUsernameOrPassword
......@@ -71,7 +66,6 @@ data AuthenticationError
type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
-- | Instances
$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
instance ToSchema AuthRequest where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
......@@ -81,7 +75,6 @@ instance Arbitrary AuthRequest where
, p <- arbitraryPassword
]
$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
instance ToSchema AuthResponse where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
instance Arbitrary AuthResponse where
......@@ -101,20 +94,43 @@ type Password = Text
data ForgotPasswordRequest = ForgotPasswordRequest { _fpReq_email :: Email }
deriving (Generic )
$(deriveJSON (unPrefix "_fpReq_") ''ForgotPasswordRequest)
instance ToSchema ForgotPasswordRequest where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpReq_")
data ForgotPasswordResponse = ForgotPasswordResponse { _fpRes_status :: Text }
deriving (Generic )
$(deriveJSON (unPrefix "_fpRes_") ''ForgotPasswordResponse)
instance ToSchema ForgotPasswordResponse where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpRes_")
data ForgotPasswordGet = ForgotPasswordGet {_fpGet_password :: Password}
deriving (Generic )
$(deriveJSON (unPrefix "_fpGet_") ''ForgotPasswordGet)
instance ToSchema ForgotPasswordGet where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpGet_")
--
-- Lenses
--
makeLenses ''AuthValid
>>>>>>> b7657056 (Fix compilation errors due to switch to GHC 9.4.7)
makeLenses ''AuthResponse
--
-- JSON instances
--
$(deriveJSON (JSON.defaultOptions { JSON.fieldLabelModifier = tail . dropWhile ((/=) '_') . tail }) ''AuthenticatedUser)
$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
$(deriveJSON (unPrefix "_fpReq_") ''ForgotPasswordRequest)
$(deriveJSON (unPrefix "_fpRes_") ''ForgotPasswordResponse)
$(deriveJSON (unPrefix "_fpGet_") ''ForgotPasswordGet)
--
-- JWT instances
--
instance ToJWT AuthenticatedUser
instance FromJWT AuthenticatedUser
src/Gargantext/API/Admin/Settings.hs
View file @ 84a3f5e3
......@@ -24,7 +24,8 @@ import Control.Lens
import Control.Monad.Logger (LogLevel(..))
import Control.Monad.Reader
import Data.ByteString.Lazy qualified as L
import Data.Pool (Pool, createPool)
import Data.Pool (Pool)
import qualified Data.Pool as Pool
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types
......@@ -217,7 +218,7 @@ newEnv logger port file = do
}
newPool :: ConnectInfo -> IO (Pool Connection)
newPool param = createPool (connect param) close 1 (60*60) 8
newPool param = Pool.newPool $ Pool.setNumStripes (Just 1) $ Pool.defaultPoolConfig (connect param) close (60*60) 8
{-
cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
......
src/Gargantext/API/Count.hs
View file @ 84a3f5e3
......@@ -104,18 +104,12 @@ messages = toMessage $ [ (400, ["Ill formed query "])
instance Arbitrary Message where
arbitrary = elements messages
instance FromJSON Message
instance ToJSON Message
instance ToSchema Message
-----------------------------------------------------------------------
data Counts = Counts { results :: [Either Message Count]
} deriving (Eq, Show, Generic)
instance FromJSON Counts
instance ToJSON Counts
instance Arbitrary Counts where
arbitrary = elements [Counts [ Right (Count Pubmed (Just 20 ))
, Right (Count IsTex (Just 150))
......@@ -131,8 +125,6 @@ data Count = Count { count_name :: Scraper
}
deriving (Eq, Show, Generic)
$(deriveJSON (unPrefix "count_") ''Count)
instance ToSchema Count where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
--instance Arbitrary Count where
......@@ -141,3 +133,16 @@ instance ToSchema Count where
-----------------------------------------------------------------------
count :: Monad m => Query -> m Counts
count _ = undefined
--
-- JSON instances
--
instance FromJSON Message
instance ToJSON Message
$(deriveJSON (unPrefix "count_") ''Count)
instance FromJSON Counts
instance ToJSON Counts
src/Gargantext/API/Errors/Types.hs
View file @ 84a3f5e3
......@@ -671,8 +671,8 @@ genFrontendErr be = do
EC_404__tree_empty_root
-> pure $ mkFrontendErr' txt $ FE_tree_empty_root
EC_500__tree_too_many_roots
-> do nodes <- arbitrary
pure $ mkFrontendErr' txt $ FE_tree_too_many_roots nodes
-> do nodes <- getNonEmpty <$> arbitrary
pure $ mkFrontendErr' txt $ FE_tree_too_many_roots (NE.fromList nodes)
-- job errors
EC_500__job_invalid_id_type
......
src/Gargantext/API/GraphQL.hs
View file @ 84a3f5e3
......@@ -22,7 +22,7 @@ import Data.ByteString.Lazy.Char8 ( ByteString )
import Data.Morpheus ( App, deriveApp )
import Data.Morpheus.Server ( httpPlayground )
import Data.Morpheus.Subscriptions ( Event (..), httpPubApp )
import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined(..) )
import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined, defaultRootResolver)
import Data.Proxy
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
......@@ -111,7 +111,7 @@ rootResolver
-> AccessPolicyManager
-> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
rootResolver authenticatedUser policyManager =
RootResolver
defaultRootResolver
{ queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
, context_ngrams = GQLCTX.resolveContextNgrams
, contexts = GQLCTX.resolveNodeContext
......@@ -133,7 +133,7 @@ rootResolver authenticatedUser policyManager =
, update_user_epo_api_token = GQLUser.updateUserEPOAPIToken
, delete_team_membership = GQLTeam.deleteTeamMembership
, update_node_context_category = GQLCTX.updateNodeContextCategory }
, subscriptionResolver = Undefined }
}
-- | Main GraphQL "app".
app
......
src/Gargantext/API/GraphQL/Node.hs
View file @ 84a3f5e3
......@@ -15,7 +15,7 @@ Portability : POSIX
module Gargantext.API.GraphQL.Node where
import Data.Aeson
import Data.HashMap.Strict qualified as HashMap
import Data.Aeson.KeyMap qualified as KM
import Data.Morpheus.Types ( GQLType )
import Data.Text qualified as T
import Gargantext.API.Admin.Auth.Types
......@@ -126,7 +126,7 @@ toCorpus N.Node { .. } = Corpus { id = NN.unNodeId _node_id
pubmedAPIKeyFromValue :: Value -> Maybe PUBMED.APIKey
pubmedAPIKeyFromValue (Object kv) =
case HashMap.lookup "pubmed_api_key" kv of
case KM.lookup "pubmed_api_key" kv of
Nothing -> Nothing
Just v -> case fromJSON v of
Error _ -> Nothing
......
src/Gargantext/API/GraphQL/Utils.hs
View file @ 84a3f5e3
......@@ -8,6 +8,8 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(adn) GraphQL will need updating.
module Gargantext.API.GraphQL.Utils where
import Control.Lens.Getter (view)
......
src/Gargantext/API/Ngrams.hs
View file @ 84a3f5e3
......@@ -120,7 +120,7 @@ import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
import Gargantext.Prelude hiding (log, to, toLower, (%))
import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
import Gargantext.Prelude.Clock (hasTime, getTime)
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import GHC.Conc (readTVar, writeTVar)
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ 84a3f5e3
......@@ -9,7 +9,8 @@ Portability : POSIX
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Ngrams.Tools
where
......
src/Gargantext/API/Ngrams/Types.hs
View file @ 84a3f5e3
......@@ -84,8 +84,6 @@ instance ToParamSchema TabType
instance ToJSON TabType
instance FromJSON TabType
instance ToSchema TabType
instance Arbitrary TabType where
arbitrary = elements [minBound .. maxBound]
instance FromJSONKey TabType where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSONKey TabType where
......@@ -161,14 +159,11 @@ deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
makeLenses ''NgramsRepoElement
instance ToSchema NgramsRepoElement where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
instance Serialise NgramsRepoElement
instance FromField NgramsRepoElement where
fromField = fromJSONField
instance ToField NgramsRepoElement where
toField = toJSONField
instance Serialise (MSet NgramsTerm)
data NgramsElement =
NgramsElement { _ne_ngrams :: NgramsTerm
, _ne_size :: Int
......@@ -197,9 +192,6 @@ newNgramsElement mayList ngrams =
instance ToSchema NgramsElement where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
instance Arbitrary NgramsElement where
arbitrary = elements [newNgramsElement Nothing "sport"]
------------------------------------------------------------------------
newtype NgramsTable = NgramsTable [NgramsElement]
......@@ -257,9 +249,6 @@ mockTable = NgramsTable
where
rp n = Just $ RootParent n n
instance Arbitrary NgramsTable where
arbitrary = pure mockTable
instance ToSchema NgramsTable
------------------------------------------------------------------------
......@@ -283,10 +272,6 @@ instance ToParamSchema OrderBy
instance FromJSON OrderBy
instance ToJSON OrderBy
instance ToSchema OrderBy
instance Arbitrary OrderBy
where
arbitrary = elements [minBound..maxBound]
-- | A query on a 'NgramsTable'.
data NgramsSearchQuery = NgramsSearchQuery
......@@ -367,8 +352,6 @@ instance ToSchema a => ToSchema (PatchSet a)
type AddRem = Replace (Maybe ())
instance Serialise AddRem
remPatch, addPatch :: AddRem
remPatch = replace (Just ()) Nothing
addPatch = replace Nothing (Just ())
......@@ -388,9 +371,6 @@ unPatchMSet (PatchMSet a) = a
type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
instance (Serialise a, Ord a) => Serialise (PatchMSet a)
-- TODO this breaks module abstraction
makePrisms ''PM.PatchMap
......@@ -419,19 +399,12 @@ instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
parseJSON = fmap (_PatchMSetIso #) . parseJSON
instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
instance ToSchema a => ToSchema (PatchMSet a) where
-- TODO
declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
type instance Patched (PatchMSet a) = MSet a
instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
arbitrary = uncurry replace <$> arbitrary
-- If they happen to be equal then the patch is Keep.
instance ToSchema a => ToSchema (Replace a) where
declareNamedSchema (_ :: Proxy (Replace a)) = do
-- TODO Keep constructor is not supported here.
......@@ -475,19 +448,11 @@ instance ToSchema NgramsPatch where
, ("old", nreSch)
, ("new", nreSch)
]
instance Arbitrary NgramsPatch where
arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
, (1, NgramsReplace <$> arbitrary <*> arbitrary)
]
instance Serialise NgramsPatch
instance FromField NgramsPatch where
fromField = fromJSONField
instance ToField NgramsPatch where
toField = toJSONField
instance Serialise (Replace ListType)
instance Serialise ListType
type NgramsPatchIso =
MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
......@@ -555,9 +520,6 @@ newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
instance Serialise NgramsTablePatch
instance Serialise (PatchMap NgramsTerm NgramsPatch)
instance FromField NgramsTablePatch
where
fromField = fromJSONField
......@@ -690,9 +652,6 @@ instance Action NgramsTablePatch (Maybe NgramsTableMap) where
fmap (execState (reParentNgramsTablePatch p)) .
act (p ^. _NgramsTablePatch)
instance Arbitrary NgramsTablePatch where
arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
-- Should it be less than an Lens' to preserve PatchMap's abstraction.
-- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
-- ntp_ngrams_patches = _NgramsTablePatch . undefined
......@@ -709,8 +668,6 @@ deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned
instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
declareNamedSchema = wellNamedSchema "_v_"
instance Arbitrary a => Arbitrary (Versioned a) where
arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
------------------------------------------------------------------------
type Count = Int
......@@ -724,8 +681,6 @@ deriveJSON (unPrefix "_vc_") ''VersionedWithCount
makeLenses ''VersionedWithCount
instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
declareNamedSchema = wellNamedSchema "_vc_"
instance Arbitrary a => Arbitrary (VersionedWithCount a) where
arbitrary = VersionedWithCount 1 1 <$> arbitrary -- TODO 1 is constant so far
toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
......@@ -749,8 +704,6 @@ instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
toJSON = genericToJSON $ unPrefix "_r_"
toEncoding = genericToEncoding $ unPrefix "_r_"
instance (Serialise s, Serialise p) => Serialise (Repo s p)
makeLenses ''Repo
initRepo :: Monoid s => Repo s p
......@@ -771,11 +724,6 @@ type RepoCmdM env err m =
-- Instances
instance Arbitrary NgramsRepoElement where
arbitrary = elements $ map ngramsElementToRepo ns
where
NgramsTable ns = mockTable
instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
where
parseUrlPiece x = maybeToEither x (decode $ cs x)
......@@ -814,3 +762,51 @@ instance ToSchema UpdateTableNgramsCharts where
------------------------------------------------------------------------
type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
--
-- Serialise instances
--
instance Serialise ListType
instance Serialise NgramsRepoElement
instance Serialise NgramsTablePatch
instance Serialise (PatchMap NgramsTerm NgramsPatch)
instance Serialise (MSet NgramsTerm)
instance Serialise AddRem
instance Serialise NgramsPatch
instance Serialise (Replace ListType)
instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
instance (Serialise a, Ord a) => Serialise (PatchMSet a)
instance (Serialise s, Serialise p) => Serialise (Repo s p)
--
-- Arbitrary instances
--
instance Arbitrary TabType where
arbitrary = elements [minBound .. maxBound]
instance Arbitrary NgramsElement where
arbitrary = elements [newNgramsElement Nothing "sport"]
instance Arbitrary NgramsTable where
arbitrary = pure mockTable
instance Arbitrary OrderBy
where
arbitrary = elements [minBound..maxBound]
instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
arbitrary = uncurry replace <$> arbitrary
-- If they happen to be equal then the patch is Keep.
instance Arbitrary NgramsPatch where
arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
, (1, NgramsReplace <$> arbitrary <*> arbitrary)
]
instance Arbitrary NgramsTablePatch where
arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
instance Arbitrary a => Arbitrary (Versioned a) where
arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
instance Arbitrary a => Arbitrary (VersionedWithCount a) where
arbitrary = VersionedWithCount 1 1 <$> arbitrary -- TODO 1 is constant so far
instance Arbitrary NgramsRepoElement where
arbitrary = elements $ map ngramsElementToRepo ns
where
NgramsTable ns = mockTable
src/Gargantext/API/Node.hs
View file @ 84a3f5e3
......@@ -189,62 +189,6 @@ nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uI
nodeNodeAPI' :: GargServer (NodeNodeAPI a)
nodeNodeAPI' = getNodeWith nId p
------------------------------------------------------------------------
-- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
nodeAPI :: forall proxy a.
( HyperdataC a, Show a
) => proxy a
-> AuthenticatedUser
-> NodeId
-> ServerT (NodeAPI a) (GargM Env BackendInternalError)
nodeAPI p authenticatedUser targetNode =
withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode targetNode) nodeAPI'
where
userRootId = RootId $ authenticatedUser ^. auth_node_id
nodeAPI' :: ServerT (NodeAPI a) (GargM Env BackendInternalError)
nodeAPI' = withPolicy authenticatedUser (nodeChecks targetNode) (getNodeWith targetNode p)
:<|> rename targetNode
:<|> postNode authenticatedUser targetNode
:<|> postNodeAsyncAPI authenticatedUser targetNode
:<|> FrameCalcUpload.api authenticatedUser targetNode
:<|> putNode targetNode
:<|> Update.api targetNode
:<|> Action.deleteNode userRootId targetNode
:<|> getChildren targetNode p
-- TODO gather it
:<|> tableApi targetNode
:<|> apiNgramsTableCorpus targetNode
:<|> catApi targetNode
:<|> scoreApi targetNode
:<|> Search.api targetNode
:<|> Share.api userRootId targetNode
-- Pairing Tools
:<|> pairWith targetNode
:<|> pairs targetNode
:<|> getPair targetNode
-- VIZ
:<|> scatterApi targetNode
:<|> chartApi targetNode
:<|> pieApi targetNode
:<|> treeApi targetNode
:<|> phyloAPI targetNode
:<|> moveNode userRootId targetNode
-- :<|> nodeAddAPI id'
-- :<|> postUpload id'
:<|> Share.unPublish targetNode
:<|> fileApi targetNode
:<|> fileAsyncApi authenticatedUser targetNode
:<|> DFWN.api authenticatedUser targetNode
:<|> DocumentUpload.api targetNode
------------------------------------------------------------------------
data RenameNode = RenameNode { r_name :: Text }
deriving (Generic)
......@@ -374,5 +318,59 @@ instance ToSchema RenameNode
instance Arbitrary RenameNode where
arbitrary = elements [RenameNode "test"]
------------------------------------------------------------------------
-- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
nodeAPI :: forall proxy a.
( HyperdataC a, Show a, MimeUnrender JSON a
) => proxy a
-> AuthenticatedUser
-> NodeId
-> ServerT (NodeAPI a) (GargM Env BackendInternalError)
nodeAPI p authenticatedUser targetNode =
withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode targetNode) nodeAPI'
where
userRootId = RootId $ authenticatedUser ^. auth_node_id
nodeAPI' :: ServerT (NodeAPI a) (GargM Env BackendInternalError)
nodeAPI' = withPolicy authenticatedUser (nodeChecks targetNode) (getNodeWith targetNode p)
:<|> rename targetNode
:<|> postNode authenticatedUser targetNode
:<|> postNodeAsyncAPI authenticatedUser targetNode
:<|> FrameCalcUpload.api authenticatedUser targetNode
:<|> putNode targetNode
:<|> Update.api targetNode
:<|> Action.deleteNode userRootId targetNode
:<|> getChildren targetNode p
-- TODO gather it
:<|> tableApi targetNode
:<|> apiNgramsTableCorpus targetNode
:<|> catApi targetNode
:<|> scoreApi targetNode
:<|> Search.api targetNode
:<|> Share.api userRootId targetNode
-- Pairing Tools
:<|> pairWith targetNode
:<|> pairs targetNode
:<|> getPair targetNode
-- VIZ
:<|> scatterApi targetNode
:<|> chartApi targetNode
:<|> pieApi targetNode
:<|> treeApi targetNode
:<|> phyloAPI targetNode
:<|> moveNode userRootId targetNode
-- :<|> nodeAddAPI id'
-- :<|> postUpload id'
:<|> Share.unPublish targetNode
:<|> fileApi targetNode
:<|> fileAsyncApi authenticatedUser targetNode
:<|> DFWN.api authenticatedUser targetNode
:<|> DocumentUpload.api targetNode
-------------------------------------------------------------
src/Gargantext/API/Node/Document/Export/Types.hs
View file @ 84a3f5e3
......@@ -94,6 +94,6 @@ type API = Summary "Document Export"
:<|> "csv"
:> Get '[PlainText] (Headers '[Servant.Header "Content-Disposition" Text] Text)) -- [Document])
$(deriveJSON (unPrefix "_de_") ''DocumentExport)
$(deriveJSON (unPrefix "_d_") ''Document)
$(deriveJSON (unPrefix "_ng_") ''Ngrams)
$(deriveJSON (unPrefix "_d_") ''Document)
$(deriveJSON (unPrefix "_de_") ''DocumentExport)
src/Gargantext/Core/NodeStory.hs
View file @ 84a3f5e3
......@@ -701,7 +701,7 @@ clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHi
currentVersion :: (HasNodeStory env err m) => ListId -> m Version
currentVersion listId = do
pool <- view connPool
nls <- withResource pool $ \c -> liftBase $ getNodeStory c listId
nls <- liftBase $ withResource pool $ \c -> liftBase $ getNodeStory c listId
pure $ nls ^. unNodeStory . at listId . _Just . a_version
......@@ -711,7 +711,7 @@ currentVersion listId = do
fixNodeStoryVersions :: (HasNodeStory env err m) => m ()
fixNodeStoryVersions = do
pool <- view connPool
_ <- withResource pool $ \c -> liftBase $ PGS.withTransaction c $ do
_ <- liftBase $ withResource pool $ \c -> liftBase $ PGS.withTransaction c $ do
nIds <- runPGSQuery c [sql| SELECT id FROM nodes WHERE ? |] (PGS.Only True) :: IO [PGS.Only Int64]
-- printDebug "[fixNodeStoryVersions] nIds" nIds
mapM_ (\(PGS.Only nId) -> do
......
src/Gargantext/Core/Text/Corpus/Parsers/Date.hs
View file @ 84a3f5e3
......@@ -24,7 +24,7 @@ module Gargantext.Core.Text.Corpus.Parsers.Date
import Data.Aeson (toJSON, Value)
import Data.Aeson qualified as Json
import Data.HashMap.Strict as HM hiding (map)
import Data.Aeson.KeyMap as KM hiding (map)
import Data.HashSet qualified as HashSet
import Data.List qualified as List
import Data.Text (unpack, splitOn, replace)
......@@ -184,7 +184,7 @@ getTimeValue rt = case head rt of
extractValue :: Maybe Value -> Maybe Text
extractValue (Just (Json.Object object)) =
case HM.lookup "value" object of
case KM.lookup "value" object of
Just (Json.String date) -> Just date
_ -> Nothing
extractValue _ = Nothing
......
src/Gargantext/Core/Text/Terms/Eleve.hs
View file @ 84a3f5e3
......@@ -34,10 +34,11 @@ Notes for current implementation:
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.Text.Terms.Eleve where
......
src/Gargantext/Core/Text/Terms/Mono/Token/En.hs
View file @ 84a3f5e3
......@@ -143,11 +143,11 @@ whitespace :: Tokenizer
whitespace xs = E [Right w | w <- T.words xs ]
instance Monad (EitherList a) where
return x = E [Right x]
return = pure
E xs >>= f = E $ concatMap (either (return . Left) (unE . f)) xs
instance Applicative (EitherList a) where
pure = pure
pure x = E [Right x]
f <*> x = f `ap` x
instance Functor (EitherList a) where
......
src/Gargantext/Core/Types/Phylo.hs
View file @ 84a3f5e3
......@@ -216,43 +216,6 @@ data ObjectData =
| Layer !GvId !GraphDataData !LayerData
deriving (Show, Eq, Generic)
instance ToJSON ObjectData where
toJSON = \case
GroupToNode gvid commonData nodeTypeData
-> mkObject gvid (Left commonData) nodeTypeData
BranchToNode gvid commonData nodeTypeData
-> mkObject gvid (Left commonData) nodeTypeData
PeriodToNode gvid commonData nodeTypeData
-> mkObject gvid (Left commonData) nodeTypeData
Layer gvid graphData nodeTypeData
-> mkObject gvid (Right graphData) nodeTypeData
instance FromJSON ObjectData where
parseJSON = withObject "ObjectData" $ \o -> do
_gvid <- o .: "_gvid"
-- try to parse the graph data first. If we succeed, then we are dealing with
-- the 'Layer', otherwise we the rest, but for the rest we can avoid re-parsing
-- the 'NodeCommonData' every time.
case parseMaybe @_ @GraphDataData parseJSON (Object o) of
Nothing
-> do commonData <- parseJSON (Object o)
((GroupToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
(BranchToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
(PeriodToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)))
Just gd
-> Layer <$> pure _gvid <*> pure gd <*> parseJSON (Object o)
mkObject :: ToJSON a => GvId -> Either NodeCommonData GraphDataData -> a -> Value
mkObject gvid commonData objectTypeData =
let commonDataJSON = either toJSON toJSON commonData
objectTypeDataJSON = toJSON objectTypeData
header = object $ [ "_gvid" .= toJSON gvid ]
in case (commonDataJSON, objectTypeDataJSON, header) of
(Object hdr, Object cdJSON, Object etDataJSON)
-> Object $ hdr <> cdJSON <> etDataJSON
_ -> panicTrace "[Gargantext.Core.Types.Phylo.mkObject] impossible: commonData, header or objectTypeDataJSON didn't convert back to JSON Object."
data GroupToNodeData
= GroupToNodeData
{ _gtn_bId :: Text
......@@ -474,17 +437,23 @@ data BranchToGroupData
, _btg_style :: Maybe Text
} deriving (Show, Eq, Generic)
-- | Lenses
makeLenses ''Phylo
makeLenses ''PhyloPeriod
makeLenses ''PhyloLevel
makeLenses ''PhyloGroup
-- | JSON instances
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
$(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_Level" ) ''PhyloLevel )
$(deriveJSON (unPrefix "_phylo_Group" ) ''PhyloGroup )
instance ToJSON GvId where
toJSON GvId{..} = toJSON _GvId
instance FromJSON GvId where
parseJSON v = GvId <$> parseJSON v
-- /NOTE/ We need to define /after/ the JSON istance for 'GvId' due to GHC stage limitation.
mkObject :: ToJSON a => GvId -> Either NodeCommonData GraphDataData -> a -> Value
mkObject gvid commonData objectTypeData =
let commonDataJSON = either toJSON toJSON commonData
objectTypeDataJSON = toJSON objectTypeData
header = object $ [ "_gvid" .= toJSON gvid ]
in case (commonDataJSON, objectTypeDataJSON, header) of
(Object hdr, Object cdJSON, Object etDataJSON)
-> Object $ hdr <> cdJSON <> etDataJSON
_ -> panicTrace "[Gargantext.Core.Types.Phylo.mkObject] impossible: commonData, header or objectTypeDataJSON didn't convert back to JSON Object."
instance ToJSON GraphData where
toJSON = mkGraphData
......@@ -512,11 +481,6 @@ instance FromJSON GraphData where
_gd_data <- parseJSON (Object o)
pure GraphData{..}
instance ToJSON GvId where
toJSON GvId{..} = toJSON _GvId
instance FromJSON GvId where
parseJSON v = GvId <$> parseJSON v
instance ToJSON EdgeData where
toJSON = \case
GroupToAncestor gvid commonData edgeTypeData
......@@ -608,6 +572,38 @@ instance FromJSON BranchToGroupData where
_btg_style <- o .:? "style"
pure BranchToGroupData{..}
instance ToJSON ObjectData where
toJSON = \case
GroupToNode gvid commonData nodeTypeData
-> mkObject gvid (Left commonData) nodeTypeData
BranchToNode gvid commonData nodeTypeData
-> mkObject gvid (Left commonData) nodeTypeData
PeriodToNode gvid commonData nodeTypeData
-> mkObject gvid (Left commonData) nodeTypeData
Layer gvid graphData nodeTypeData
-> mkObject gvid (Right graphData) nodeTypeData
instance FromJSON ObjectData where
parseJSON = withObject "ObjectData" $ \o -> do
_gvid <- o .: "_gvid"
-- try to parse the graph data first. If we succeed, then we are dealing with
-- the 'Layer', otherwise we the rest, but for the rest we can avoid re-parsing
-- the 'NodeCommonData' every time.
case parseMaybe @_ @GraphDataData parseJSON (Object o) of
Nothing
-> do commonData <- parseJSON (Object o)
((GroupToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
(BranchToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
(PeriodToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)))
Just gd
-> Layer <$> pure _gvid <*> pure gd <*> parseJSON (Object o)
$(deriveJSON (unPrefix "_phylo_Group" ) ''PhyloGroup )
$(deriveJSON (unPrefix "_phylo_Level" ) ''PhyloLevel )
$(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
-- | ToSchema instances
instance ToSchema Phylo where
......@@ -637,7 +633,9 @@ instance ToSchema GraphDataData where
instance ToSchema GraphData where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gd_")
-- | Arbitrary instances
--
-- Arbitrary instances
--
instance Arbitrary LayerData where
arbitrary = LayerData <$> arbitrary
instance Arbitrary NodeCommonData where
......@@ -723,3 +721,13 @@ instance Arbitrary GraphDataData where
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
--
-- Lenses
--
makeLenses ''Phylo
makeLenses ''PhyloPeriod
makeLenses ''PhyloLevel
makeLenses ''PhyloGroup
src/Gargantext/Core/Viz/LegacyPhylo.hs
View file @ 84a3f5e3
......@@ -475,38 +475,38 @@ makeLenses ''PhyloEdge
------------------------
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
$(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
$(deriveJSON (unPrefix "_phylo_foundations" ) ''PhyloFoundations )
$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
$(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
$(deriveJSON (unPrefix "_phyloFis_" ) ''PhyloFis )
--
$(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam )
$(deriveJSON (unPrefix "_lb_" ) ''LBParams )
$(deriveJSON (unPrefix "_sb_" ) ''SBParams )
--
$(deriveJSON (unPrefix "_fis_" ) ''FisParams )
$(deriveJSON (unPrefix "_hamming_" ) ''HammingParams )
$(deriveJSON (unPrefix "_wlj_" ) ''WLJParams )
--
$(deriveJSON defaultOptions ''Filter )
$(deriveJSON defaultOptions ''Metric )
$(deriveJSON defaultOptions ''Cluster )
$(deriveJSON defaultOptions ''Proximity )
--
$(deriveJSON (unPrefix "_fis_" ) ''FisParams )
$(deriveJSON (unPrefix "_hamming_" ) ''HammingParams )
$(deriveJSON (unPrefix "_louvain_" ) ''LouvainParams )
$(deriveJSON (unPrefix "_rc_" ) ''RCParams )
$(deriveJSON (unPrefix "_wlj_" ) ''WLJParams )
$(deriveJSON defaultOptions ''Cluster )
$(deriveJSON (unPrefix "_q_" ) ''PhyloQueryBuild )
--
$(deriveJSON (unPrefix "_lb_" ) ''LBParams )
$(deriveJSON (unPrefix "_sb_" ) ''SBParams )
$(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam )
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
--
$(deriveJSON (unPrefix "_q_" ) ''PhyloQueryBuild )
$(deriveJSON (unPrefix "_pv_" ) ''PhyloView )
$(deriveJSON (unPrefix "_pb_" ) ''PhyloBranch )
$(deriveJSON (unPrefix "_pe_" ) ''PhyloEdge )
$(deriveJSON (unPrefix "_pn_" ) ''PhyloNode )
$(deriveJSON defaultOptions ''Filiation )
$(deriveJSON (unPrefix "_pn_" ) ''PhyloNode )
$(deriveJSON defaultOptions ''EdgeType )
$(deriveJSON (unPrefix "_pe_" ) ''PhyloEdge )
$(deriveJSON (unPrefix "_pv_" ) ''PhyloView )
---------------------------
-- | Swagger instances | --
......
src/Gargantext/Core/Viz/Phylo.hs
View file @ 84a3f5e3
......@@ -625,9 +625,6 @@ makeLenses ''PhyloBranch
-- | JSON instances | --
------------------------
instance FromJSON Phylo
instance ToJSON Phylo
instance FromJSON PhyloSources
instance ToJSON PhyloSources
......@@ -651,6 +648,9 @@ instance ToJSON PhyloGroup
$(deriveJSON (unPrefix "_foundations_" ) ''PhyloFoundations)
instance FromJSON Phylo
instance ToJSON Phylo
-- NFData instances
instance NFData CorpusParser
......@@ -677,3 +677,4 @@ instance NFData Order
instance NFData Sort
instance NFData Tagger
instance NFData PhyloLabel
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @ 84a3f5e3
......@@ -114,7 +114,7 @@ corpusIdtoDocuments timeUnit corpusId = do
docs <- selectDocNodes corpusId
lId <- defaultList corpusId
termList <- getTermList lId MapTerm NgramsTerms
corpus_node <- getNodeWith corpusId (Proxy @ HyperdataCorpus)
corpus_node <- getNodeWith corpusId (Proxy @HyperdataCorpus)
let corpusLang = view (node_hyperdata . to _hc_lang) corpus_node
let patterns = case termList of
......
src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs
View file @ 84a3f5e3
......@@ -46,7 +46,7 @@ flowPhylo :: (HasNodeStory env err m, HasDBid NodeType)
-> m Phylo
flowPhylo cId = do
corpus_node <- getNodeWith cId (Proxy @ HyperdataCorpus)
corpus_node <- getNodeWith cId (Proxy @HyperdataCorpus)
let lang = withDefaultLanguage $ view (node_hyperdata . to _hc_lang) corpus_node
list' <- defaultList cId
termList <- HashMap.toList <$> getTermsWith (Text.words . unNgramsTerm) [list'] NgramsTerms (Set.singleton MapTerm)
......
src/Gargantext/Database/Action/Flow.hs
View file @ 84a3f5e3
......@@ -659,7 +659,7 @@ reIndexWith :: ( HasNodeStory env err m )
-> m ()
reIndexWith cId lId nt lts = do
-- printDebug "(cId,lId,nt,lts)" (cId, lId, nt, lts)
corpus_node <- getNodeWith cId (Proxy @ HyperdataCorpus)
corpus_node <- getNodeWith cId (Proxy @HyperdataCorpus)
let corpusLang = withDefaultLanguage $ view (node_hyperdata . to _hc_lang) corpus_node
-- Getting [NgramsTerm]
......
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
View file @ 84a3f5e3
......@@ -193,6 +193,20 @@ instance Arbitrary HyperdataContact where
-- | Specific Gargantext instance
instance Hyperdata HyperdataContact
-- | All lenses
makeLenses ''ContactWho
makeLenses ''ContactWhere
makeLenses ''ContactTouch
makeLenses ''ContactMetaData
makeLenses ''HyperdataContact
-- | All Json instances
$(deriveJSON (unPrefix "_ct_") ''ContactTouch)
$(deriveJSON (unPrefix "_cw_") ''ContactWho)
$(deriveJSON (unPrefix "_cw_") ''ContactWhere)
$(deriveJSON (unPrefix "_cm_") ''ContactMetaData)
$(deriveJSON (unPrefix "_hc_") ''HyperdataContact)
-- | Database (Posgresql-simple instance)
instance FromField HyperdataContact where
fromField = fromField'
......@@ -207,16 +221,3 @@ instance DefaultFromField (Nullable SqlJsonb) HyperdataContact where
-- | All lenses
makeLenses ''ContactWho
makeLenses ''ContactWhere
makeLenses ''ContactTouch
makeLenses ''ContactMetaData
makeLenses ''HyperdataContact
-- | All Json instances
$(deriveJSON (unPrefix "_cw_") ''ContactWho)
$(deriveJSON (unPrefix "_cw_") ''ContactWhere)
$(deriveJSON (unPrefix "_ct_") ''ContactTouch)
$(deriveJSON (unPrefix "_cm_") ''ContactMetaData)
$(deriveJSON (unPrefix "_hc_") ''HyperdataContact)
src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
View file @ 84a3f5e3
......@@ -73,8 +73,6 @@ defaultHyperdataDocument = case decode docExample of
data StatusV3 = StatusV3 { statusV3_error :: !(Maybe Text)
, statusV3_action :: !(Maybe Text)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "statusV3_") ''StatusV3)
------------------------------------------------------------------------
data HyperdataDocumentV3 = HyperdataDocumentV3 { _hdv3_publication_day :: !(Maybe Int)
......@@ -140,12 +138,25 @@ arbitraryHyperdataDocuments =
instance Hyperdata HyperdataDocument
instance Hyperdata HyperdataDocumentV3
------------------------------------------------------------------------
$(makeLenses ''HyperdataDocument)
makePrisms ''HyperdataDocument
-- $(deriveJSON (unPrefix "_hd_") ''HyperdataDocument)
instance ToSchema HyperdataDocument where
declareNamedSchema proxy =
genericDeclareNamedSchema (unPrefixSwagger "_hd_") proxy
& mapped.schema.description ?~ "Document Hyperdata"
& mapped.schema.example ?~ toJSON defaultHyperdataDocument
$(makeLenses ''HyperdataDocumentV3)
{-
-- | For now HyperdataDocumentV3 is not exposed with the API
instance ToSchema HyperdataDocumentV3 where
declareNamedSchema proxy =
genericDeclareNamedSchema (unPrefixSwagger "hyperdataDocumentV3_") proxy
& mapped.schema.description ?~ "Document Hyperdata for Garg V3"
& mapped.schema.example ?~ toJSON defaultHyperdataDocumentV3
-}
-- $(deriveJSON (unPrefix "_hd_") ''HyperdataDocument)
--
-- JSON instances
--
instance FromJSON HyperdataDocument
where
......@@ -167,24 +178,13 @@ instance ToJSON HyperdataDocument
$(deriveJSON (unPrefix "statusV3_") ''StatusV3)
$(deriveJSON (unPrefix "_hdv3_") ''HyperdataDocumentV3)
instance ToSchema HyperdataDocument where
declareNamedSchema proxy =
genericDeclareNamedSchema (unPrefixSwagger "_hd_") proxy
& mapped.schema.description ?~ "Document Hyperdata"
& mapped.schema.example ?~ toJSON defaultHyperdataDocument
--
-- FromField/ToField instances
--
{-
-- | For now HyperdataDocumentV3 is not exposed with the API
instance ToSchema HyperdataDocumentV3 where
declareNamedSchema proxy =
genericDeclareNamedSchema (unPrefixSwagger "hyperdataDocumentV3_") proxy
& mapped.schema.description ?~ "Document Hyperdata for Garg V3"
& mapped.schema.example ?~ toJSON defaultHyperdataDocumentV3
-}
------------------------------------------------------------------------
instance FromField HyperdataDocument
where
fromField = fromField'
......@@ -193,14 +193,12 @@ instance FromField HyperdataDocumentV3
where
fromField = fromField'
-------
instance ToField HyperdataDocument where
toField = toJSONField
instance ToField HyperdataDocumentV3 where
toField = toJSONField
------------------------------------------------------------------------
instance DefaultFromField SqlJsonb HyperdataDocument
where
defaultFromField = fromPGSFromField
......@@ -208,4 +206,10 @@ instance DefaultFromField SqlJsonb HyperdataDocument
instance DefaultFromField SqlJsonb HyperdataDocumentV3
where
defaultFromField = fromPGSFromField
------------------------------------------------------------------------
--
-- Lenses
--
$(makeLenses ''HyperdataDocument)
makePrisms ''HyperdataDocument
$(makeLenses ''HyperdataDocumentV3)
src/Gargantext/Database/Admin/Types/Hyperdata/User.hs
View file @ 84a3f5e3
......@@ -98,9 +98,9 @@ makeLenses ''HyperdataPrivate
makeLenses ''HyperdataPublic
-- | All Json instances
$(deriveJSON (unPrefix "_hu_") ''HyperdataUser)
$(deriveJSON (unPrefix "_hpr_") ''HyperdataPrivate)
$(deriveJSON (unPrefix "_hpu_") ''HyperdataPublic)
$(deriveJSON (unPrefix "_hu_") ''HyperdataUser)
-- | Arbitrary instances
instance Arbitrary HyperdataUser where
......
src/Gargantext/Database/Admin/Types/Metrics.hs
View file @ 84a3f5e3
......@@ -41,8 +41,8 @@ instance Arbitrary Metric
<*> arbitrary
<*> arbitrary
deriveJSON (unPrefix "metrics_") ''Metrics
deriveJSON (unPrefix "m_") ''Metric
deriveJSON (unPrefix "metrics_") ''Metrics
newtype ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
......
src/Gargantext/Database/Prelude.hs
View file @ 84a3f5e3
......@@ -119,7 +119,7 @@ fromInt64ToInt = fromIntegral
mkCmd :: (Connection -> IO a) -> DBCmd err a
mkCmd k = do
pool <- view connPool
withResource pool (liftBase . k)
liftBase $ withResource pool (liftBase . k)
runCmd :: (HasConnectionPool env)
=> env
......
src/Gargantext/Database/Query/Facet.hs
View file @ 84a3f5e3
......@@ -15,6 +15,7 @@ Portability : POSIX
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
------------------------------------------------------------------------
module Gargantext.Database.Query.Facet
( runViewAuthorsDoc
......
src/Gargantext/Database/Schema/User.hs
View file @ 84a3f5e3
......@@ -121,11 +121,11 @@ userTable = Table "auth_user"
}
)
$(deriveJSON (unPrefix "userLight_") ''UserLight)
$(deriveJSON (unPrefix "user_") ''UserPoly)
instance FromField UserLight where
fromField = fromField'
instance FromField UserDB where
fromField = fromField'
$(deriveJSON (unPrefix "userLight_") ''UserLight)
$(deriveJSON (unPrefix "user_") ''UserPoly)
src/Gargantext/Utils/Jobs.hs
View file @ 84a3f5e3
......@@ -10,6 +10,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Utils.Jobs (
-- * Serving the JOBS API
serveJobsAPI
......
src/Gargantext/Utils/SpacyNLP.hs
View file @ 84a3f5e3
......@@ -15,71 +15,24 @@ Server to be used: https://gitlab.iscpif.fr/gargantext/spacy-server
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Utils.SpacyNLP where
module Gargantext.Utils.SpacyNLP (
module Gargantext.Utils.SpacyNLP.Types
, spacyRequest
, spacyTagsToToken
, spacyDataToPosSentences
, nlp
) where
import Control.Lens
import Data.Aeson (encode)
import Data.Aeson.TH (deriveJSON)
import Data.Text hiding (map, group, filter, concat, zip)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Terms.Multi.PosTagging.Types
import Gargantext.Core.Types (POS(..), NER(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude
import Network.HTTP.Simple (parseRequest, httpJSON, setRequestBodyLBS, getResponseBody, Response)
import Network.URI (URI(..))
import Gargantext.Utils.SpacyNLP.Types
data SpacyData = SpacyData { _spacy_data :: ![SpacyText]}
deriving (Show)
data SpacyText = SpacyText { _spacy_text :: !Text
, _spacy_tags :: ![SpacyTags]
} deriving (Show)
data SpacyTags =
SpacyTags { _spacyTags_text :: !Text
, _spacyTags_text_with_ws :: !Text
, _spacyTags_whitespace :: !Text
, _spacyTags_head :: !Text
, _spacyTags_head_index :: !Int
, _spacyTags_left_edge :: !Text
, _spacyTags_right_edge :: !Text
, _spacyTags_index :: Int
, _spacyTags_ent_type :: !NER
, _spacyTags_ent_iob :: !Text
, _spacyTags_lemma :: !Text
, _spacyTags_normalized :: !Text
, _spacyTags_shape :: !Text
, _spacyTags_prefix :: !Text
, _spacyTags_suffix :: !Text
, _spacyTags_is_alpha :: Bool
, _spacyTags_is_ascii :: Bool
, _spacyTags_is_digit :: Bool
, _spacyTags_is_title :: Bool
, _spacyTags_is_punct :: Bool
, _spacyTags_is_left_punct :: Bool
, _spacyTags_is_right_punct :: Bool
, _spacyTags_is_space :: Bool
, _spacyTags_is_bracket :: Bool
, _spacyTags_is_quote :: Bool
, _spacyTags_is_currency :: Bool
, _spacyTags_like_url :: Bool
, _spacyTags_like_num :: Bool
, _spacyTags_like_email :: Bool
, _spacyTags_is_oov :: Bool
, _spacyTags_is_stop :: Bool
, _spacyTags_pos :: POS
, _spacyTags_tag :: POS
, _spacyTags_dep :: !Text
, _spacyTags_lang :: !Text
, _spacyTags_prob :: !Int
, _spacyTags_char_offset :: !Int
} deriving (Show)
data SpacyRequest = SpacyRequest { _spacyRequest_text :: !Text }
deriving (Show)
spacyRequest :: URI -> Text -> IO SpacyData
spacyRequest uri txt = do
req <- parseRequest $ "POST " <> show (uri { uriPath = "/pos" })
......@@ -87,30 +40,18 @@ spacyRequest uri txt = do
result <- httpJSON request :: IO (Response SpacyData)
pure $ getResponseBody result
-- Instances
deriveJSON (unPrefix "_spacy_") ''SpacyData
deriveJSON (unPrefix "_spacy_") ''SpacyText
deriveJSON (unPrefix "_spacyTags_") ''SpacyTags
deriveJSON (unPrefix "_spacyRequest_") ''SpacyRequest
makeLenses ''SpacyData
makeLenses ''SpacyText
makeLenses ''SpacyTags
makeLenses ''SpacyRequest
----------------------------------------------------------------
spacyTagsToToken :: SpacyTags -> Token
spacyTagsToToken st = Token (st ^. spacyTags_index)
(st ^. spacyTags_normalized)
(st ^. spacyTags_text)
(st ^. spacyTags_lemma)
(st ^. spacyTags_head_index)
(st ^. spacyTags_char_offset)
(Just $ st ^. spacyTags_pos)
(Just $ st ^. spacyTags_ent_type)
(Just $ st ^. spacyTags_prefix)
(Just $ st ^. spacyTags_suffix)
spacyTagsToToken st = Token (_spacyTags_index st)
(_spacyTags_normalized st)
(_spacyTags_text st)
(_spacyTags_lemma st)
(_spacyTags_head_index st)
(_spacyTags_char_offset st)
(Just $ _spacyTags_pos st)
(Just $ _spacyTags_ent_type st)
(Just $ _spacyTags_prefix st)
(Just $ _spacyTags_suffix st)
spacyDataToPosSentences :: SpacyData -> PosSentences
spacyDataToPosSentences (SpacyData ds) = PosSentences
......
src/Gargantext/Utils/SpacyNLP/Types.hs 0 → 100644
View file @ 84a3f5e3
{-|
Module : Gargantext.Utils.SpacyNLP.Types
Description : John Snow NLP API connexion
Copyright : (c) CNRS, 2017
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Spacy ecosystem: https://github.com/explosion/spaCy
Server to be used: https://gitlab.iscpif.fr/gargantext/spacy-server
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Utils.SpacyNLP.Types where
import Control.Lens
import Data.Aeson.TH (deriveJSON)
import Data.Text hiding (map, group, filter, concat, zip)
import Gargantext.Core.Types (POS(..), NER(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude
data SpacyData = SpacyData { _spacy_data :: ![SpacyText]}
deriving (Show)
data SpacyText = SpacyText { _spacy_text :: !Text
, _spacy_tags :: ![SpacyTags]
} deriving (Show)
data SpacyTags =
SpacyTags { _spacyTags_text :: !Text
, _spacyTags_text_with_ws :: !Text
, _spacyTags_whitespace :: !Text
, _spacyTags_head :: !Text
, _spacyTags_head_index :: !Int
, _spacyTags_left_edge :: !Text
, _spacyTags_right_edge :: !Text
, _spacyTags_index :: Int
, _spacyTags_ent_type :: !NER
, _spacyTags_ent_iob :: !Text
, _spacyTags_lemma :: !Text
, _spacyTags_normalized :: !Text
, _spacyTags_shape :: !Text
, _spacyTags_prefix :: !Text
, _spacyTags_suffix :: !Text
, _spacyTags_is_alpha :: Bool
, _spacyTags_is_ascii :: Bool
, _spacyTags_is_digit :: Bool
, _spacyTags_is_title :: Bool
, _spacyTags_is_punct :: Bool
, _spacyTags_is_left_punct :: Bool
, _spacyTags_is_right_punct :: Bool
, _spacyTags_is_space :: Bool
, _spacyTags_is_bracket :: Bool
, _spacyTags_is_quote :: Bool
, _spacyTags_is_currency :: Bool
, _spacyTags_like_url :: Bool
, _spacyTags_like_num :: Bool
, _spacyTags_like_email :: Bool
, _spacyTags_is_oov :: Bool
, _spacyTags_is_stop :: Bool
, _spacyTags_pos :: POS
, _spacyTags_tag :: POS
, _spacyTags_dep :: !Text
, _spacyTags_lang :: !Text
, _spacyTags_prob :: !Int
, _spacyTags_char_offset :: !Int
} deriving (Show)
data SpacyRequest = SpacyRequest { _spacyRequest_text :: !Text }
deriving (Show)
--
-- JSON instances
--
deriveJSON (unPrefix "_spacyTags_") ''SpacyTags
deriveJSON (unPrefix "_spacy_") ''SpacyText
deriveJSON (unPrefix "_spacy_") ''SpacyData
deriveJSON (unPrefix "_spacyRequest_") ''SpacyRequest
--
-- Lenses
--
makeLenses ''SpacyData
makeLenses ''SpacyText
makeLenses ''SpacyTags
makeLenses ''SpacyRequest
stack.yaml
View file @ 84a3f5e3
......@@ -148,6 +148,11 @@ extra-deps:
- tmp-postgres-1.34.1.0
- vector-0.12.3.0@sha256:0ae2c1ba86f0077910be242ec6802cc3d7725fe7b2bea6987201aa3737b239b5,7953
- wai-3.2.4
- morpheus-graphql-0.24.3
- morpheus-graphql-app-0.24.3
- morpheus-graphql-core-0.24.3
- morpheus-graphql-server-0.24.3
- morpheus-graphql-subscriptions-0.24.3
# For the graph clustering
ghc-options:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment