Skip to content

haskell-gargantext
haskell-gargantext
Commit 76e11752 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/dev-auth' into dev-merge

parents a517afbc a2dc9494
Pipeline #588 failed with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 614 additions and 317 deletions
    bin/gargantext-import/Main.hs
    View file @ 76e11752
    ......@@ -30,7 +30,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
    import Gargantext.Database.Schema.User (insertUsersDemo)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Core (Lang(..))
    import Gargantext.API -- (GargError)
    import Gargantext.API.Types (GargError)
    import Gargantext.API.Node () -- instances
    import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
    import System.Environment (getArgs)
    ......
    bin/gargantext-init/Main.hs
    View file @ 76e11752
    ......@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
    import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Core (Lang(..))
    import Gargantext.API -- (GargError)
    import Gargantext.API.Types (GargError)
    import Gargantext.API.Node () -- instances
    import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
    --import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
    ......
    devops/docker/Dockerfile
    View file @ 76e11752
    from fpco/stack-build:lts-12.26
    from fpco/stack-build:lts-14.6
    RUN apt-get update && \
    apt-get install -y git libigraph0-dev && \
    ......
    devops/docker/docker-postgres
    View file @ 76e11752
    ......@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || :
    export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')"
    docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
    sleep 3
    docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < src/Gargantext/Database/Schema/schema.sql
    docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < devops/postgres/schema.sql
    #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < gargantext.dump
    #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres dropdb -h postgres -U gargantua gargandbV5
    package.yaml
    View file @ 76e11752
    ......@@ -33,6 +33,7 @@ library:
    # - Gargantext.API.Orchestrator
    - Gargantext.API.Search
    - Gargantext.API.Settings
    - Gargantext.API.Types
    - Gargantext.Core
    - Gargantext.Core.Types
    - Gargantext.Core.Types.Main
    ......@@ -130,7 +131,7 @@ library:
    - hlcm
    - ini
    - insert-ordered-containers
    - jose-jwt
    - jose
    # - kmeans-vector
    - json-stream
    - KMP
    ......@@ -160,6 +161,7 @@ library:
    - simple-reflect
    - cereal # (IGraph)
    - singletons # (IGraph)
    - quickcheck-instances
    - random
    - rake
    - regex-compat
    ......@@ -169,6 +171,8 @@ library:
    - semigroups
    - servant
    - servant-auth
    - servant-auth-server >= 0.4.4.0
    - servant-auth-swagger
    - servant-blaze
    - servant-client
    # - servant-job
    ......
    src/Gargantext/API.hs
    View file @ 76e11752
    ......@@ -55,6 +55,9 @@ import Network.Wai
    import Network.Wai.Handler.Warp hiding (defaultSettings)
    import Servant
    import Servant.Auth as SA
    import Servant.Auth.Server (AuthResult(..))
    import Servant.Auth.Swagger ()
    import Servant.HTML.Blaze (HTML)
    --import Servant.Mock (mock)
    --import Servant.Job.Server (WithCallbacks)
    ......@@ -68,7 +71,7 @@ import Text.Blaze.Html (Html)
    --import Gargantext.API.Swagger
    --import Gargantext.Database.Node.Contact (HyperdataContact)
    import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
    import Gargantext.API.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), AuthContext, auth, withAccess)
    import Gargantext.API.Count ( CountAPI, count, Query)
    import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
    import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
    ......@@ -76,9 +79,6 @@ import Gargantext.API.Node
    import Gargantext.API.Search (SearchPairsAPI, searchPairs)
    import Gargantext.API.Types
    import qualified Gargantext.API.Corpus.New as New
    import Gargantext.Core.Types (HasInvalidError(..))
    import Gargantext.Database.Schema.Node (HasNodeError(..), NodeError)
    import Gargantext.Database.Tree (HasTreeError(..), TreeError)
    import Gargantext.Database.Types.Node
    import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
    import Gargantext.Database.Utils (HasConnection)
    ......@@ -109,24 +109,8 @@ import Network.HTTP.Types hiding (Query)
    import Gargantext.API.Settings
    data GargError
    = GargNodeError NodeError
    | GargTreeError TreeError
    | GargInvalidError Validation
    deriving (Show)
    makePrisms ''GargError
    instance HasNodeError GargError where
    _NodeError = _GargNodeError
    instance HasInvalidError GargError where
    _InvalidError = _GargInvalidError
    instance HasTreeError GargError where
    _TreeError = _GargTreeError
    showAsServantErr :: Show a => a -> ServerError
    showAsServantErr :: GargError -> ServerError
    showAsServantErr (GargServerError err) = err
    showAsServantErr a = err500 { errBody = BL8.pack $ show a }
    fireWall :: Applicative f => Request -> FireWall -> f Bool
    ......@@ -231,15 +215,26 @@ type GargAPI' =
    "auth" :> Summary "AUTH API"
    :> ReqBody '[JSON] AuthRequest
    :> Post '[JSON] AuthResponse
    -- Roots endpoint
    :<|> "user" :> Summary "First user endpoint"
    -- TODO-ACCESS here we want to request a particular header for
    -- auth and capabilities.
    :<|> GargPrivateAPI
    type GargPrivateAPI = SA.Auth '[SA.JWT] AuthenticatedUser :> GargPrivateAPI'
    type GargAdminAPI
    -- Roots endpoint
    = "user" :> Summary "First user endpoint"
    :> Roots
    :<|> "nodes" :> Summary "Nodes endpoint"
    :> ReqBody '[JSON] [NodeId] :> NodesAPI
    type GargPrivateAPI' =
    GargAdminAPI
    -- Node endpoint
    :<|> "node" :> Summary "Node endpoint"
    :> Capture "id" NodeId :> NodeAPI HyperdataAny
    -- Corpus endpoint
    :<|> "corpus":> Summary "Corpus endpoint"
    :> Capture "id" CorpusId :> NodeAPI HyperdataCorpus
    ......@@ -251,16 +246,12 @@ type GargAPI' =
    -- Document endpoint
    :<|> "document":> Summary "Document endpoint"
    :> Capture "id" DocId :> "ngrams" :> TableNgramsApi
    -- Corpus endpoint
    :<|> "nodes" :> Summary "Nodes endpoint"
    :> ReqBody '[JSON] [NodeId] :> NodesAPI
    -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
    -- Corpus endpoint
    -- TODO-SECURITY
    :<|> "count" :> Summary "Count endpoint"
    :> ReqBody '[JSON] Query :> CountAPI
    -- Corpus endpoint --> TODO rename s/search/filter/g
    :<|> "search":> Capture "corpus" NodeId :> SearchPairsAPI
    ......@@ -290,6 +281,10 @@ type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
    type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
    -- This is the concrete monad. It needs to be used as little as possible,
    -- instead, prefer GargServer, GargServerT, GargServerC.
    type GargServerM env err = ReaderT env (ExceptT err IO)
    ---------------------------------------------------------------------
    -- | Server declarations
    ......@@ -298,30 +293,42 @@ server :: forall env. (HasConnection env, HasRepo env, HasSettings env)
    server env = do
    -- orchestrator <- scrapyOrchestrator env
    pure $ swaggerFront
    :<|> hoistServer (Proxy :: Proxy GargAPI) transform serverGargAPI
    :<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
    :<|> serverStatic
    where
    transform :: forall a. ReaderT env (ExceptT GargError IO) a -> Handler a
    transform :: forall a. GargServerM env GargError a -> Handler a
    transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
    serverGargAPI :: GargServer GargAPI
    serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
    serverGargAPI -- orchestrator
    = auth
    :<|> roots
    :<|> nodeAPI (Proxy :: Proxy HyperdataAny) fakeUserId
    :<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) fakeUserId
    :<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) fakeUserId
    :<|> apiNgramsTableDoc
    :<|> nodesAPI
    :<|> count -- TODO: undefined
    :<|> searchPairs -- TODO: move elsewhere
    :<|> graphAPI -- TODO: mock
    :<|> treeAPI
    :<|> New.api
    :<|> New.info fakeUserId
    = auth :<|> serverPrivateGargAPI
    -- :<|> orchestrator
    where
    fakeUserId = 2 -- TODO, byDefault user1 (if users automatically generated with inserUsersDemo)
    serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
    serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
    serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
    -- Here throwAll' requires a concrete type for the monad.
    -- TODO-SECURITY admin only: withAdmin
    -- Question: How do we mark admins?
    serverGargAdminAPI :: GargServer GargAdminAPI
    serverGargAdminAPI
    = roots
    :<|> nodesAPI
    serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
    serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
    = serverGargAdminAPI
    :<|> nodeAPI (Proxy :: Proxy HyperdataAny) uid
    :<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) uid
    :<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) uid
    :<|> withAccess (Proxy :: Proxy TableNgramsApi) Proxy uid <*> apiNgramsTableDoc
    :<|> count -- TODO: undefined
    :<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid <*> searchPairs -- TODO: move elsewhere
    :<|> withAccess (Proxy :: Proxy GraphAPI) Proxy uid <*> graphAPI -- TODO: mock
    :<|> withAccess (Proxy :: Proxy TreeAPI) Proxy uid <*> treeAPI
    :<|> New.api -- TODO-SECURITY
    :<|> New.info uid -- TODO-SECURITY
    serverStatic :: Server (Get '[HTML] Html)
    serverStatic = $(do
    ......@@ -341,7 +348,13 @@ swaggerFront = schemaUiServer swaggerDoc
    ---------------------------------------------------------------------
    makeApp :: (HasConnection env, HasRepo env, HasSettings env)
    => env -> IO Application
    makeApp = fmap (serve api) . server
    makeApp env = serveWithContext api cfg <$> server env
    where
    cfg :: Servant.Context AuthContext
    cfg = env ^. settings . jwtSettings
    :. env ^. settings . cookieSettings
    -- :. authCheck env
    :. EmptyContext
    --appMock :: Application
    --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
    ......
    src/Gargantext/API/Auth.hs
    View file @ 76e11752
    ......@@ -16,27 +16,40 @@ Main authorisation of Gargantext are managed in this module
    -- 2: Implement the Auth API backend
    https://github.com/haskell-servant/servant-auth
    TODO-ACCESS Critical
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.API.Auth
    where
    import Control.Lens (view)
    import Control.Monad.IO.Class (liftIO)
    import Data.Aeson.TH (deriveJSON)
    import Data.List (elem)
    import Data.Swagger
    import Data.Text (Text, reverse)
    import Data.Text.Lazy (toStrict)
    import Data.Text.Lazy.Encoding (decodeUtf8)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Servant
    import Servant.Auth.Server
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.API.Settings
    import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, serverError, GargServerC)
    import Gargantext.Database.Root (getRoot)
    import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Database.Tree (isDescendantOf)
    import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId(..), UserId)
    import Gargantext.Database.Utils (Cmd', CmdM, HasConnection)
    import Gargantext.Prelude hiding (reverse)
    import Test.QuickCheck (elements, oneof)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ......@@ -74,15 +87,30 @@ type TreeId = NodeId
    data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
    deriving (Eq)
    checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
    makeTokenForUser :: (HasSettings env, HasJoseError err)
    => NodeId -> Cmd' env err Token
    makeTokenForUser uid = do
    jwtS <- view $ settings . jwtSettings
    e <- liftIO $ makeJWT (AuthenticatedUser uid) jwtS Nothing
    -- TODO-SECURITY here we can implement token expiration ^^.
    either joseError (pure . toStrict . decodeUtf8) e
    -- TODO not sure about the encoding...
    checkAuthRequest :: (HasSettings env, HasConnection env, HasJoseError err)
    => Username -> Password -> Cmd' env err CheckAuth
    checkAuthRequest u p
    | not (u `elem` arbitraryUsername) = pure InvalidUser
    | u /= reverse p = pure InvalidPassword
    | otherwise = do
    muId <- getRoot "user1"
    pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
    auth :: AuthRequest -> Cmd err AuthResponse
    muId <- head <$> getRoot "user1" -- TODO user1 hard-coded
    case _node_id <$> muId of
    Nothing -> pure InvalidUser
    Just uid -> do
    token <- makeTokenForUser uid
    pure $ Valid token uid
    auth :: (HasSettings env, HasConnection env, HasJoseError err)
    => AuthRequest -> Cmd' env err AuthResponse
    auth (AuthRequest u p) = do
    checkAuthRequest' <- checkAuthRequest u p
    case checkAuthRequest' of
    ......@@ -90,9 +118,36 @@ auth (AuthRequest u p) = do
    InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
    Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
    newtype AuthenticatedUser = AuthenticatedUser
    { _authUser_id :: NodeId
    } deriving (Generic)
    $(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
    instance ToSchema AuthenticatedUser where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
    instance ToJWT AuthenticatedUser
    instance FromJWT AuthenticatedUser
    --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
    -- TODO-SECURITY why is the CookieSettings necessary?
    type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
    {-
    instance FromBasicAuthData AuthenticatedUser where
    fromBasicAuthData authData authCheckFunction = authCheckFunction authData
    authCheck :: forall env. env
    -> BasicAuthData
    -> IO (AuthResult AuthenticatedUser)
    authCheck _env (BasicAuthData login password) = pure $
    maybe Indefinite Authenticated $ TODO
    -}
    -- | Instances
    $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
    instance ToSchema AuthRequest
    instance ToSchema AuthRequest where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
    instance Arbitrary AuthRequest where
    arbitrary = elements [ AuthRequest u p
    ......@@ -101,23 +156,40 @@ instance Arbitrary AuthRequest where
    ]
    $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
    instance ToSchema AuthResponse
    instance ToSchema AuthResponse where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
    instance Arbitrary AuthResponse where
    arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
    , flip AuthResponse Nothing . Just <$> arbitrary ]
    $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
    instance ToSchema AuthInvalid
    instance ToSchema AuthInvalid where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
    instance Arbitrary AuthInvalid where
    arbitrary = elements [ AuthInvalid m
    | m <- [ "Invalid user", "Invalid password"]
    ]
    $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
    instance ToSchema AuthValid
    instance ToSchema AuthValid where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
    instance Arbitrary AuthValid where
    arbitrary = elements [ AuthValid to tr
    | to <- ["token0", "token1"]
    , tr <- [1..3]
    ]
    withAccessM :: (CmdM env err m, HasServerError err) => UserId -> NodeId -> m a -> m a
    withAccessM uId id m = do
    d <- id `isDescendantOf` NodeId uId
    if d then m else serverError err401
    withAccess :: forall env err m api.
    (GargServerC env err m, HasServer api '[]) =>
    Proxy api -> Proxy m ->
    UserId -> NodeId ->
    ServerT api m -> ServerT api m
    withAccess p _ uId id = hoistServer p f
    where
    f :: forall a. m a -> m a
    f = withAccessM uId id
    src/Gargantext/API/Corpus/New.hs
    View file @ 76e11752
    ......@@ -30,7 +30,7 @@ import Data.Aeson.TH (deriveJSON)
    import Data.Swagger
    import Data.Text (Text)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Flow (flowCorpusSearchInDatabase)
    import Gargantext.Database.Types.Node (CorpusId)
    import Gargantext.Text.Terms (TermType(..))
    ......@@ -60,9 +60,7 @@ instance Arbitrary Query where
    ]
    instance ToSchema Query where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 6 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
    type Api = Summary "New Corpus endpoint"
    :> ReqBody '[JSON] Query
    ......@@ -70,6 +68,8 @@ type Api = Summary "New Corpus endpoint"
    :<|> Get '[JSON] ApiInfo
    -- | TODO manage several apis
    -- TODO-ACCESS
    -- TODO this is only the POST
    api :: (FlowCmdM env err m) => Query -> m CorpusId
    api (Query q _ as) = do
    cId <- case head as of
    ......
    src/Gargantext/API/Count.hs
    View file @ 76e11752
    ......@@ -41,7 +41,7 @@ import Test.QuickCheck (elements)
    -- import Control.Applicative ((<*>))
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    -----------------------------------------------------------------------
    -- TODO-ACCESS: CanCount
    ......@@ -93,7 +93,9 @@ instance Arbitrary Query where
    , n <- take 10 $ permutations scrapers
    ]
    instance ToSchema Query
    instance ToSchema Query where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
    -----------------------------------------------------------------------
    type Code = Integer
    type Error = Text
    ......@@ -144,7 +146,8 @@ data Count = Count { count_name :: Scraper
    $(deriveJSON (unPrefix "count_") ''Count)
    instance ToSchema Count
    instance ToSchema Count where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
    --instance Arbitrary Count where
    -- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
    ......
    src/Gargantext/API/Metrics.hs
    View file @ 76e11752
    ......@@ -31,7 +31,7 @@ import Data.Time (UTCTime)
    import Data.Text (Text)
    import GHC.Generics (Generic)
    import Gargantext.Core.Types (ListType(..))
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Utils
    import Gargantext.Core.Types (CorpusId, ListId, Limit)
    import Gargantext.Prelude
    ......@@ -50,7 +50,8 @@ data Metrics = Metrics
    { metrics_data :: [Metric]}
    deriving (Generic, Show)
    instance ToSchema Metrics
    instance ToSchema Metrics where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "metrics_")
    instance Arbitrary Metrics
    where
    arbitrary = Metrics <$> arbitrary
    ......@@ -62,7 +63,8 @@ data Metric = Metric
    , m_cat :: !ListType
    } deriving (Generic, Show)
    instance ToSchema Metric
    instance ToSchema Metric where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "m_")
    instance Arbitrary Metric
    where
    arbitrary = Metric <$> arbitrary
    ......@@ -78,7 +80,8 @@ deriveJSON (unPrefix "m_") ''Metric
    data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
    deriving (Generic, Show)
    instance (ToSchema a) => ToSchema (ChartMetrics a)
    instance (ToSchema a) => ToSchema (ChartMetrics a) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "chartMetrics_")
    instance (Arbitrary a) => Arbitrary (ChartMetrics a)
    where
    arbitrary = ChartMetrics <$> arbitrary
    ......@@ -86,7 +89,8 @@ instance (Arbitrary a) => Arbitrary (ChartMetrics a)
    deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics
    -------------------------------------------------------------
    instance ToSchema Histo
    instance ToSchema Histo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "histo_")
    instance Arbitrary Histo
    where
    arbitrary = elements [ Histo ["2012"] [1]
    ......@@ -95,11 +99,6 @@ instance Arbitrary Histo
    deriveJSON (unPrefix "histo_") ''Histo
    instance ToSchema MyTree
    instance Arbitrary MyTree
    where
    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
    -------------------------------------------------------------
    -- | Scatter metrics API
    ......
    src/Gargantext/API/Ngrams.hs
    View file @ 76e11752
    {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
    {-|
    Module : Gargantext.API.Ngrams
    Description : Server API
    ......@@ -32,6 +33,52 @@ add get
    {-# OPTIONS -fno-warn-orphans #-}
    module Gargantext.API.Ngrams
    ( TableNgramsApi
    , TableNgramsApiGet
    , TableNgramsApiPut
    , TableNgramsApiPost
    , getTableNgrams
    , putListNgrams
    , tableNgramsPost
    , apiNgramsTableCorpus
    , apiNgramsTableDoc
    , NgramsStatePatch
    , NgramsTablePatch
    , NgramsElement
    , mkNgramsElement
    , mergeNgramsElement
    , RootParent(..)
    , MSet
    , mSetFromList
    , mSetToList
    , Repo(..)
    , r_version
    , r_state
    , NgramsRepo
    , NgramsRepoElement(..)
    , saveRepo
    , initRepo
    , RepoEnv(..)
    , renv_var
    , renv_lock
    , TabType(..)
    , ngramsTypeFromTabType
    , HasRepoVar(..)
    , HasRepoSaver(..)
    , HasRepo(..)
    , RepoCmdM
    , QueryParamR
    , TODO(..)
    )
    where
    -- import Debug.Trace (trace)
    ......@@ -69,7 +116,7 @@ import Data.Swagger hiding (version, patch)
    import Data.Text (Text, isInfixOf, count)
    import Data.Validity
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
    import Gargantext.Database.Config (userMaster)
    import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast)
    ......@@ -208,7 +255,8 @@ mkNgramsElement ngrams list rp children =
    newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
    newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
    instance ToSchema NgramsElement
    instance ToSchema NgramsElement where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
    instance Arbitrary NgramsElement where
    arbitrary = elements [newNgramsElement Nothing "sport"]
    ......@@ -462,7 +510,8 @@ data NgramsPatch =
    deriveJSON (unPrefix "_") ''NgramsPatch
    makeLenses ''NgramsPatch
    instance ToSchema NgramsPatch
    instance ToSchema NgramsPatch where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
    instance Arbitrary NgramsPatch where
    arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
    ......@@ -597,7 +646,8 @@ data Versioned a = Versioned
    deriving (Generic, Show)
    deriveJSON (unPrefix "_v_") ''Versioned
    makeLenses ''Versioned
    instance ToSchema a => ToSchema (Versioned a)
    instance ToSchema a => ToSchema (Versioned a) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
    instance Arbitrary a => Arbitrary (Versioned a) where
    arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
    ......@@ -798,12 +848,14 @@ putListNgrams listId ngramsType nes = do
    where
    m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
    -- TODO-ACCESS check
    tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
    tableNgramsPost tabType listId mayList =
    putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
    -- Apply the given patch to the DB and returns the patch to be applied on the
    -- client.
    -- TODO-ACCESS check
    tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
    => TabType -> ListId
    -> Versioned NgramsTablePatch
    ......
    src/Gargantext/API/Ngrams/NTree.hs
    View file @ 76e11752
    ......@@ -23,16 +23,18 @@ import Data.Text (Text)
    import Gargantext.Prelude
    import GHC.Generics (Generic)
    import Data.Aeson.TH (deriveJSON)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (ListType(..), NodeId)
    import Gargantext.API.Ngrams
    import Data.Tree
    import Data.Maybe (catMaybes)
    import Data.Map (Map)
    import Data.Set (Set)
    import Data.Swagger
    import qualified Data.Set as Set
    import qualified Data.Map as Map
    import qualified Data.List as List
    import Test.QuickCheck
    type Children = Text
    type Root = Text
    ......@@ -47,12 +49,17 @@ toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
    deriveJSON (unPrefix "mt_") ''MyTree
    instance ToSchema MyTree where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
    instance Arbitrary MyTree
    where
    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
    toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
    toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
    where
    buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m)
    value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
    rootsCandidates = catMaybes
    ......@@ -60,7 +67,7 @@ toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
    $ map (\(c,c') -> case _nre_root c' of
    Nothing -> Just c
    _ -> _nre_root c' ) (Map.toList m)
    roots = map fst
    $ filter (\(_,l) -> l == lt)
    $ catMaybes
    ......
    src/Gargantext/API/Ngrams/Tools.hs
    View file @ 76e11752
    ......@@ -33,6 +33,10 @@ import qualified Data.Set as Set
    type RootTerm = Text
    -- TODO-ACCESS: We want to do the security check before entering here.
    -- Add a static capability parameter would be nice.
    -- Ideally this is the access to `repoVar` which needs to
    -- be properly guarded.
    getListNgrams :: RepoCmdM env err m
    => [ListId] -> NgramsType
    -> m (Map Text NgramsRepoElement)
    ......
    src/Gargantext/API/Node.hs
    View file @ 76e11752
    ......@@ -7,6 +7,8 @@ Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    -- TODO-SECURITY: Critical
    -- TODO-ACCESS: CanGetNode
    -- TODO-EVENTS: No events as this is a read only query.
    Node API
    ......@@ -46,6 +48,7 @@ import Data.Swagger
    import Data.Text (Text())
    import Data.Time (UTCTime)
    import GHC.Generics (Generic)
    import Gargantext.API.Auth (withAccess)
    import Gargantext.API.Metrics
    import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
    import Gargantext.API.Ngrams.NTree (MyTree)
    ......@@ -156,11 +159,14 @@ type ChildrenApi a = Summary " Summary children"
    :> QueryParam "offset" Int
    :> QueryParam "limit" Int
    :> Get '[JSON] [Node a]
    ------------------------------------------------------------------------
    -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
    nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
    nodeAPI p uId id
    = getNode id p
    nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
    nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId id nodeAPI'
    where
    nodeAPI' :: GargServer (NodeAPI a)
    nodeAPI' = getNode id p
    :<|> rename id
    :<|> postNode uId id
    :<|> putNode id
    ......@@ -172,18 +178,18 @@ nodeAPI p uId id
    :<|> apiNgramsTableCorpus id
    :<|> getPairing id
    -- :<|> getTableNgramsDoc id
    :<|> catApi id
    :<|> searchDocs id
    :<|> getScatter id
    :<|> getChart id
    :<|> getPie id
    :<|> getTree id
    :<|> phyloAPI id uId
    :<|> postUpload id
    where
    deleteNodeApi id' = do
    node <- getNode' id'
    if _node_typename node == nodeTypeId NodeUser
    ......@@ -196,6 +202,7 @@ nodeAPI p uId id
    data RenameNode = RenameNode { r_name :: Text }
    deriving (Generic)
    -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON RenameNode
    instance ToJSON RenameNode
    instance ToSchema RenameNode
    ......@@ -206,6 +213,7 @@ data PostNode = PostNode { pn_name :: Text
    , pn_typename :: NodeType}
    deriving (Generic)
    -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON PostNode
    instance ToJSON PostNode
    instance ToSchema PostNode
    ......@@ -222,6 +230,7 @@ data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
    }
    deriving (Generic)
    -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON NodesToCategory
    instance ToJSON NodesToCategory
    instance ToSchema NodesToCategory
    ......@@ -301,8 +310,7 @@ instance HasTreeError ServantErr where
    -}
    type TreeAPI = Get '[JSON] (Tree NodeTree)
    -- TODO-ACCESS: CanTree or CanGetNode
    -- TODO-EVENTS: No events as this is a read only query.
    treeAPI :: NodeId -> GargServer TreeAPI
    treeAPI = treeDB
    ......
    src/Gargantext/API/Search.hs
    View file @ 76e11752
    ......@@ -35,7 +35,7 @@ import Test.QuickCheck (elements)
    -- import Control.Applicative ((<*>))
    import Gargantext.API.Types (GargServer)
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Types.Node
    import Gargantext.Database.TextSearch
    import Gargantext.Database.Facet
    ......@@ -48,9 +48,7 @@ data SearchQuery = SearchQuery
    $(deriveJSON (unPrefix "sq_") ''SearchQuery)
    instance ToSchema SearchQuery where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 3}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sq_")
    instance Arbitrary SearchQuery where
    arbitrary = elements [SearchQuery ["electrodes"]]
    ......@@ -64,9 +62,7 @@ instance Arbitrary SearchDocResults where
    arbitrary = SearchDocResults <$> arbitrary
    instance ToSchema SearchDocResults where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 4}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
    data SearchPairedResults = SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
    deriving (Generic)
    ......@@ -76,9 +72,7 @@ instance Arbitrary SearchPairedResults where
    arbitrary = SearchPairedResults <$> arbitrary
    instance ToSchema SearchPairedResults where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "spr_")
    -----------------------------------------------------------------------
    -- TODO-ACCESS: CanSearch? or is it part of CanGetNode
    ......
    src/Gargantext/API/Settings.hs
    View file @ 76e11752
    ......@@ -6,6 +6,8 @@ License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    TODO-SECURITY: Critical
    -}
    {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    ......@@ -40,16 +42,15 @@ import Data.Aeson
    import Data.Maybe (fromMaybe)
    import Data.Either (either)
    import Data.Text
    import Data.Text.Encoding (encodeUtf8)
    --import Data.Text.Encoding (encodeUtf8)
    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Lazy as L
    import Servant
    import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
    import Servant.Client (BaseUrl, parseBaseUrl)
    --import Servant.Job.Async (newJobEnv, defaultSettings)
    import Web.HttpApiData (parseUrlPiece)
    import qualified Jose.Jwk as Jose
    import qualified Jose.Jwa as Jose
    import Control.Concurrent
    import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
    ......@@ -77,7 +78,8 @@ data Settings = Settings
    , _logLevelLimit :: LogLevel -- log level from the monad-logger package
    -- , _dbServer :: Text
    -- ^ this is not used yet
    , _jwtSecret :: Jose.Jwk -- key from the jose-jwt package
    , _jwtSettings :: JWTSettings
    , _cookieSettings :: CookieSettings
    , _sendLoginEmails :: SendEmailType
    , _scrapydUrl :: BaseUrl
    , _fileFolder :: FilePath
    ......@@ -89,29 +91,22 @@ class HasSettings env where
    settings :: Getter env Settings
    parseJwk :: Text -> Jose.Jwk
    parseJwk secretStr = jwk
    where
    secretBs = encodeUtf8 secretStr
    jwk = Jose.SymmetricJwk secretBs
    Nothing
    Nothing
    (Just $ Jose.Signed Jose.HS256)
    devSettings :: Settings
    devSettings = Settings
    devSettings :: FilePath -> IO Settings
    devSettings jwkFile = do
    jwkExists <- doesFileExist jwkFile
    when (not jwkExists) $ writeKey jwkFile
    jwk <- readKey jwkFile
    pure $ Settings
    { _allowedOrigin = "http://localhost:8008"
    , _allowedHost = "localhost:3000"
    , _appPort = 3000
    , _logLevelLimit = LevelDebug
    -- , _dbServer = "localhost"
    -- generate with dd if=/dev/urandom bs=1 count=32 | base64
    -- make sure jwtSecret differs between development and production, because you do not want
    -- your production key inside source control.
    , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
    , _sendLoginEmails = LogEmailToConsole
    , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
    , _fileFolder = "data"
    , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
    , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
    }
    ......@@ -232,10 +227,13 @@ readRepoEnv = do
    saver <- mkRepoSaver mvar
    pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
    devJwkFile :: FilePath
    devJwkFile = "dev.jwk"
    newEnv :: PortNumber -> FilePath -> IO Env
    newEnv port file = do
    manager <- newTlsManager
    settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
    settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
    when (port /= settings ^. appPort) $
    panic "TODO: conflicting settings of port"
    ......@@ -295,10 +293,11 @@ withDevEnv iniPath k = do
    param <- databaseParameters iniPath
    conn <- connect param
    repo <- readRepoEnv
    setts <- devSettings devJwkFile
    pure $ DevEnv
    { _dev_env_conn = conn
    , _dev_env_repo = repo
    , _dev_env_settings = devSettings
    , _dev_env_settings = setts
    }
    -- | Run Cmd Sugar for the Repl (GHCI)
    ......
    src/Gargantext/API/Table.hs
    View file @ 76e11752
    ......@@ -45,7 +45,7 @@ import Data.Text (Text())
    import GHC.Generics (Generic)
    import Gargantext.API.Ngrams (TabType(..))
    import Gargantext.Core.Types (Offset, Limit)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
    import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
    import Gargantext.Database.TextSearch
    ......@@ -73,9 +73,7 @@ data TableQuery = TableQuery
    $(deriveJSON (unPrefix "tq_") ''TableQuery)
    instance ToSchema TableQuery where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 3}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tq_")
    instance Arbitrary TableQuery where
    arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"]
    ......
    src/Gargantext/API/Types.hs
    View file @ 76e11752
    ......@@ -10,13 +10,26 @@ Portability : POSIX
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE UndecidableInstances #-}
    module Gargantext.API.Types
    where
    import Control.Lens (Prism', (#))
    import Control.Lens.TH (makePrisms)
    import Control.Monad.Error.Class (MonadError(throwError))
    import Crypto.JOSE.Error as Jose
    import Data.Validity
    import Servant
    import Gargantext.Prelude
    import Gargantext.API.Settings
    import Gargantext.API.Ngrams
    import Gargantext.Database.Tree
    ......@@ -24,18 +37,75 @@ import Gargantext.Core.Types
    import Gargantext.Database.Utils
    import Gargantext.Database.Schema.Node
    class HasServerError e where
    _ServerError :: Prism' e ServerError
    type GargServer api =
    forall env err m.
    serverError :: (MonadError e m, HasServerError e) => ServerError -> m a
    serverError e = throwError $ _ServerError # e
    class HasJoseError e where
    _JoseError :: Prism' e Jose.Error
    joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
    joseError = throwError . (_JoseError #)
    class ThrowAll' e a | a -> e where
    -- | 'throwAll' is a convenience function to throw errors across an entire
    -- sub-API
    --
    --
    -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
    -- > == throwError err400 :<|> throwError err400 :<|> err400
    throwAll' :: e -> a
    instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
    throwAll' e = throwAll' e :<|> throwAll' e
    -- Really this shouldn't be necessary - ((->) a) should be an instance of
    -- MonadError, no?
    instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
    throwAll' e = const $ throwAll' e
    instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
    throwAll' = throwError
    type GargServerC env err m =
    ( CmdM env err m
    , HasNodeError err
    , HasInvalidError err
    , HasTreeError err
    , HasServerError err
    , HasJoseError err
    , HasRepo env
    , HasSettings env
    )
    => ServerT api m
    type GargServerT env err m api = GargServerC env err m => ServerT api m
    type GargServer api =
    forall env err m. GargServerT env err m api
    data GargError
    = GargNodeError NodeError
    | GargTreeError TreeError
    | GargInvalidError Validation
    | GargJoseError Jose.Error
    | GargServerError ServerError
    deriving (Show)
    makePrisms ''GargError
    instance HasNodeError GargError where
    _NodeError = _GargNodeError
    instance HasInvalidError GargError where
    _InvalidError = _GargInvalidError
    instance HasTreeError GargError where
    _TreeError = _GargTreeError
    instance HasServerError GargError where
    _ServerError = _GargServerError
    instance HasJoseError GargError where
    _JoseError = _GargJoseError
    src/Gargantext/API/Utils.hs
    View file @ 76e11752
    ......@@ -21,22 +21,6 @@ import Gargantext.Prelude
    import Data.Maybe (Maybe, fromMaybe)
    import Prelude (String)
    import qualified Data.Text as T
    import Data.Swagger
    import Data.Text (Text)
    swaggerOptions :: Text -> SchemaOptions
    swaggerOptions pref = defaultSchemaOptions
    { Data.Swagger.fieldLabelModifier = modifier pref
    , Data.Swagger.unwrapUnaryRecords = False
    }
    modifier :: Text -> String -> String
    modifier pref field = T.unpack
    $ T.stripPrefix pref (T.pack field) ?! "Expecting prefix " <> T.unpack pref
    infixr 4 ?|
    ......
    src/Gargantext/Core/Types/Main.hs
    View file @ 76e11752
    ......@@ -22,8 +22,7 @@ module Gargantext.Core.Types.Main where
    ------------------------------------------------------------------------
    import Prelude (Enum, Bounded, minBound, maxBound)
    import Data.Aeson (FromJSON, ToJSON, toJSON)
    import Data.Aeson as A
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON)
    import Data.Map (fromList, lookup)
    import Data.Either (Either(..))
    ......@@ -33,7 +32,7 @@ import Data.Text (Text, unpack)
    import Data.Swagger
    import Gargantext.Database.Types.Node -- (NodeType(..), Node, Hyperdata(..))
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Prelude
    import GHC.Generics (Generic)
    ......@@ -49,36 +48,10 @@ data NodeTree = NodeTree { _nt_name :: Text
    } deriving (Show, Read, Generic)
    $(deriveJSON (unPrefix "_nt_") ''NodeTree)
    instance ToSchema NodeTree where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nt_")
    ------------------------------------------------------------------------
    -- Garg Network is a network of all Garg nodes
    --gargNetwork = undefined
    -- | Garg Node is Database Schema Typed as specification
    -- gargNode gathers all the Nodes of all users on one Node
    gargNode :: [Tree NodeTree]
    gargNode = [userTree]
    -- | User Tree simplified
    userTree :: Tree NodeTree
    userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
    -- | Project Tree
    projectTree :: Tree NodeTree
    projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
    -- | Corpus Tree
    annuaireTree :: Tree NodeTree
    annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
    corpusTree :: NodeId -> Text -> Tree NodeTree
    corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
    , leafT $ NodeTree "Graph" NodeGraph (nId +2)
    ]
    -- <> [ leafT $ NodeTree "My lists" Lists 5]
    -- <> [ leafT (NodeTree "Metrics A" Metrics 6) ]
    -- <> [ leafT (NodeTree "Class A" Classification 7)]
    )
    --data Classification = Favorites | MyClassifcation
    ......@@ -127,17 +100,14 @@ type IsTrash = Bool
    ------------------------------------------------------------------------
    -- All the Database is structred like a hierarchical Tree
    data Tree a = TreeN a [Tree a]
    data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
    deriving (Show, Read, Eq, Generic, Ord)
    instance ToJSON a => ToJSON (Tree a) where
    toJSON (TreeN node nodes) =
    object ["node" A..= toJSON node, "children" A..= toJSON nodes]
    $(deriveJSON (unPrefix "_tn_") ''Tree)
    instance FromJSON a => FromJSON (Tree a)
    instance ToSchema a => ToSchema (Tree a) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_tn_")
    instance ToSchema NodeTree
    instance ToSchema a => ToSchema (Tree a)
    instance Arbitrary (Tree NodeTree) where
    arbitrary = elements [userTree, userTree]
    ......@@ -146,3 +116,33 @@ instance Arbitrary (Tree NodeTree) where
    -- same as Data.Tree
    leafT :: a -> Tree a
    leafT x = TreeN x []
    ------------------------------------------------------------------------
    -- Garg Network is a network of all Garg nodes
    --gargNetwork = undefined
    -- | Garg Node is Database Schema Typed as specification
    -- gargNode gathers all the Nodes of all users on one Node
    gargNode :: [Tree NodeTree]
    gargNode = [userTree]
    -- | User Tree simplified
    userTree :: Tree NodeTree
    userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
    -- | Project Tree
    projectTree :: Tree NodeTree
    projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
    -- | Corpus Tree
    annuaireTree :: Tree NodeTree
    annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
    corpusTree :: NodeId -> Text -> Tree NodeTree
    corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
    , leafT $ NodeTree "Graph" NodeGraph (nId +2)
    ]
    -- <> [ leafT $ NodeTree "My lists" Lists 5]
    -- <> [ leafT (NodeTree "Metrics A" Metrics 6) ]
    -- <> [ leafT (NodeTree "Class A" Classification 7)]
    )
    src/Gargantext/Core/Types/Phylo.hs
    View file @ 76e11752
    ......@@ -25,15 +25,18 @@ Phylomemy was first described in Chavalarias, D., Cointet, J.-P., 2013. Phylomem
    module Gargantext.Core.Types.Phylo where
    import Control.Lens (makeLenses)
    import Data.Aeson.TH (deriveJSON)
    import Data.Maybe (Maybe)
    import Data.Swagger
    import Data.Text (Text)
    import Data.Time.Clock.POSIX (POSIXTime)
    import GHC.Generics (Generic)
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    ------------------------------------------------------------------------
    -- | Phylo datatype descriptor of a phylomemy
    ......@@ -94,8 +97,24 @@ type PhyloGroupId = (PhyloLevelId, Int)
    type Edge = (PhyloGroupId, Weight)
    type Weight = Double
    -- | 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 )
    -- | ToSchema instances
    instance ToSchema Phylo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    instance ToSchema PhyloPeriod where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Period")
    instance ToSchema PhyloLevel where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Level")
    instance ToSchema PhyloGroup where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Group")
    src/Gargantext/Core/Utils/Prefix.hs
    View file @ 76e11752
    ......@@ -22,6 +22,7 @@ import Data.Aeson.TH (Options, fieldLabelModifier, omitNothingFields)
    import Data.Aeson.Types (Parser)
    import Data.Char (toLower)
    import Data.Monoid ((<>))
    import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
    import Text.Read (Read(..),readMaybe)
    ......@@ -32,6 +33,9 @@ unPrefix prefix = defaultOptions
    , omitNothingFields = True
    }
    unPrefixSwagger :: String -> SchemaOptions
    unPrefixSwagger = fromAesonOptions . unPrefix
    -- | Lower case leading character
    unCapitalize :: String -> String
    unCapitalize [] = []
    ......
    src/Gargantext/Database.hs
    View file @ 76e11752
    ......@@ -17,9 +17,9 @@ Gargantext's database.
    {-# LANGUAGE NoImplicitPrelude #-}
    module Gargantext.Database ( module Gargantext.Database.Utils
    , module Gargantext.Database.Bashql
    -- , module Gargantext.Database.Bashql
    )
    where
    import Gargantext.Database.Utils (connectGargandb)
    import Gargantext.Database.Bashql
    -- import Gargantext.Database.Bashql
    src/Gargantext/Database/Access.hs
    View file @ 76e11752
    ......@@ -7,6 +7,7 @@ Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    TODO-SECURITY review purpose of this module
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    ......
    src/Gargantext/Database/Bashql.hs
    View file @ 76e11752
    {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
    {-|
    Module : Gargantext.Database.Bashql
    Description : BASHQL to deal with Gargantext Database.
    ......@@ -55,13 +56,15 @@ AMS, and by SIAM.
    [3] https://github.com/Gabriel439/Haskell-Turtle-Library
    TODO-ACCESS: should the checks be done here or before.
    -}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Bashql ( get
    module Gargantext.Database.Bashql () {-( get
    , ls
    , home
    , post
    ......@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
    , rename
    , tree
    -- , mkCorpus, mkAnnuaire
    )
    )-}
    where
    import Control.Monad.Reader -- (Reader, ask)
    ......
    src/Gargantext/Database/Facet.hs
    View file @ 76e11752
    ......@@ -26,10 +26,22 @@ Portability : POSIX
    {-# LANGUAGE TypeFamilies #-}
    ------------------------------------------------------------------------
    module Gargantext.Database.Facet
    ( runViewAuthorsDoc
    , runViewDocuments
    , filterWith
    , Pair(..)
    , Facet(..)
    , FacetDoc
    , FacetDocRead
    , FacetPaired(..)
    , FacetPairedRead
    , OrderBy(..)
    )
    where
    ------------------------------------------------------------------------
    import Control.Arrow (returnA)
    import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    -- import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON)
    import Data.Either(Either(Left))
    ......@@ -41,7 +53,7 @@ import Data.Time (UTCTime)
    import Data.Time.Segment (jour)
    import GHC.Generics (Generic)
    import Gargantext.Core.Types
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Config (nodeTypeId)
    import Gargantext.Database.Schema.Ngrams
    import Gargantext.Database.Schema.Node
    ......@@ -70,9 +82,9 @@ type Title = Text
    -- TODO remove Title
    type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
    type FacetSources = FacetDoc
    type FacetAuthors = FacetDoc
    type FacetTerms = FacetDoc
    -- type FacetSources = FacetDoc
    -- type FacetAuthors = FacetDoc
    -- type FacetTerms = FacetDoc
    data Facet id created title hyperdata favorite ngramCount =
    ......@@ -99,9 +111,7 @@ $(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}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_p_")
    instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
    arbitrary = Pair <$> arbitrary <*> arbitrary
    ......@@ -116,9 +126,7 @@ $(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}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
    instance ( Arbitrary id
    , Arbitrary date
    ......@@ -142,7 +150,8 @@ type FacetPairedRead = FacetPaired (Column PGInt4 )
    $(deriveJSON (unPrefix "facetDoc_") ''Facet)
    -- | Documentation instance
    instance ToSchema FacetDoc
    instance ToSchema FacetDoc where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
    -- | Mock and Quickcheck instances
    instance Arbitrary FacetDoc where
    ......@@ -158,7 +167,7 @@ instance Arbitrary FacetDoc where
    -- Facets / Views for the Front End
    -- | Database instances
    $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
    $(makeLensesWith abbreviatedFields ''Facet)
    -- $(makeLensesWith abbreviatedFields ''Facet)
    type FacetDocRead = Facet (Column PGInt4 )
    (Column PGTimestamptz)
    ......@@ -196,6 +205,7 @@ instance Arbitrary OrderBy
    arbitrary = elements [minBound..maxBound]
    -- TODO-SECURITY check
    runViewAuthorsDoc :: ContactId -> IsTrash -> 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
    ......@@ -236,6 +246,7 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
    ------------------------------------------------------------------------
    -- TODO-SECURITY check
    runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
    runViewDocuments cId t o l order =
    runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
    ......
    src/Gargantext/Database/Flow.hs
    View file @ 76e11752
    ......@@ -31,6 +31,13 @@ Portability : POSIX
    {-# LANGUAGE OverloadedStrings #-}
    module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
    ( FlowCmdM
    , flowCorpusFile
    , flowCorpus
    , flowCorpusSearchInDatabase
    , getOrMkRoot
    , getOrMkRootWithCorpus
    )
    where
    import Prelude (String)
    import Data.Either
    ......@@ -45,7 +52,7 @@ import Data.Monoid
    import Data.Text (Text, splitOn, intercalate)
    import GHC.Show (Show)
    import Gargantext.API.Ngrams (HasRepoVar)
    import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
    import Gargantext.API.Ngrams (NgramsElement, putListNgrams, RepoCmdM)
    import Gargantext.Core (Lang(..))
    import Gargantext.Core.Types (NodePoly(..), Terms(..))
    import Gargantext.Core.Types.Individu (Username)
    ......@@ -99,30 +106,32 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth
    getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Just q)
    flowCorpusApi :: ( FlowCmdM env err m)
    -- UNUSED
    _flowCorpusApi :: ( FlowCmdM env err m)
    => Username -> Either CorpusName [CorpusId]
    -> TermType Lang
    -> Maybe Limit
    -> ApiQuery
    -> m CorpusId
    flowCorpusApi u n tt l q = do
    _flowCorpusApi u n tt l q = do
    docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
    flowCorpus u n tt docs
    ------------------------------------------------------------------------
    flowAnnuaire :: FlowCmdM env err m
    -- UNUSED
    _flowAnnuaire :: FlowCmdM env err m
    => Username -> Either CorpusName [CorpusId] -> (TermType Lang) -> FilePath -> m AnnuaireId
    flowAnnuaire u n l filePath = do
    _flowAnnuaire u n l filePath = do
    docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
    flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
    flowCorpusDebat :: FlowCmdM env err m
    -- UNUSED
    _flowCorpusDebat :: FlowCmdM env err m
    => Username -> Either CorpusName [CorpusId]
    -> Limit -> FilePath
    -> m CorpusId
    flowCorpusDebat u n l fp = do
    _flowCorpusDebat u n l fp = do
    docs <- liftIO ( splitEvery 500
    <$> take l
    <$> readFile' fp
    ......@@ -151,19 +160,22 @@ flowCorpusSearchInDatabase u la q = do
    flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
    flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
    -- UNUSED
    _flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
    => Username -> Lang -> Text -> m CorpusId
    flowCorpusSearchInDatabaseApi u la q = do
    _flowCorpusSearchInDatabaseApi u la q = do
    (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
    ids <- map fst <$> searchInDatabase cId (stemIt q)
    flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
    ------------------------------------------------------------------------
    -- | TODO improve the needed type to create/update a corpus
    {- UNUSED
    data UserInfo = Username Text
    | UserId NodeId
    data CorpusInfo = CorpusName Lang Text
    | CorpusId Lang NodeId
    -}
    flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
    ......
    src/Gargantext/Database/Flow/Pairing.hs
    View file @ 76e11752
    ......@@ -16,6 +16,7 @@ Portability : POSIX
    -- {-# LANGUAGE Arrows #-}
    module Gargantext.Database.Flow.Pairing
    (pairing)
    where
    --import Debug.Trace (trace)
    ......
    src/Gargantext/Database/Node/Contact.hs
    View file @ 76e11752
    ......@@ -22,12 +22,12 @@ module Gargantext.Database.Node.Contact
    import Control.Lens (makeLenses)
    import Data.Aeson.TH (deriveJSON)
    import Data.Swagger (ToSchema)
    import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
    import Data.Text (Text)
    import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (Name)
    import Gargantext.Database.Schema.Node (NodeWrite, node)
    import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
    ......@@ -105,16 +105,22 @@ nodeContactW maybeName maybeContact aId =
    contact = maybe arbitraryHyperdataContact identity maybeContact
    -- | Main instances of Contact
    instance ToSchema HyperdataContact
    instance ToSchema ContactWho
    instance ToSchema ContactWhere
    instance ToSchema ContactTouch
    -- | ToSchema instances
    instance ToSchema HyperdataContact where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hc_")
    instance ToSchema ContactWho where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cw_")
    instance ToSchema ContactWhere where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cw_")
    instance ToSchema ContactTouch where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ct_")
    instance ToSchema ContactMetaData where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cm_")
    -- | Arbitrary instances
    instance Arbitrary HyperdataContact where
    arbitrary = elements [HyperdataContact Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing]
    -- | Specific Gargantext instance
    instance Hyperdata HyperdataContact
    ......
    src/Gargantext/Database/Node/Update.hs
    View file @ 76e11752
    ......@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
    unOnly :: Only a -> a
    unOnly (Only a) = a
    -- TODO-ACCESS
    update :: Update -> Cmd err [Int]
    update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
    (DT.take 255 name,nId)
    ......
    src/Gargantext/Database/TextSearch.hs
    View file @ 76e11752
    ......@@ -82,6 +82,7 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
    type AuthorName = Text
    -- | TODO Optim: Offset and Limit in the Query
    -- TODO-SECURITY check
    searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
    searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
    <$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
    ......@@ -94,6 +95,7 @@ searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop
    maybePair (Pair Nothing _) = Nothing
    maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
    -- TODO-SECURITY check
    searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
    searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
    where
    ......
    src/Gargantext/Database/Tree.hs
    View file @ 76e11752
    ......@@ -16,7 +16,15 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
    module Gargantext.Database.Tree
    ( treeDB
    , TreeError(..)
    , HasTreeError(..)
    , dbTree
    , toNodeTree
    , DbTreeNode
    , isDescendantOf
    ) where
    import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
    import Control.Monad.Error.Class (MonadError(throwError))
    ......@@ -103,7 +111,21 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGS
    SELECT * from tree;
    |] (Only rootId)
    isDescendantOf :: NodeId -> RootId -> Cmd err Bool
    isDescendantOf childId rootId = (== [Only True]) <$> runPGSQuery [sql|
    WITH RECURSIVE
    tree (id, parent_id) AS
    (
    SELECT c.id, c.parent_id
    FROM nodes AS c
    WHERE c.id = ?
    UNION
    SELECT p.id, p.parent_id
    FROM nodes AS p
    INNER JOIN tree AS t ON t.parent_id = p.id
    )
    SELECT COUNT(*) = 1 from tree AS t
    WHERE t.id = ?;
    |] (childId, rootId)
    src/Gargantext/Database/Types/Node.hs
    View file @ 76e11752
    ......@@ -41,9 +41,8 @@ import Data.ByteString.Lazy (ByteString)
    import Data.Either
    import Data.Eq (Eq)
    import Data.Monoid (mempty)
    import Data.Text (Text, unpack, pack)
    import Data.Text (Text, unpack)
    import Data.Time (UTCTime)
    import Data.Time.Segment (jour, timesAfter, Granularity(D))
    import Data.Swagger
    import Text.Read (read)
    ......@@ -55,9 +54,11 @@ import Servant
    import Test.QuickCheck.Arbitrary
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Instances.Time ()
    import Test.QuickCheck.Instances.Text ()
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Viz.Phylo (Phylo)
    --import Gargantext.Database.Utils
    ------------------------------------------------------------------------
    ......@@ -133,12 +134,6 @@ type MasterUserId = UserId
    id2int :: NodeId -> Int
    id2int (NodeId n) = n
    type UTCTime' = UTCTime
    instance Arbitrary UTCTime' where
    arbitrary = elements $ timesAfter 100 D (jour 2000 01 01)
    ------------------------------------------------------------------------
    data Status = Status { status_failed :: !Int
    , status_succeeded :: !Int
    ......@@ -273,18 +268,16 @@ instance Arbitrary Event where
    arbitrary = Event <$> arbitrary <*> arbitrary <*> arbitrary
    instance ToSchema Event where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "event_")
    ------------------------------------------------------------------------
    instance Arbitrary Text where
    arbitrary = elements $ map (\c -> pack [c]) ['a'..'z']
    data Resource = Resource { resource_path :: !(Maybe Text)
    , resource_scraper :: !(Maybe Text)
    , resource_query :: !(Maybe Text)
    , resource_events :: !([Event])
    , resource_status :: !Status
    , resource_date :: !UTCTime'
    , resource_date :: !UTCTime
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "resource_") ''Resource)
    ......@@ -297,7 +290,7 @@ instance Arbitrary Resource where
    <*> arbitrary
    instance ToSchema Resource where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "resource_")
    ------------------------------------------------------------------------
    data HyperdataUser = HyperdataUser { hyperdataUser_language :: Maybe Text
    ......@@ -534,17 +527,20 @@ docExample :: ByteString
    docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",\"publication_minute\":0,\"publication_month\":7,\"language_iso3\":\"eng\",\"publication_second\":0,\"authors\":\"Nils Hovdenak, Kjell Haram\",\"publication_year\":2012,\"publication_date\":\"2012-07-06 00:00:00+00:00\",\"language_name\":\"English\",\"realdate_full_\":\"2012 01 12\",\"source\":\"European journal of obstetrics, gynecology, and reproductive biology\",\"abstract\":\"The literature was searched for publications on minerals and vitamins during pregnancy and the possible influence of supplements on pregnancy outcome.\",\"title\":\"Influence of mineral and vitamin supplements on pregnancy outcome.\",\"publication_hour\":0}"
    instance ToSchema HyperdataCorpus where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataCorpus_") proxy
    & mapped.schema.description ?~ "a corpus"
    & mapped.schema.example ?~ toJSON hyperdataCorpus
    instance ToSchema HyperdataAnnuaire where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataAnnuaire_") proxy
    & mapped.schema.description ?~ "an annuaire"
    & mapped.schema.example ?~ toJSON hyperdataAnnuaire
    instance ToSchema HyperdataDocument where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "_hyperdataDocument_") proxy
    & mapped.schema.description ?~ "a document"
    & mapped.schema.example ?~ toJSON hyperdataDocument
    ......@@ -560,14 +556,16 @@ instance ToSchema hyperdata =>
    (Maybe UserId)
    ParentId NodeName
    UTCTime hyperdata
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
    instance ToSchema hyperdata =>
    ToSchema (NodePoly NodeId NodeTypeId
    UserId
    (Maybe ParentId) NodeName
    UTCTime hyperdata
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
    instance ToSchema hyperdata =>
    ......@@ -575,16 +573,19 @@ instance ToSchema hyperdata =>
    (Maybe UserId)
    ParentId NodeName
    UTCTime hyperdata (Maybe TSVector)
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
    instance ToSchema hyperdata =>
    ToSchema (NodePolySearch NodeId NodeTypeId
    UserId
    (Maybe ParentId) NodeName
    UTCTime hyperdata (Maybe TSVector)
    )
    ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
    instance ToSchema Status
    instance ToSchema Status where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "status_")
    src/Gargantext/Viz/Graph.hs
    View file @ 76e11752
    ......@@ -24,7 +24,7 @@ import Data.Swagger
    import Data.Text (Text, pack)
    import GHC.Generics (Generic)
    import GHC.IO (FilePath)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (ListId)
    import Gargantext.Database.Types.Node (NodeId)
    import Gargantext.Prelude
    ......@@ -57,9 +57,7 @@ data Node = Node { node_size :: Int
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "node_") ''Node)
    instance ToSchema Node where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
    data Edge = Edge { edge_source :: Text
    ......@@ -71,9 +69,7 @@ data Edge = Edge { edge_source :: Text
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "edge_") ''Edge)
    instance ToSchema Edge where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
    ---------------------------------------------------------------
    data LegendField = LegendField { _lf_id :: Int
    ......@@ -83,9 +79,7 @@ data LegendField = LegendField { _lf_id :: Int
    $(deriveJSON (unPrefix "_lf_") ''LegendField)
    instance ToSchema LegendField where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
    makeLenses ''LegendField
    --
    ......@@ -97,9 +91,7 @@ data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the grap
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
    instance ToSchema GraphMetadata where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
    makeLenses ''GraphMetadata
    ......@@ -112,10 +104,7 @@ $(deriveJSON (unPrefix "_graph_") ''Graph)
    makeLenses ''Graph
    instance ToSchema Graph where
    declareNamedSchema =
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
    -- | Intances for the mack
    instance Arbitrary Graph where
    ......
    src/Gargantext/Viz/Phylo.hs
    View file @ 76e11752
    ......@@ -37,10 +37,11 @@ import Data.Text (Text)
    import Data.Set (Set)
    import Data.Map (Map)
    import Data.Vector (Vector)
    import Data.Swagger
    --import Data.Time.Clock.POSIX (POSIXTime)
    import GHC.Generics (Generic)
    --import Gargantext.Database.Schema.Ngrams (NgramsId)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Text.Context (TermList)
    import Gargantext.Prelude
    ......@@ -517,6 +518,57 @@ $(deriveJSON (unPrefix "_pn_" ) ''PhyloNode )
    $(deriveJSON defaultOptions ''Filiation )
    $(deriveJSON defaultOptions ''EdgeType )
    ---------------------------
    -- | Swagger instances | --
    ---------------------------
    instance ToSchema Phylo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    instance ToSchema PhyloFoundations where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_foundations")
    instance ToSchema PhyloPeriod where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_period")
    instance ToSchema PhyloLevel where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_level")
    instance ToSchema PhyloGroup where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_group")
    instance ToSchema PhyloFis where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phyloFis_")
    instance ToSchema Software where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_software_")
    instance ToSchema PhyloParam where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phyloParam_")
    instance ToSchema Filter
    instance ToSchema Metric
    instance ToSchema Cluster
    instance ToSchema Proximity where
    declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
    instance ToSchema FisParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fis_")
    instance ToSchema HammingParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hamming_")
    instance ToSchema LouvainParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_louvain_")
    instance ToSchema RCParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_rc_")
    instance ToSchema WLJParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wlj_")
    instance ToSchema LBParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lb_")
    instance ToSchema SBParams where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_sb_")
    instance ToSchema PhyloQueryBuild where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_q_")
    instance ToSchema PhyloView where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pv_")
    instance ToSchema PhyloBranch where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pb_")
    instance ToSchema PhyloEdge where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pe_")
    instance ToSchema PhyloNode where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pn_")
    instance ToSchema Filiation
    instance ToSchema EdgeType
    ----------------------------
    -- | TODO XML instances | --
    ......
    src/Gargantext/Viz/Phylo/API.hs
    View file @ 76e11752
    ......@@ -29,7 +29,6 @@ import qualified Data.ByteString as DB
    import qualified Data.ByteString.Lazy as DBL
    import Data.Swagger
    import Gargantext.API.Types
    import Gargantext.API.Utils (swaggerOptions)
    import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
    import Gargantext.Database.Schema.Node (insertNodes, nodePhyloW, getNodePhylo)
    import Gargantext.Database.Types.Node -- (NodePhylo(..))
    ......@@ -153,33 +152,7 @@ instance Arbitrary Phylo
    where
    arbitrary = elements [phylo]
    instance ToSchema Cluster
    instance ToSchema EdgeType
    instance ToSchema Filiation
    instance ToSchema Filter
    instance ToSchema FisParams
    instance ToSchema HammingParams
    instance ToSchema LouvainParams
    instance ToSchema Metric
    instance ToSchema Order
    instance ToSchema Phylo
    instance ToSchema PhyloFis
    instance ToSchema PhyloBranch
    instance ToSchema PhyloEdge
    instance ToSchema PhyloGroup
    instance ToSchema PhyloLevel
    instance ToSchema PhyloNode
    instance ToSchema PhyloParam
    instance ToSchema PhyloFoundations
    instance ToSchema PhyloPeriod
    instance ToSchema PhyloQueryBuild
    instance ToSchema PhyloView
    instance ToSchema RCParams
    instance ToSchema LBParams
    instance ToSchema SBParams
    instance ToSchema Software
    instance ToSchema WLJParams
    instance ToParamSchema Order
    instance FromHttpApiData Order
    ......@@ -213,13 +186,6 @@ instance FromHttpApiData Sort
    parseUrlPiece = readTextData
    instance ToParamSchema Sort
    instance ToSchema Proximity
    where
    declareNamedSchema = genericDeclareNamedSchemaUnrestricted
    $ swaggerOptions ""
    instance FromHttpApiData [Tagger]
    where
    parseUrlPiece = readTextData
    ......
    stack.yaml
    View file @ 76e11752
    ......@@ -6,7 +6,7 @@ packages:
    docker:
    enable: false
    repo: 'cgenie/stack-build:lts-12.26'
    repo: 'fpco/stack-build:lts-14.6-garg'
    allow-newer: true
    extra-deps:
    ......
    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